      DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB,
     $                            AFB, LDAFB, IPIV, CMODE, C, INFO,
     $     WORK, IWORK )
*
*     -- LAPACK routine (version 3.2)                                 --
*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
*     -- Jason Riedy of Univ. of California Berkeley.                 --
*     -- November 2008                                                --
*
*     -- LAPACK is a software package provided by Univ. of Tennessee, --
*     -- Univ. of California Berkeley and NAG Ltd.                    --
*
      IMPLICIT NONE
*     ..
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            N, LDAB, LDAFB, INFO, KL, KU, CMODE
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * ), IPIV( * )
      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ),
     $                   C( * )
*
*     DLA_GERCOND Estimates the Skeel condition number of  op(A) * op2(C)
*     where op2 is determined by CMODE as follows
*     CMODE =  1    op2(C) = C
*     CMODE =  0    op2(C) = I
*     CMODE = -1    op2(C) = inv(C)
*     The Skeel condition number  cond(A) = norminf( |inv(A)||A| )
*     is computed by computing scaling factors R such that
*     diag(R)*A*op2(C) is row equilibrated and computing the standard
*     infinity-norm condition number.
*     WORK is a double precision workspace of size 5*N, and
*     IWORK is an integer workspace of size N.
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRANS
      INTEGER            KASE, I, J, KD
      DOUBLE PRECISION   AINVNM, TMP
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLACN2, DGBTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
      DLA_GBRCOND = 0.0D+0
*
      INFO = 0
      NOTRANS = LSAME( TRANS, 'N' )
      IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T')
     $     .AND. .NOT. LSAME(TRANS, 'C') ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -4
      ELSE IF( KU.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
         INFO = -8
      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLA_GBRCOND', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 ) THEN
         DLA_GBRCOND = 1.0D+0
         RETURN
      END IF
*
*     Compute the equilibration matrix R such that
*     inv(R)*A*C has unit 1-norm.
*
      KD = KU + 1
      IF ( NOTRANS ) THEN
         DO I = 1, N
            TMP = 0.0D+0
               IF ( CMODE .EQ. 1 ) THEN
                  DO J = 1, N
                     IF ( I.GE.MAX( 1, J-KU )
     $                    .AND. I.LE.MIN( N, J+KL ) ) THEN
                        TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) )
                     END IF
                  END DO
               ELSE IF ( CMODE .EQ. 0 ) THEN
                  DO J = 1, N
                     IF ( I.GE.MAX( 1, J-KU )
     $                    .AND. I.LE.MIN( N, J+KL ) ) THEN
                        TMP = TMP + ABS( AB( KD+I-J, J ) )
                     END IF
                  END DO
               ELSE
                  DO J = 1, N
                     IF ( I.GE.MAX( 1, J-KU )
     $                    .AND. I.LE.MIN( N, J+KL ) ) THEN
                        TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) )
                     END IF
                  END DO
               END IF
            WORK( 2*N+I ) = TMP
         END DO
      ELSE
         DO I = 1, N
            TMP = 0.0D+0
            IF ( CMODE .EQ. 1 ) THEN
               DO J = 1, N
                  IF ( I.GE.MAX( 1, J-KU )
     $                 .AND. I.LE.MIN( N, J+KL ) ) THEN
                     TMP = TMP + ABS( AB( J, KD+I-J ) * C( J ) )
                  END IF
               END DO
            ELSE IF ( CMODE .EQ. 0 ) THEN
               DO J = 1, N
                  IF ( I.GE.MAX( 1, J-KU )
     $                 .AND. I.LE.MIN( N, J+KL ) ) THEN
                     TMP = TMP + ABS(AB(J,KD+I-J))
                  END IF
               END DO
            ELSE
               DO J = 1, N
                  IF ( I.GE.MAX( 1, J-KU )
     $                 .AND. I.LE.MIN( N, J+KL ) ) THEN
                     TMP = TMP + ABS( AB( J, KD+I-J ) / C( J ) )
                  END IF
               END DO
            END IF
            WORK( 2*N+I ) = TMP
         END DO
      END IF
*
*     Estimate the norm of inv(op(A)).
*
      AINVNM = 0.0D+0

      KASE = 0
   10 CONTINUE
      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
      IF( KASE.NE.0 ) THEN
         IF( KASE.EQ.2 ) THEN
*
*           Multiply by R.
*
            DO I = 1, N
               WORK( I ) = WORK( I ) * WORK( 2*N+I )
            END DO

            IF ( NOTRANS ) THEN
               CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB,
     $              IPIV, WORK, N, INFO )
            ELSE
               CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV,
     $              WORK, N, INFO )
            END IF
*
*           Multiply by inv(C).
*
            IF ( CMODE .EQ. 1 ) THEN
               DO I = 1, N
                  WORK( I ) = WORK( I ) / C( I )
               END DO
            ELSE IF ( CMODE .EQ. -1 ) THEN
               DO I = 1, N
                  WORK( I ) = WORK( I ) * C( I )
               END DO
            END IF
         ELSE
*
*           Multiply by inv(C').
*
            IF ( CMODE .EQ. 1 ) THEN
               DO I = 1, N
                  WORK( I ) = WORK( I ) / C( I )
               END DO
            ELSE IF ( CMODE .EQ. -1 ) THEN
               DO I = 1, N
                  WORK( I ) = WORK( I ) * C( I )
               END DO
            END IF

            IF ( NOTRANS ) THEN
               CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV,
     $              WORK, N, INFO )
            ELSE
               CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB,
     $              IPIV, WORK, N, INFO )
            END IF
*
*           Multiply by R.
*
            DO I = 1, N
               WORK( I ) = WORK( I ) * WORK( 2*N+I )
            END DO
         END IF
         GO TO 10
      END IF
*
*     Compute the estimate of the reciprocal condition number.
*
      IF( AINVNM .NE. 0.0D+0 )
     $   DLA_GBRCOND = ( 1.0D+0 / AINVNM )
*
      RETURN
*
      END


module symmQRBM
  use debugging
  use matrices

  implicit none

  private :: logfile, right_translate, compute_theta, wf, compute_VarOp
  public :: s_init, s_delete,s_SR

  character*20 :: logfile="symm_outlog.txt"

  type :: sRBM
     integer :: Nv, alpha, dmn
     double precision ::  spin
     double complex, allocatable :: a(:),b(:)
     double complex, allocatable :: W(:,:)
  end type sRBM

contains

  subroutine s_init(self, Nv, alpha, spin)
    implicit none
    type(sRBM):: self
    integer, intent(in) :: Nv, alpha
    integer ::  status, ii, jj
    double precision, intent(in) :: spin
    double precision ::  re, im
    logical :: ca = .false., cb = .false., cW = .false.

    self%Nv = Nv
    self%alpha = alpha
    self%dmn = 2*alpha +Nv*alpha
    self%spin = spin

    allocate(self%a(alpha), stat=status)
    if (status .eq. 0) ca = .true.

    allocate(self%b(alpha), stat = status)
    if (status .eq. 0) cb = .true.

    allocate(self%W(Nv,alpha), stat = status)
    if (status .eq. 0) cW = .true.

    if (ca .and. cb .and. cW .eqv. .true.) then
       print *,"RBM succesfully initialized"
    else
       print *,"RBM allocation: FAILED"
       stop
    endif

    do ii=1,alpha
       call random_number(re)
       call random_number(im)
       self%a(ii) = complex(re*0.2-0.1,im*0.2-0.1)
    enddo

    do jj=1,alpha
       call random_number(re)
       call random_number(im)
       self%b(jj) = complex(re*0.2-0.1,im*0.2-0.1)
    enddo

    do jj=1,alpha
       do ii=1,Nv
          call random_number(re)
          call random_number(im)
          self%W(ii,jj) = complex(re*0.2-0.1,im*0.2-0.1)
       enddo
    enddo

  end subroutine s_init

  subroutine s_delete(self)
    implicit none
    type(sRBM) :: self
    deallocate(self%a, self%b, self%W)

    print *, "RBM succesfully deleted"

  end subroutine s_delete

   subroutine right_translate(self,S)
    implicit none
    type(sRBM), intent(in) :: self
    integer :: ii
    double complex :: S(self%Nv), S_temp(self%Nv)

    do  ii=1,self%Nv-1
       S_temp(ii+1) = S(ii)
    enddo

    S_temp(1) = S(self%Nv)

    S = S_temp

  end subroutine right_translate

  subroutine compute_theta(self, S, theta)
    implicit none
    type(sRBM), intent(in) :: self
    double complex, intent(in) :: S(self%Nv)
    double complex, intent(out) :: theta(self%alpha)

    theta = self%b+matmul(S, self%W)

  end subroutine compute_theta

  double complex function wf(self,S)
    implicit none
    type(sRBM), intent(in) :: self
    integer :: ss,jj
    double complex, dimension(self%Nv) :: S
    double complex, dimension(self%alpha) :: theta, act

    ! Initialize wave function
    wf = exp(sum(self%a)*sum(S))

       ! Add product of cosh
       do ss=1,self%Nv

          ! Compute theta
          call compute_theta(self, S, theta)

          !print *, "theta", double precision(sum((conjg(theta)*theta)**2))

          ! Compute activation
          act = cosh(theta)

          do jj=1,self%alpha
             !print *, "act", double precision(sum((conjg(act)*act)**2))
             wf = wf*act(jj)
          enddo

          !Translate spin configuration
          call right_translate(self,S)

       enddo

       ! We translate S Nv times, so in the end it should be equal to original one

  end function wf

  double complex function Ising_loc(self, S, h, pbc)
    implicit none
    type(sRBM), intent(in) :: self
    integer :: ii, jj,ss, iph
    double precision, intent(in) :: h
    double complex:: frac
    double complex, dimension(self%Nv) :: S
    double complex, dimension(self%alpha) :: theta, theta_new, act, act_new
    logical, intent(in) :: pbc

    ! Initialize local energy
    Ising_loc = complex(0d0,0d0)

    ! Linear term
    do  ii=1,self%Nv

       ! Take the difference of exponential part
       frac = exp(-2.*sum(self%a)*S(ii))

       ! Add product of cosh

       do ss=0,self%Nv-1

          ! Compute theta
          call compute_theta(self, S, theta)

          !print *, "theta", double precision(sum((conjg(theta)*theta)**2))

          ! Compute activation
          act = cosh(theta)

          ! Copmute permutation index
          iph = mod(ii+ss-1,self%Nv)+1

          !print *, "ii", ii, "iph", iph

          ! Compute theta of new configuration
          theta_new = theta - 2.*self%W(iph,:)*S(iph)

          !print *, S(iph)-temp_spin

          !Compute  act_new
          act_new = cosh(theta_new)

          do jj=1, self%alpha
             !print *, "act", double precision(sum((conjg(act)*act)**2))
             frac = frac*act_new(jj)/act(jj)
          enddo

          !Translate spin configuration
          call right_translate(self,S)

       enddo

       ! Update local energy
       Ising_loc = Ising_loc - frac

    enddo

    ! Add field
    Ising_loc = Ising_loc*h

    ! Interaction term
    do ii=1,self%Nv-1
       Ising_loc = Ising_loc -S(ii)*S(ii+1)
    end do

    ! Periodic boundary conditions

    if (pbc .eqv. .true.) then
       Ising_loc = Ising_loc - S(1)*S(self%Nv)
    endif

  end function Ising_loc

  double complex function Heisenberg_loc(self, S, pbc)
    implicit none
    type(sRBM), intent(in) :: self
    integer :: ii, jj,ss, iph1, iph2
    double complex:: frac
    double complex, dimension(self%Nv) :: S
    double complex, dimension(self%alpha) :: theta, theta_new, act, act_new
    logical, intent(in) :: pbc

    ! Initialize local energy
    Heisenberg_loc = complex(0d0,0d0)

    ! Bulk term
    do  ii=1,self%Nv-1

       ! Take the difference of exponential part
       frac = exp(-2.*sum(self%a)*(S(ii)+S(ii+1)))

       ! Add product of cosh

       do ss=0,self%Nv-1

          ! Compute theta
          call compute_theta(self, S, theta)

          !print *, "theta", double precision(sum((conjg(theta)*theta)**2))

          ! Compute activation
          act = cosh(theta)

          ! Compute permutation index realtive to ii
          iph1 = mod(ii+ss-1,self%Nv)+1

          ! Compute permutation index realtive to ii+1
          iph2 = mod(ii+ss,self%Nv)+1

          ! Compute theta of new configuration
          theta_new = theta - 2.*self%W(iph1,:)*S(iph1) - 2.*self%W(iph2,:)*S(iph2)

          !print *, S(iph)-temp_spin

          !Compute  act_new
          act_new = cosh(theta_new)

          do jj=1, self%alpha
             !print *, "act", double precision(sum((conjg(act)*act)**2))
             frac = frac*act_new(jj)/act(jj)
          enddo

          !Translate spin configuration
          call right_translate(self,S)

       enddo

       ! Update local energy
       Heisenberg_loc = Heisenberg_loc - frac*(1-S(ii)*S(ii+1))+S(ii)*S(ii+1)

    enddo

    ! Periodic boundary conditions

    if (pbc .eqv. .true.) then

       ! Take the difference of exponential part
       frac = exp(-2.*sum(self%a)*(S(1)+S(self%Nv)))

       ! Add product of cosh

       do ss=0,self%Nv-1

          ! Compute theta
          call compute_theta(self, S, theta)

          !print *, "theta", double precision(sum((conjg(theta)*theta)**2))

          ! Compute activation
          act = cosh(theta)

          ! Compute permutation index realtive to 1
          iph1 = mod(ss,self%Nv)+1

          ! Compute permutation index realtive to self%Nv
          iph2 = mod(self%Nv+ss-1,self%Nv)+1

          ! Compute theta of new configuration
          theta_new = theta - 2.*self%W(iph1,:)*S(iph1) - 2.*self%W(iph2,:)*S(iph2)

          !print *, S(iph)-temp_spin

          !Compute  act_new
          act_new = cosh(theta_new)

          do jj=1, self%alpha
             !print *, "act", double precision(sum((conjg(act)*act)**2))
             frac = frac*act_new(jj)/act(jj)
          enddo

          !Translate spin configuration
          call right_translate(self,S)

       enddo

       ! Update local energy
       Heisenberg_loc = Heisenberg_loc - frac*(1-S(1)*S(self%Nv))+S(1)*S(self%Nv)

    endif

  end function Heisenberg_loc

  double precision function sample_wf(self, S, N_sweeps)
    implicit none
    type(sRBM), intent(in) :: self
    integer, intent(in) :: N_sweeps
    integer :: sweep,jj, ss, site, iph
    double precision :: uu, prob
    double complex:: frac
    double complex, dimension(self%Nv):: S
    double complex, dimension(self%alpha) :: theta, theta_new, act, act_new

    do sweep=1,self%Nv*N_sweeps

       ! Generate a site in (1,.., Nv)
       call random_number(uu)
       site = int(floor(self%Nv*uu)+1.)

       ! Initialize the fraction
       frac = exp(-2.*sum(self%a)*S(site))

       ! Add product of cosh

       do ss=0,self%Nv-1

          ! Compute theta
          call compute_theta(self, S, theta)

          !print *, "theta", double precision(sum((conjg(theta)*theta)**2))

          ! Compute activation
          act = cosh(theta)

          ! Compute index of permutation site
          iph = mod(site+ss-1,self%Nv)+1

          ! Compute theta of new configuration
          theta_new = theta - 2.*self%W(iph,:)*S(iph)

          !Compute act_new
          act_new = cosh(theta_new)

          do jj=1, self%alpha
             !print *, "act", double precision(sum((conjg(act)*act)**2))
             frac = frac*act_new(jj)/act(jj)
          enddo

          !Translate spin configuration
          call right_translate(self,S)

       enddo

       ! Compute the probability
       prob = min(1., dble(conjg(frac)*frac))

       !print *, "prob", prob

       ! Metropolis algorithm
       call random_number(uu)
       if (uu.le.prob) then
          S(site) = -1.*S(site)
       endif

    enddo

    ! Compute the square wave function of sampled configuration
    sample_wf = dble(conjg(wf(self,S))*wf(self,S))

  end function sample_wf

  subroutine compute_VarOp(self, S, O)
    implicit none
    type(sRBM), intent(in) :: self
    integer :: ii,jj,ss
    double complex, intent(in) :: S(self%Nv)
    double complex :: Oh(self%alpha), theta(self%alpha), act(self%alpha)
    double complex, intent(out) :: O(self%dmn)

    ! Copmute variational operator
    O(1:self%alpha) = sum(S)

    Oh = complex(0d0,0d0)
    do  ii=1,self%Nv
       call  compute_theta(self, S, theta)
       Oh = Oh+tanh(theta)
       call right_translate(self,S)
    enddo

    O(self%alpha+1:2*self%alpha) = Oh

    do jj=1,self%alpha
       do ii=1,self%Nv
          O(self%alpha+self%alpha+(jj-1)*self%Nv+ii)=complex(0d0,0d0)
          do ss=0,self%Nv-1
             call compute_theta(self,S,theta)
             act= tanh(theta)
             O(self%alpha+self%alpha+(jj-1)*self%Nv+ii) =  O(self%alpha+self%alpha+(jj-1)*self%Nv+ii) + S(ii)*act(jj)
             call right_translate(self,S)
          enddo
       enddo
    enddo

   end subroutine compute_VarOp

  subroutine s_SR(self, model, h, pbc, steps, N_sweeps, N_samples, E, debug)
    implicit none
    type(sRBM) :: self
    integer :: step, sample, ii,jj
    integer, intent(in) :: model, steps, N_sweeps, N_samples
    double precision :: norm, square_wf, lr, uu, threshold, start, finish
    double precision, intent(in) :: h
    double precision, intent(out) :: E(steps)
    double complex :: Eloc_av, Eloc, S(self%Nv)
    double complex, dimension(self%dmn) :: O, Odag, O_av, Odag_av, ElocOdag, ElocOdag_av, Force
    double complex, dimension(self%dmn, self%dmn) :: OdagO,OdagO_av, t_dot, Fisher, Inverse
    logical, intent(in) :: pbc , debug

    threshold = 0.00001

    open(9, file=logfile, status="unknown")

    if(debug) then
       write(9,*) "Logfile for symmetric RBM ansatz"
       write(9,*) "    "
       if(model.eq.0) then
          write(9,*) "Model: Heisenberg"
          write(9,*) "Parameters:"
          write(9,*) "Number of spins:   ", self%Nv
          write(9,*) "Alpha:   ", self%alpha
          write(9,*) "Number of variational parameters:   ", self%dmn
          write(9,*) "Periodic boundary conditions:   ", pbc
          write(9,*) "Number  of SR iterations:   ", steps
          write(9,*) "Number of MC sweep through the lattice:   ", N_sweeps
          write(9,*) "Number of samples:   ", N_samples
       elseif(model.eq.1) then
          write(9,*) "Model: Ising"
          write(9,*) "Parameters:"
          write(9,*) "Number of spins:   ", self%Nv
          write(9,*) "Alpha:   ", self%alpha
          write(9,*) "Number of variational parameters:   ", self%dmn
          write(9,*) "H_field:   ", h
          write(9,*) "Periodic boundary conditions:   ", pbc
          write(9,*) "Number  of SR iterations:   ", steps
          write(9,*) "Number of MC sweep through the lattice:   ", N_sweeps
          write(9,*) "Number of samples:   ", N_samples
       else
          write(9,*) "Unrecognize model"
          write(9,*) "Computation stopped."
          stop
       endif

       write(9,*) "*************************************************************************************************"

       write(9,*) "Starting Sochastic Reconfiguration..."
    endif

    do step=1,steps

       if(debug) then
          write(9,*) "Epoch: ", step
       end if

       ! Initialize tensors
       OdagO_av = complex(0d0,0d0)
       Odag_av = complex(0d0,0d0)
       O_av = complex(0d0,0d0)
       ElocOdag_av = complex(0d0,0d0)
       Eloc_av = complex(0d0,0d0)
       norm = 0.0

       !Generate the standard sequence
       do ii=1,self%Nv
          call random_number(uu)
          uu = (2.*floor(2*uu)-1.)*self%spin
          S(ii) = uu
       enddo

       if(debug) then
          write(9,*) "Square a:   ", dble(sum(conjg(self%a)*self%a))
          write(9,*) "Square b:   ", dble(sum(conjg(self%b)*self%b))
          write(9,*) "Square W:   ", dble(sum(conjg(self%W)*self%W))
       endif

       ! Sample sequence and probability according to thermalize MCMC
       square_wf = sample_wf(self, S, 100)

       if(debug) then
          write(9,*)   "-------------------------------------------------------------------------------------------------"
          write(9,*) "Starting sampling..."
       endif

       call cpu_time(start)
       do sample=1,N_samples

          ! Sample sequence and probability according to MCMC
          square_wf = sample_wf(self, S, N_sweeps)

          ! Compute O and Odag
          call compute_VarOp(self, S, O)
          Odag = conjg(O)

          !write(9,*) "Variational operator:   ", O

          ! Compute OdagO
          do jj=1,self%dmn
             do ii=1,self%dmn
                OdagO(ii,jj) = Odag(ii)*O(jj)
             enddo
          enddo

          ! Compute Eloc
          if (model .eq. 0) then
             Eloc = Heisenberg_loc(self,S, pbc)
          elseif (model .eq. 1) then
             Eloc = Ising_loc(self, S, h, pbc)
          else
             print *, "Undefined model"
             stop
          endif

          ! Copmute ElocOdag
          ElocOdag = Eloc*Odag

          ! Update averages
          norm = norm+square_wf
          ElocOdag_av = ElocOdag_av+ElocOdag*square_wf
          Eloc_av =  Eloc_av+Eloc*square_wf

          OdagO_av = OdagO_av + OdagO*square_wf
          O_av = O_av +O*square_wf
          Odag_av = Odag_av +Odag*square_wf

       enddo

       call cpu_time(finish)

       if(debug) then
          write(9,*) "Sampling recap:"
          write(9,*) "Sampling time (s):   ", finish-start
          write(9,*) "Last sampled square_wf:   ", square_wf
          write(9,*) "Normalization constant:   ", norm
          write(9,*) "End sampling."
          write(9,*)  "-------------------------------------------------------------------------------------------------"
       endif

       !Compute t_dot
       do jj=1,self%dmn
          do ii=1,self%dmn
             t_dot(ii,jj) = Odag_av(ii)*O_av(jj)
          enddo
       enddo

       ! Compute Fisher matrix
       Fisher = OdagO_av/norm-t_dot/norm**2

       if(debug) then
          write(9,*) "Sum squared Fisher matrix:   ", sum(conjg(Fisher)*Fisher)
          !Check hermiticity
          call check_hermiticity(Fisher, threshold, logfile)
       endif

       ! Compute learning rate
       lr =max(0.01*(0.95**step), 0.001)

       ! Regularize Fisher matrix
       do ii=1,self%dmn
          Fisher(ii,ii) = Fisher(ii,ii)+ 0.0001
       enddo

       !call print_matrix(Fisher)

       if(debug) then
          write(9,*) "Sum squared regularized Fisher matrix:   ", sum(conJG(Fisher)*Fisher)
       endif

       !print *, "Fisher", Fisher

       Inverse = Fisher
       call cpu_time(start)
       ! Invert Fisher matrix
       call inv_herm(Inverse)
       call cpu_time(finish)

       if(debug) then
          write(9,*) "Inversion time(s):   ", finish-start
          ! Check inverse
          call check_inverse(Fisher, Inverse, threshold, logfile)
       endif

       ! Compute the force
       Force = ElocOdag_av/norm-Eloc_av*Odag_av/norm**2

       if(debug) then
          write(9,*) "Sum squared Force:   ", sum(conjg(Force)*Force)
          write(9,*) "Sum squared Inverse:   ", sum(conjg(Inverse)*Inverse)
       end if

       ! Compute new weights (save in Force)
       Force = lr*matmul(Inverse, Force)

       if(debug) then
          write(9,*) "Sum squared learning force:   ", sum(conjg(Force)*Force)
          !write(9,*) "Learning force:   ", Force
       endif

       ! Update weights and biases
       self%a = self%a -Force(1:self%alpha)
       self%b = self%b - Force(self%alpha+1: self%alpha+self%alpha)

       do jj=1,self%alpha
          do ii=1,self%Nv
             self%W(ii,jj) = self%W(ii,jj) - Force(self%alpha+self%alpha+(jj-1)*self%Nv+ii)
          enddo
       enddo

       if(debug) then
          write(9,*) "Expected energy:   ", Eloc_av/norm
       endif

       E(step) = dble(Eloc_av/norm)

       if(debug) then
          write(9,*) "End of epoch:   ", step, "."
          write(9,*)  "*************************************************************************************************"
       endif

    enddo

  end subroutine s_SR

end module symmQRBM


module NEQ_FFT_GF
  USE SF_CONSTANTS, only: xi,pi
  USE SF_FFT_FFTPACK
  implicit none
  private

  public :: fft_rw2rt
  public :: fft_rt2rw
  public :: fft_iw2tau
  public :: fft_tau2iw
  public :: fft_gbeta_minus

contains

  !+----------------------------------------------------------------+
  !PURPOSE  : Modified real-axis FFT to deal with the special 0:L
  ! form of the time-axis Keldysh GF.
  !+----------------------------------------------------------------+
  function fft_rw2rt(func_in) result(func_out)
    complex(8),dimension(:)               :: func_in
    complex(8),dimension(0:size(func_in)) :: func_out
    complex(8),dimension(size(func_in))   :: ftmp
    ftmp = func_in
    call fft(ftmp)
    call fftex(ftmp)
    func_out = fftshift(ftmp)*size(ftmp)
  end function fft_rw2rt
  !
  function fft_rt2rw(func_in) result(func_out)
    complex(8),dimension(:)               :: func_in
    complex(8),dimension(size(func_in)-1) :: func_out
    complex(8),dimension(size(func_in)-1) :: ftmp
    ftmp = func_in
    call ifft(ftmp)
    call fftex(ftmp)
    func_out = ifftshift(ftmp)
  end function fft_rt2rw

  !+-------------------------------------------------------------------+
  !PURPOSE  : Evaluate the FFT of a given function from Matsubara frequencies
  ! to imaginary time.
  !COMMENT  : The routine implements all the necessary manipulations required
  !by the FFT in this formalism: tail subtraction and reshaping.
  !Output is only for tau\in[0,beta]
  !if g(-tau) is required this has to be implemented in the calling code
  !using the transformation: g(-tau)=-g(beta-tau) for tau>0
  !+-------------------------------------------------------------------+
  subroutine fft_iw2tau(gw,gt,beta,notail,nofix)
    implicit none
    integer                             :: i,n,L
    logical,optional                    :: notail,nofix
    logical                             :: notail_,nofix_
    complex(8),dimension(:)             :: gw
    real(8),dimension(0:)               :: gt
    complex(8),dimension(:),allocatable :: tmpGw
    real(8),dimension(:),allocatable    :: tmpGt
    complex(8)                          :: tail
    real(8)                             :: wmax,beta,mues,tau,dtau,At,w
    notail_=.false.;if(present(notail))notail_=notail
    nofix_ =.false.;if(present(nofix))nofix_=nofix
    !
    n=size(gw)     ; L=size(gt)-1 ; dtau=beta/real(L,8)
    !
    allocate(tmpGw(2*L),tmpGt(-L:L))
    !
    wmax = pi/beta*real(2*N-1,8)
    mues =-dreal(gw(N))*wmax**2
    tmpGw= (0.d0,0.d0)
    !
    select case(notail_)
    case default
       do i=1,L
          w=pi/beta*dble(2*i-1)
          tail=-(mues+w*(0.d0,1.d0))/(mues**2+w**2)
          ! tmpGw(2*i)= gw(i)-tail
          if(i<=n)tmpGw(2*i)= gw(i)-tail
          if(i>n)tmpGw(2*i)= tail
       enddo
       call fft(tmpGw)
       tmpGt(-L:L-1) = -dreal(tmpGw)*2*size(tmpGw)/beta
       do i=0,L-1
          tau=real(i,8)*dtau
          if(mues > 0.d0)then
             if((mues*beta) > 30.d0)then
                At = -exp(-mues*tau)
             else
                At = -exp(-mues*tau)/(1.d0 + exp(-beta*mues))
             endif
          else
             if((mues*beta) < -30.d0)then
                At = -exp(mues*(beta-tau))
             else
                At = -exp(-mues*tau)/(1.d0 + exp(-beta*mues))
             endif
          endif
          gt(i) = tmpGt(i) + At
       enddo
       if(.not.nofix_)gt(L)=-(gt(0)+1.d0)
    case(.true.)
       if(L/=N)then
          print*,"error in fftgf_iw2tau: call w/ notail and L/=N"
          stop
       endif
       forall(i=1:L)tmpGw(2*i)  = gw(i)
       call fft(tmpGw)
       tmpGt(-L:L-1) = -dreal(tmpGw)*2*size(tmpGw)/beta
       tmpGt(L)=-tmpGt(0)
       gt(0:L-1) = tmpGt(0:L-1)
       gt(L)=-gt(0)
    end select
    deallocate(tmpGw,tmpGt)
  end subroutine fft_iw2tau

  !+-------------------------------------------------------------------+
  !PURPOSE  :
  !+-------------------------------------------------------------------+
  subroutine fft_tau2iw(gt,gw,beta)
    real(8)                :: gt(0:)
    complex(8)             :: gw(:)
    real(8)                :: beta
    integer                :: i,L,n,M
    complex(8),allocatable :: Igw(:)
    real(8),allocatable    :: Igt(:)
    L=size(gt)-1    ; N=size(gw)
    M=32*N
    allocate(Igt(-M:M),Igw(2*M))
    call interp(gt(0:L),Igt(0:M),L,M)
    forall(i=1:M)Igt(-i)=-Igt(M-i) !Valid for every fermionic GF (bosonic case not here)
    Igw = Igt(-M:M-1)
    call ifft(Igw)
    forall(i=1:n)gw(i)=-Igw(2*i)/size(Igw)*beta
    deallocate(Igt,Igw)
  end subroutine fft_tau2iw

  !+-------------------------------------------------------------------+
  !PURPOSE  :
  !+-------------------------------------------------------------------+
  function fft_gbeta_minus(Giw,beta,notail) result(g0)
    complex(8),dimension(:)        :: Giw
    real(8)                        :: beta
    logical,optional               :: notail
    logical                        :: notail_
    real(8),dimension(0:size(Giw)) :: Gtau
    real(8)                        :: g0
    notail_=.false.;if(present(notail))notail_=notail
    call fft_iw2tau(Giw,Gtau(0:),beta,notail_)
    g0 = -Gtau(size(Giw))
  end function fft_gbeta_minus

  ! !+----------------------------------------------------------------+
  ! !PURPOSE  :
  ! !+----------------------------------------------------------------+
  ! function ret_component_t(fgkgtr,fgkless,t) result(fgkret)
  !   integer                                       :: i,L
  !   complex(8),dimension(:),intent(in)            :: fgkgtr
  !   complex(8),dimension(size(fgkgtr)),intent(in) :: fgkless
  !   complex(8),dimension(size(fgkgtr))            :: fgkret
  !   real(8),dimension(size(fgkgtr)),intent(in)   :: t
  !   L=size(fgkgtr)
  !   forall(i=1:L)fgkret(i)=step(t(i))*(fgkgtr(i)-fgkless(i))
  ! contains
  !   pure function step(x)
  !     real(8),intent(in) :: x
  !     real(8)            :: step
  !     if(x < 0.d0) then
  !        step = 0.0d0
  !     elseif(x==0.d0)then
  !        step = 0.50d0
  !     else
  !        step = 1.0d0
  !     endif
  !   end function step
  ! end function ret_component_t

  ! !+----------------------------------------------------------------+
  ! !PURPOSE  :
  ! !+----------------------------------------------------------------+
  ! function less_component_w(fret,wr,beta) result(fless)
  !   integer                            :: i,L
  !   complex(8),dimension(:),intent(in) :: fret
  !   complex(8),dimension(size(fret))   :: fless
  !   real(8),dimension(size(fret))      :: wr
  !   real(8)                            :: A,beta,w
  !   L=size(fret)
  !   do i=1,L
  !      w       = wr(i)
  !      A       = -dimag(fret(i))/pi
  !      fless(i)= 2d0*pi*xi*fermi(w,beta)*A
  !   enddo
  ! contains
  !   function fermi(x,beta)
  !     real(8) :: fermi, x, beta
  !     if(x*beta > 50d0)then
  !        fermi=0.d0
  !        return
  !     endif
  !     fermi = 1.d0/(1.d0+exp(beta*x))
  !   end function fermi
  ! end function less_component_w

  ! !+----------------------------------------------------------------+
  ! !PURPOSE  :
  ! !+----------------------------------------------------------------+
  ! function gtr_component_w(fret,wr,beta) result(fgtr)
  !   integer                            :: i,L
  !   complex(8),dimension(:),intent(in) :: fret
  !   complex(8),dimension(size(fret))   :: fgtr
  !   real(8),dimension(size(fret))      :: wr
  !   real(8)                            :: A,beta,w
  !   L=size(fret)
  !   do i=1,L
  !      w      = wr(i)
  !      A      = -dimag(fret(i))/pi
  !      fgtr(i)= 2.d0*pi*xi*(fermi(w,beta)-1.d0)*A
  !   enddo
  ! contains
  !   function fermi(x,beta)
  !     real(8) :: fermi, x, beta
  !     if(x*beta > 50d0)then
  !        fermi=0.d0
  !        return
  !     endif
  !     fermi = 1.d0/(1.d0+exp(beta*x))
  !   end function fermi
  ! end function gtr_component_w

  subroutine interp(FctL1,FctL2,L1,L2)
    integer             :: L1, L2
    real(8)             :: FctL1(0:L1), FctL2(0:L2)
    real(8),allocatable :: xa(:), ya(:,:), y2(:)
    integer             :: L11, L12, L13
    real(8)             :: x
    integer             :: i
    L11 = L1 + 1
    L12 = L1 + 2
    L13 = L1 + 3
    allocate(xa(L11),ya(4,L11),y2(L11))
    do i=1, L11
       xa(i)=real(i-1,8)/real(L1,8)
       ya(1,i)=FctL1(i-1)
    enddo
    call CUBSPL(xa,ya,L11,0,0)
    do i=1, L2
       x=real(i,8)/real(L2,8)
       FctL2(i)=PPVALU(xa,ya,L1,4,x,0)
    enddo
    FctL2(0)=FctL1(0)
  end subroutine interp

  subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
    !**************************************************************************
    !
    !! CUBSPL defines an interpolatory cubic spline.
    !
    !  Discussion:
    !
    !    A tridiagonal linear system for the unknown slopes S(I) of
    !    F at TAU(I), I=1,..., N, is generated and then solved by Gauss
    !    elimination, with S(I) ending up in C(2,I), for all I.
    !
    !  Modified:
    !
    !    14 February 2007
    !
    !  Author:
    !
    !    Carl DeBoor
    !
    !  Reference:
    !
    !    Carl DeBoor,
    !    A Practical Guide to Splines,
    !    Springer, 2001,
    !    ISBN: 0387953663,
    !    LC: QA1.A647.v27.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) TAU(N), the abscissas or X values of
    !    the data points.  The entries of TAU are assumed to be
    !    strictly increasing.
    !
    !    Input, integer ( kind = 4 ) N, the number of data points.  N is
    !    assumed to be at least 2.
    !
    !    Input/output, real ( kind = 8 ) C(4,N).
    !    On input, if IBCBEG or IBCBEG is 1 or 2, then C(2,1)
    !    or C(2,N) should have been set to the desired derivative
    !    values, as described further under IBCBEG and IBCEND.
    !    On output, C contains the polynomial coefficients of
    !    the cubic interpolating spline with interior knots
    !    TAU(2) through TAU(N-1).
    !    In the interval interval (TAU(I), TAU(I+1)), the spline
    !    F is given by
    !      F(X) =
    !        C(1,I) +
    !        C(2,I) * H +
    !        C(3,I) * H**2 / 2 +
    !        C(4,I) * H**3 / 6.
    !    where H=X-TAU(I).  The routine PPVALU may be used to
    !    evaluate F or its derivatives from TAU, C, L=N-1,
    !    and K=4.
    !
    !    Input, integer ( kind = 4 ) IBCBEG, IBCEND, boundary condition indicators
    !    IBCBEG = 0 means no boundary condition at TAU(1) is given.
    !    In this case, the "not-a-knot condition" is used.  That
    !    is, the jump in the third derivative across TAU(2) is
    !    forced to zero.  Thus the first and the second cubic
    !    polynomial pieces are made to coincide.
    !    IBCBEG = 1 means the slope at TAU(1) is to equal the
    !    input value C(2,1).
    !    IBCBEG = 2 means the second derivative at TAU(1) is
    !    to equal C(2,1).
    !    IBCEND = 0, 1, or 2 has analogous meaning concerning the
    !    boundary condition at TAU(N), with the additional
    !    information taken from C(2,N).
    !
    implicit none
    integer ( kind = 4 ) n
    real ( kind = 8 ) c(4,n)
    real ( kind = 8 ) divdf1
    real ( kind = 8 ) divdf3
    real ( kind = 8 ) dtau
    real ( kind = 8 ) g
    integer ( kind = 4 ) i
    integer ( kind = 4 ) ibcbeg
    integer ( kind = 4 ) ibcend
    real ( kind = 8 ) tau(n)
    !
    !  C(3,*) and C(4,*) are used initially for temporary storage.
    !
    !  Store first differences of the TAU sequence in C(3,*).
    !
    !  Store first divided difference of data in C(4,*).
    !
    do i = 2, n
       c(3,i) = tau(i) - tau(i-1)
    end do

    do i = 2, n
       c(4,i) = ( c(1,i) - c(1,i-1) ) / ( tau(i) - tau(i-1) )
    end do
    !
    !  Construct the first equation from the boundary condition
    !  at the left endpoint, of the form:
    !
    !    C(4,1) * S(1) + C(3,1) * S(2) = C(2,1)
    !
    !  IBCBEG = 0: Not-a-knot
    !
    if ( ibcbeg == 0 ) then

       if ( n <= 2 ) then
          c(4,1) = 1.0D+00
          c(3,1) = 1.0D+00
          c(2,1) = 2.0D+00 * c(4,2)
          go to 120
       end if

       c(4,1) = c(3,3)
       c(3,1) = c(3,2) + c(3,3)
       c(2,1) = ( ( c(3,2) + 2.0D+00 * c(3,1) ) * c(4,2) * c(3,3) &
            + c(3,2)**2 * c(4,3) ) / c(3,1)
       !
       !  IBCBEG = 1: derivative specified.
       !
    else if ( ibcbeg == 1 ) then

       c(4,1) = 1.0D+00
       c(3,1) = 0.0D+00

       if ( n == 2 ) then
          go to 120
       end if
       !
       !  Second derivative prescribed at left end.
       !
    else

       c(4,1) = 2.0D+00
       c(3,1) = 1.0D+00
       c(2,1) = 3.0D+00 * c(4,2) - c(3,2) / 2.0D+00 * c(2,1)

       if ( n == 2 ) then
          go to 120
       end if

    end if
    !
    !  If there are interior knots, generate the corresponding
    !  equations and carry out the forward pass of Gauss elimination,
    !  after which the I-th equation reads:
    !
    !    C(4,I) * S(I) + C(3,I) * S(I+1) = C(2,I).
    !
    do i = 2, n-1
       g = -c(3,i+1) / c(4,i-1)
       c(2,i) = g * c(2,i-1) + 3.0D+00 * ( c(3,i) * c(4,i+1) + c(3,i+1) * c(4,i) )
       c(4,i) = g * c(3,i-1) + 2.0D+00 * ( c(3,i) + c(3,i+1))
    end do
    !
    !  Construct the last equation from the second boundary condition, of
    !  the form
    !
    !    -G * C(4,N-1) * S(N-1) + C(4,N) * S(N) = C(2,N)
    !
    !  If slope is prescribed at right end, one can go directly to
    !  back-substitution, since the C array happens to be set up just
    !  right for it at this point.
    !
    if ( ibcend == 1 ) then
       go to 160
    end if

    if ( 1 < ibcend ) then
       go to 110
    end if

    !90 continue
    !
    !  Not-a-knot and 3 <= N, and either 3 < N or also not-a-knot
    !  at left end point.
    !
    if ( n /= 3 .or. ibcbeg /= 0 ) then
       g = c(3,n-1) + c(3,n)
       c(2,n) = ( ( c(3,n) + 2.0D+00 * g ) * c(4,n) * c(3,n-1) + c(3,n)**2 &
            * ( c(1,n-1) - c(1,n-2) ) / c(3,n-1) ) / g
       g = - g / c(4,n-1)
       c(4,n) = c(3,n-1)
       c(4,n) = c(4,n) + g * c(3,n-1)
       c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
       go to 160
    end if
    !
    !  N = 3 and not-a-knot also at left.
    !
    !100 continue

    c(2,n) = 2.0D+00 * c(4,n)
    c(4,n) = 1.0D+00
    g = -1.0D+00 / c(4,n-1)
    c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
    c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
    go to 160
    !
    !  IBCEND = 2: Second derivative prescribed at right endpoint.
    !
110 continue

    c(2,n) = 3.0D+00 * c(4,n) + c(3,n) / 2.0D+00 * c(2,n)
    c(4,n) = 2.0D+00
    g = -1.0D+00 / c(4,n-1)
    c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
    c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
    go to 160
    !
    !  N = 2.
    !
120 continue

    if ( ibcend == 2  ) then

       c(2,n) = 3.0D+00 * c(4,n) + c(3,n) / 2.0D+00 * c(2,n)
       c(4,n) = 2.0D+00
       g = -1.0D+00 / c(4,n-1)
       c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
       c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)

    else if ( ibcend == 0 .and. ibcbeg /= 0 ) then

       c(2,n) = 2.0D+00 * c(4,n)
       c(4,n) = 1.0D+00
       g = -1.0D+00 / c(4,n-1)
       c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
       c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)

    else if ( ibcend == 0 .and. ibcbeg == 0 ) then

       c(2,n) = c(4,n)

    end if
    !
    !  Back solve the upper triangular system
    !
    !    C(4,I) * S(I) + C(3,I) * S(I+1) = B(I)
    !
    !  for the slopes C(2,I), given that S(N) is already known.
    !
160 continue

    do i = n-1, 1, -1
       c(2,i) = ( c(2,i) - c(3,i) * c(2,i+1) ) / c(4,i)
    end do
    !
    !  Generate cubic coefficients in each interval, that is, the
    !  derivatives at its left endpoint, from value and slope at its
    !  endpoints.
    !
    do i = 2, n
       dtau = c(3,i)
       divdf1 = ( c(1,i) - c(1,i-1) ) / dtau
       divdf3 = c(2,i-1) + c(2,i) - 2.0D+00 * divdf1
       c(3,i-1) = 2.0D+00 * ( divdf1 - c(2,i-1) - divdf3 ) / dtau
       c(4,i-1) = 6.0D+00 * divdf3 / dtau**2
    end do
    return
  end subroutine cubspl
  !-----------------------
  !-----------------------
  !-----------------------
  function ppvalu ( break, coef, l, k, x, jderiv )
    !**************************************************************************80
    !
    !! PPVALU evaluates a piecewise polynomial function or its derivative.
    !
    !  Discussion:
    !
    !    PPVALU calculates the value at X of the JDERIV-th derivative of
    !    the piecewise polynomial function F from its piecewise
    !    polynomial representation.
    !
    !    The interval index I, appropriate for X, is found through a
    !    call to INTERV.  The formula for the JDERIV-th derivative
    !    of F is then evaluated by nested multiplication.
    !
    !    The J-th derivative of F is given by:
    !
    !      (d**J) F(X) =
    !        COEF(J+1,I) + H * (
    !        COEF(J+2,I) + H * (
    !        ...
    !        COEF(K-1,I) + H * (
    !        COEF(K,  I) / (K-J-1) ) / (K-J-2) ... ) / 2 ) / 1
    !
    !    with
    !
    !      H = X - BREAK(I)
    !
    !    and
    !
    !      I = max ( 1, max ( J, BREAK(J) <= X, 1 <= J <= L ) ).
    !
    !  Modified:
    !
    !    16 February 2007
    !
    !  Author:
    !
    !    Carl DeBoor
    !
    !  Reference:
    !
    !    Carl DeBoor,
    !    A Practical Guide to Splines,
    !    Springer, 2001,
    !    ISBN: 0387953663,
    !    LC: QA1.A647.v27.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) BREAK(L+1), real COEF(*), integer L, the
    !    piecewise polynomial representation of the function F to be evaluated.
    !
    !    Input, integer ( kind = 4 ) K, the order of the polynomial pieces that
    !    make up the function F.
    !    The usual value for K is 4, signifying a piecewise
    !    cubic polynomial.
    !
    !    Input, real ( kind = 8 ) X, the point at which to evaluate F or
    !    of its derivatives.
    !
    !    Input, integer ( kind = 4 ) JDERIV, the order of the derivative to be
    !    evaluated.  If JDERIV is 0, then F itself is evaluated,
    !    which is actually the most common case.  It is assumed
    !    that JDERIV is zero or positive.
    !
    !    Output, real ( kind = 8 ) PPVALU, the value of the JDERIV-th
    !    derivative of F at X.
    !
    implicit none

    integer ( kind = 4 ) k
    integer ( kind = 4 ) l

    real ( kind = 8 ) break(l+1)
    real ( kind = 8 ) coef(k,l)
    real ( kind = 8 ) fmmjdr
    real ( kind = 8 ) h
    integer ( kind = 4 ) i
    integer ( kind = 4 ) jderiv
    integer ( kind = 4 ) m
    integer ( kind = 4 ) ndummy
    real ( kind = 8 ) ppvalu
    real ( kind = 8 ) value
    real ( kind = 8 ) x

    value = 0.0D+00

    fmmjdr = real(k - jderiv,8)
    !
    !  Derivatives of order K or higher are identically zero.
    !
    if ( k <= jderiv ) then
       return
    end if
    !
    !  Find the index I of the largest breakpoint to the left of X.
    !
    call interv ( break, l+1, x, i, ndummy )
    !
    !  Evaluate the JDERIV-th derivative of the I-th polynomial piece at X.
    !
    h = x - break(i)
    m = k

    do
       value = ( value / fmmjdr ) * h + coef(m,i)
       m = m - 1
       fmmjdr = fmmjdr - 1.0D+00

       if ( fmmjdr <= 0.0D+00 ) then
          exit
       end if
    end do

    ppvalu = value
    return
  end function ppvalu
  !-----------------------
  !-----------------------
  !-----------------------
  subroutine interv ( xt, lxt, x, left, mflag )
    !**************************************************************************80
    !
    !! INTERV brackets a real value in an ascending vector of values.
    !
    !  Discussion:
    !
    !    The XT array is a set of increasing values.  The goal of the routine
    !    is to determine the largest index I so that XT(I) <= X.
    !
    !    The routine is designed to be efficient in the common situation
    !    that it is called repeatedly, with X taken from an increasing
    !    or decreasing sequence.
    !
    !    This will happen when a piecewise polynomial is to be graphed.
    !    The first guess for LEFT is therefore taken to be the value
    !    returned at the previous call and stored in the local variable ILO.
    !
    !    A first check ascertains that ILO < LXT.  This is necessary
    !    since the present call may have nothing to do with the previous
    !    call.  Then, if
    !
    !      XT(ILO) <= X < XT(ILO+1),
    !
    !    we set LEFT = ILO and are done after just three comparisons.
    !
    !    Otherwise, we repeatedly double the difference ISTEP = IHI - ILO
    !    while also moving ILO and IHI in the direction of X, until
    !
    !      XT(ILO) <= X < XT(IHI)
    !
    !    after which we use bisection to get, in addition, ILO + 1 = IHI.
    !    The value LEFT = ILO is then returned.
    !
    !  Modified:
    !
    !    14 February 2007
    !
    !  Author:
    !
    !    Carl DeBoor
    !
    !  Reference:
    !
    !    Carl DeBoor,
    !    A Practical Guide to Splines,
    !    Springer, 2001,
    !    ISBN: 0387953663,
    !    LC: QA1.A647.v27.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) XT(LXT), a nondecreasing sequence of values.
    !
    !    Input, integer ( kind = 4 ) LXT, the dimension of XT.
    !
    !    Input, real ( kind = 8 ) X, the point whose location with
    !    respect to the sequence XT is to be determined.
    !
    !    Output, integer ( kind = 4 ) LEFT, the index of the bracketing value:
    !      1     if             X  <  XT(1)
    !      I     if   XT(I)  <= X  < XT(I+1)
    !      LXT   if  XT(LXT) <= X
    !
    !    Output, integer ( kind = 4 ) MFLAG, indicates whether X lies within the
    !    range of the data.
    !    -1:            X  <  XT(1)
    !     0: XT(I)   <= X  < XT(I+1)
    !    +1: XT(LXT) <= X
    !
    implicit none
    integer ( kind = 4 ) lxt

    integer ( kind = 4 ) left
    integer ( kind = 4 ) mflag
    integer ( kind = 4 ) ihi
    integer ( kind = 4 ), save :: ilo = 1
    integer ( kind = 4 ) istep
    integer ( kind = 4 ) middle
    real ( kind = 8 ) x
    real ( kind = 8 ) xt(lxt)

    ihi = ilo + 1

    if ( lxt <= ihi ) then
       if ( xt(lxt) <= x ) then
          go to 110
       end if
       if ( lxt <= 1 ) then
          mflag = -1
          left = 1
          return
       end if
       ilo = lxt - 1
       ihi = lxt
    end if

    if ( xt(ihi) <= x ) then
       go to 20
    end if

    if ( xt(ilo) <= x ) then
       mflag = 0
       left = ilo
       return
    end if
    !
    !  Now X < XT(ILO).  Decrease ILO to capture X.
    !
    istep = 1

10  continue

    ihi = ilo
    ilo = ihi - istep

    if ( 1 < ilo ) then
       if ( xt(ilo) <= x ) then
          go to 50
       end if
       istep = istep * 2
       go to 10
    end if

    ilo = 1

    if ( x < xt(1) ) then
       mflag = -1
       left = 1
       return
    end if

    go to 50
    !
    !  Now XT(IHI) <= X.  Increase IHI to capture X.
    !
20  continue
    istep = 1

30  continue

    ilo = ihi
    ihi = ilo + istep

    if ( ihi < lxt ) then
       if ( x < xt(ihi) ) then
          go to 50
       end if
       istep = istep * 2
       go to 30
    end if

    if ( xt(lxt) <= x ) then
       go to 110
    end if
    !
    !  Now XT(ILO) < = X < XT(IHI).  Narrow the interval.
    !
    ihi = lxt
50  continue

    do
       middle = ( ilo + ihi ) / 2
       if ( middle == ilo ) then
          mflag = 0
          left = ilo
          return
       end if
       !
       !  It is assumed that MIDDLE = ILO in case IHI = ILO+1.
       !
       if ( xt(middle) <= x ) then
          ilo = middle
       else
          ihi = middle
       end if
    end do
    !
    !  Set output and return.
    !
110 continue
    mflag = 1
    if ( x == xt(lxt) ) then
       mflag = 0
    end if
    do left = lxt, 1, -1
       if ( xt(left) < xt(lxt) ) then
          return
       end if
    end do
    return
  end subroutine interv

end module NEQ_FFT_GF


!
!     -------------------------------------------------------------
!      S I X J
!     -------------------------------------------------------------
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | I/2  J/2  K/2 |                                            *
!     | L/2  M/2  N/2 |          (29.1A) [J.B.77]                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
!
      SUBROUTINE SIXJ(I, J, K, L, M, N, ITIK, SI)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:06:26  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      USE sixj5_I
      USE sixj1_I
      USE sixj35_I
      USE sixj2_I
      USE gracah1_I
      USE sixj3_I
      USE sixj4_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: K
      INTEGER  :: L
      INTEGER  :: M
      INTEGER  :: N
      INTEGER , INTENT(IN) :: ITIK
      REAL(DOUBLE)  :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IFA
      REAL(DOUBLE), DIMENSION(0:4,0:4,0:4,0:4,0:4,0:4) :: RACA
      REAL(DOUBLE) :: UNDEF, A
      LOGICAL :: SAVE
!-----------------------------------------------
      DATA RACA/ 15625*1.D-20/
      DATA UNDEF/ 1.D-20/
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(I,J,K,L,M,N) == 0) RETURN
      ENDIF
      SAVE = .FALSE.
      IF (MAX0(I,J,K,L,M,N) <= 4) THEN
         SI = RACA(I,J,K,L,M,N)
         IF (SI == UNDEF) THEN
            SAVE = .TRUE.
         ELSE
            RETURN
         ENDIF
      ENDIF
!
!     CALCULATED IN CASE WHEN ONE OF PERAMETERS EQUAL 0
!
      IF (I*J*K*L*M*N == 0) THEN
         IF (I == 0) THEN
            A = DBLE((M + 1)*(K + 1))
            IFA = L + M + K
         ELSE IF (J == 0) THEN
            A = DBLE((L + 1)*(K + 1))
            IFA = I + M + N
         ELSE IF (K == 0) THEN
            A = DBLE((I + 1)*(L + 1))
            IFA = I + M + N
         ELSE IF (L == 0) THEN
            A = DBLE((J + 1)*(K + 1))
            IFA = I + J + K
         ELSE IF (M == 0) THEN
            A = DBLE((I + 1)*(K + 1))
            IFA = I + J + K
         ELSE
            A = DBLE((I + 1)*(J + 1))
            IFA = I + J + K
         ENDIF
         SI = ONE/DSQRT(A)
         IF (MOD(IFA,4) /= 0) SI = -SI
!
!     THE CASE 1/2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 1) THEN
         IF (I == 1) THEN
            CALL SIXJ5 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 1) THEN
            CALL SIXJ5 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 1) THEN
            CALL SIXJ5 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 1) THEN
            CALL SIXJ5 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 1) THEN
            CALL SIXJ5 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ5 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 1
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 2) THEN
         IF (I == 2) THEN
            CALL SIXJ1 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 2) THEN
            CALL SIXJ1 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 2) THEN
            CALL SIXJ1 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 2) THEN
            CALL SIXJ1 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 2) THEN
            CALL SIXJ1 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ1 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 3/2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 3) THEN
         IF (I == 3) THEN
            CALL SIXJ35 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 3) THEN
            CALL SIXJ35 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 3) THEN
            CALL SIXJ35 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 3) THEN
            CALL SIXJ35 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 3) THEN
            CALL SIXJ35 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ35 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 4) THEN
         IF (I == 4) THEN
            CALL SIXJ2 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 4) THEN
            CALL SIXJ2 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 4) THEN
            CALL SIXJ2 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 4) THEN
            CALL SIXJ2 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 4) THEN
            CALL SIXJ2 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ2 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 5/2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 5) THEN
         CALL GRACAH1 (I, J, M, L, K, N, SI)
         IF (MOD(I + J + M + L,4) /= 0) SI = -SI
!
!     CASES 3
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 6) THEN
         IF (I == 6) THEN
            CALL SIXJ3 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 6) THEN
            CALL SIXJ3 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 6) THEN
            CALL SIXJ3 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 6) THEN
            CALL SIXJ3 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 6) THEN
            CALL SIXJ3 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ3 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 7/2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 7) THEN
         CALL GRACAH1 (I, J, M, L, K, N, SI)
         IF (MOD(I + J + M + L,4) /= 0) SI = -SI
!
!     CASES 4
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 8) THEN
         IF (I == 8) THEN
            CALL SIXJ4 (M, K, L, J, N, 0, SI)
         ELSE IF (J == 8) THEN
            CALL SIXJ4 (I, N, M, L, K, 0, SI)
         ELSE IF (K == 8) THEN
            CALL SIXJ4 (I, M, N, L, J, 0, SI)
         ELSE IF (L == 8) THEN
            CALL SIXJ4 (J, K, I, M, N, 0, SI)
         ELSE IF (M == 8) THEN
            CALL SIXJ4 (I, K, J, L, N, 0, SI)
         ELSE
            CALL SIXJ4 (I, J, K, L, M, 0, SI)
         ENDIF
!
!     THE CASE 9/2
!
      ELSE IF (MIN0(I,J,K,L,M,N) == 9) THEN
         CALL GRACAH1 (I, J, M, L, K, N, SI)
         IF (MOD(I + J + M + L,4) /= 0) SI = -SI
!
!     CALCULATED OTHER CASES
!
      ELSE
!       CALL DRACAH(I,J,M,L,K,N,SI)
         CALL GRACAH1 (I, J, M, L, K, N, SI)
!        CALL GRACAH(I,J,M,L,K,N,SI)
         IF (MOD(I + J + M + L,4) /= 0) SI = -SI
      ENDIF
      IF (SAVE) RACA(I,J,K,L,M,N) = SI
      RETURN
      END SUBROUTINE SIXJ


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_spg2set
      use m_juDFT
!-------------------------------------------------------------------------+
! determine the rotation martrices (mrot) and non-symorphic translations  !
! for a given 2D symmetry (defined by a number n2spg) plus eventually     !
! inversion (invs) or z-reflection (zrfs) symmetry.                       !
! Plane groups 1-17 are according to Int. Tables of Crystallography       !
! 18-20 : pm, pg and cm with mirror plane y -> -y  (as used in old spgset)!
! 21-25 : p3, p3m1, p31m, p6 and p6mm  with sharp angle (lattice type hex)!
!                                                                   gb`02 !
!-------------------------------------------------------------------------+
      CONTAINS
      SUBROUTINE spg2set(
     >                   nop,zrfs,invs,namgrp,latnam,
     <                   mrot,tau,nop2,symor)

      USE m_constants
      USE m_symdata, ONLY : gen2,tau2,spg2,gnt2,namgr2,nammap,ord2
      USE m_matmul,ONLY   : matmul4
      IMPLICIT NONE

      INTEGER, INTENT (IN) :: nop
      LOGICAL, INTENT (IN) :: invs,zrfs
      CHARACTER(len=4),INTENT (IN) :: namgrp
      CHARACTER(len=3),INTENT (IN) :: latnam

      INTEGER, INTENT (OUT) :: nop2
      INTEGER, INTENT (OUT) :: mrot(3,3,nop)
      REAL,    INTENT (OUT) :: tau(3,nop)
      LOGICAL, INTENT (OUT) :: symor

      INTEGER n2spg, ngen, igen, n1, n2, n, i, j, d, t
      INTEGER mt(3,3), multab(nop)
      LOGICAL l_new
      CHARACTER(len=3) type

!mod: INTEGER spg2(3,25)             ! generators for 2d space groups
!mod: INTEGER gnt2(3,25)             ! translations for 2d space groups
!mod: INTEGER gen2(2,2,9)            ! rotation matrices for the generators
!mod: REAL    tau2(2,3)              ! translations for the generators
!mod: CHARACTER(len=4) :: namgr2(25) ! names of 2d space groups
!
! Determine number of 2d space group
!
      n2spg=0
      DO i = 1, 20
        IF (namgrp.EQ.nammap(i)) n2spg = i
      ENDDO
      IF ((latnam.EQ.'hex').AND.(n2spg.GT.12).
     +                      AND.(n2spg.LT.18)) THEN
        n2spg = n2spg + 8
      ENDIF
      IF (n2spg == 0)  THEN
        print *,latnam,namgrp
        CALL juDFT_error("2D-symmetry group not found!"
     +     ,calledby ="spg2set")
      ENDIF
!
! Determine number of generators ngen
!
      ngen = 1
      DO igen = 1, 3
        IF (spg2(igen,n2spg).NE.0) ngen = ngen + 1
      ENDDO
      nop2 = ord2(n2spg)
!
! make 3d rotation matrices for the generators
!
      symor = .true.
      mrot(:,:,1) = reshape((/1,0,0,0,1,0,0,0,1/),(/3,3/))  ! Identity is the first generator
      tau(:,1) = 0.0
      DO igen = 2, ngen
        mrot(:,:,igen) = reshape((/0,0,0,0,0,0,0,0,1/),(/3,3/))
        mrot(1:2,1:2,igen) = gen2(1:2,1:2,spg2(igen-1,n2spg))
        tau(:,igen) =  0.0
        IF (gnt2(igen-1,n2spg).NE.0) THEN
          symor = .false.
          tau(1:2,igen) = tau2(1:2,gnt2(igen-1,n2spg))
        ENDIF
      ENDDO
!
! now close the group
!
      mrot(:,:,ngen+1:nop) = 0 ; tau(:,ngen+1:nop) = 0.0
  10  CONTINUE
      rm1 : DO n1 = 1,ngen
         rm2 : DO  n2 = 1,ngen

            !CALL matmul1(mrot(1,1,n1),mrot(1,1,n2),mt)
            mt=matmul(mrot(:,:,n1),mrot(:,:,n2))
            rm3 : DO n = 1,nop
               DO i = 1,3
                  DO j = 1,3
                     IF (mt(i,j).NE.mrot(i,j,n)) CYCLE rm3
                  ENDDO
               ENDDO
               CYCLE rm2
            ENDDO rm3

! -->       new element found
            ngen = ngen + 1
            IF (ngen.gt.nop) THEN
             WRITE(oUnit,'(a7,i4,a7,i4)') 'ngen = ',ngen,' nop = ',nop
                CALL juDFT_error("ngen > nop",calledby="spg2set")
            ENDIF

            CALL matmul4(mrot(1,1,n1),tau(1,n1),
     >                   mrot(1,1,n2),tau(1,n2),
     <                   mrot(1,1,ngen),tau(1,ngen))
            GOTO 10

         ENDDO rm2
      ENDDO rm1
!
! add inversion or z-reflection symmetry
!
      IF ( (nop2.EQ.ngen).AND.(zrfs.OR.invs) ) THEN
        l_new = .true.
        IF (invs) THEN
          ngen = ngen + 1
          mrot(:,:,ngen) = - mrot(:,:,1)                     ! I
          tau(:,ngen) =  0.0
          IF (spg2(1,n2spg).EQ.2) l_new = .false.            ! if c_2 & I are generators
        ENDIF                                                ! m_z is no new generator
        IF (zrfs.AND.l_new) THEN
          ngen = ngen + 1
          mrot(:,:,ngen) =  reshape((/1,0,0,0,1,0,0,0,-1/),(/3,3/))  !m_z
          tau(:,ngen) =  0.0
        ENDIF
        GOTO 10                                              ! now close the 3D group
      ENDIF
!
! Output the symmetry elements
!
      IF (nop.NE.ngen) THEN
          WRITE (oUnit,*) 'nop =',nop,' =/= ngen = ',ngen
           CALL juDFT_error("nop =/= ngen",calledby="spg2set")
      ENDIF
      WRITE (oUnit,FMT=8010) namgr2(n2spg),invs,zrfs,nop,symor
 8010 FORMAT (/,/,' space group: ',a4,' invs=',l1,' zrfs=',l1,/,
     +  ' number of operations=',i3,/,' symmorphic=',l1,/,/)
      WRITE (oUnit,'("Number of 2D operations=",i3)') nop2
      DO n = 1,nop
!
! Determine the kind of symmetry operation we have here
!
         d = mrot(1,1,n)*mrot(2,2,n)*mrot(3,3,n) +
     +       mrot(1,2,n)*mrot(2,3,n)*mrot(3,1,n) +
     +       mrot(2,1,n)*mrot(3,2,n)*mrot(1,3,n) -
     +       mrot(1,3,n)*mrot(2,2,n)*mrot(3,1,n) -
     +       mrot(2,3,n)*mrot(3,2,n)*mrot(1,1,n) -
     +       mrot(2,1,n)*mrot(1,2,n)*mrot(3,3,n)
         t =  mrot(1,1,n) + mrot(2,2,n) + mrot(3,3,n)

         IF (d.EQ.-1) THEN
           type = 'm  '
           IF (t.EQ.-3) type = 'I  '
         ELSEIF (d.EQ.1) THEN
           IF (t.EQ.-1) type = 'c_2'
           IF (t.EQ. 0) type = 'c_3'
           IF (t.EQ. 1) type = 'c_4'
           IF (t.EQ. 2) type = 'c_6'
           IF (t.EQ. 3) type = 'E  '
         ELSE
            CALL juDFT_error("determinant=/=+/- 1",calledby ="spg2set")
         ENDIF

         WRITE (oUnit,FMT=8020) n, type
 8020    FORMAT (/,1x,i3,' : ',a3)
         DO i = 1,3
            WRITE (oUnit,FMT=8030) (mrot(i,j,n),j=1,3),tau(i,n)
         ENDDO
 8030    FORMAT (5x,3i3,3x,f4.1)
      ENDDO
c
c     check closure
c
      WRITE (oUnit,FMT=8040)
 8040 FORMAT (/,/,' multiplication table',/,/)

      op1 : DO n1 = 1,nop
         op2 : DO  n2 = 1,nop

            !CALL matmul1(mrot(1,1,n1),mrot(1,1,n2),mt)
            mt=matmul(mrot(:,:,n1),mrot(:,:,n2))
            op3 : DO n = 1,nop
               DO i = 1,3
                  DO j = 1,3
                     IF (mt(i,j).NE.mrot(i,j,n)) CYCLE op3
                  ENDDO
               ENDDO
               multab(n2) = n
               CYCLE op2
            ENDDO op3

            WRITE (oUnit,FMT=8050) n1,n2
 8050       FORMAT (' error - n1,n2=',2i3)
             CALL juDFT_error("mult",calledby="spg2set")
         ENDDO op2
         WRITE (oUnit,FMT=8060) (multab(n),n=1,nop)
 8060    FORMAT (1x,48i2)
      ENDDO op1

      END SUBROUTINE spg2set
      END MODULE m_spg2set


program test2
      implicit none
      real :: a(2)
      a(1)=1.0d0
      a(2)=4.0d0
      print *,sqrt(a)
end program test2


      PROGRAM Y1TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESY1
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following six
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest integer such that
C                          FLOAT(IBETA)**MAXEXP causes overflow
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest positive normalized
C                          floating-point power of the radix
C                 XMAX   - the largest finite floating-point
C                          number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, FLOAT, LOG, MAX, SIGN, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 13, 1992
C
C  Authors: George Zazi, W. J. Cody
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      LOGICAL SFLAG, TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MBM1,MBP1,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
      DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESY0,BESY1,BETA,C,CONV,DEL,EIGHT,
     2   EPS,EPSNEG,FOUR,HALF,HUND,ONE,REN,R6,R7,SIXTEN,SUM,T,
     3   TWENTY,TWO56,T1,U,W,X,XI,XL,XLAM,XMAX,XMB,XMIN,X1,Y,YX,
     4   Z,ZERO,ZZ
      DIMENSION U(560),XI(2),YX(2)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
      DATA IOUT/6/
CS    DATA ZERO,ONE,FOUR/0.0E0,1.0E0,4.0E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   HALF,SIXTEN,XLAM,HUND/0.5E0,16.0E0,0.9375E0,100.0E0/
      DATA ZERO,ONE,FOUR/0.0D0,1.0D0,4.0D0/,
     1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
     2   HALF,SIXTEN,XLAM,HUND/0.5D0,16.0D0,0.9375D0,100.0D0/
C--------------------------------------------------------------------
C  Zeroes of Y1
C--------------------------------------------------------------------
CS    DATA XI/562.0E0,1390.0E0/
CS    DATA YX(1)/-9.5282 39309 77227 03132 E-4/
CS   1     YX(2)/-2.1981 83008 05980 02741 E-6/
      DATA XI/562.0D0,1390.0D0/
      DATA YX(1)/-9.5282393097722703132D-4/,
     1     YX(2)/-2.1981830080598002741D-6/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = FLOAT(NDUM)
      CONV(NDUM) = DBLE(FLOAT(NDUM))
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      B = EPS
C--------------------------------------------------------------------
C  Random argument accuracy tests (based on the
C    multiplication theorem)
C--------------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = (J .EQ. 1) .AND. (MAXEXP/IT .LE. 5)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         A = B
         IF (J .EQ. 1) THEN
               B = FOUR
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
               N = 500
         END IF
         DEL = (B - A) / CONV(N)
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments and evaluate identities
C--------------------------------------------------------------------
            Y = X/XLAM
            W = SIXTEN * Y
            Y = (W + Y) - W
            X = Y * XLAM
            U(1) = BESY0(Y)
            U(2) = BESY1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
               U(1) = U(1) * EPS
               U(2) = U(2) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            W = (ONE-XLAM)*(ONE+XLAM)
            C = W * Y
            T = ABS(XLAM*U(2))
            T1 = EPS/HUND
            DO 110 II = 3, 60
               U(II) = XMB/Y * U(II-1) - U(II-2)
               T1 = XMB * T1 / C
               XMB = XMB + ONE
               MB = MB + 1
               MBP1=MB + 1
               Z = ABS(U(II))
               IF (Z/T1 .LT. T) THEN
                     GO TO 120
                  ELSE IF (Y .LT. XMB) THEN
                     IF (Z .GT. XMAX*(Y/XMB)) THEN
                        A= X
                        XL=XL+DEL
                        GO TO  200
                     END IF
               END IF
               IF (T1 .GT. ONE/EPS) THEN
                  T = T * T1
                  T1 = ONE
               END IF
  110       CONTINUE
  120       SUM = U(MBP1)
            IND = MBP1
            MBM1 =MB-1
            DO 155 II = 1, MBM1
               IND = IND - 1
               XMB = XMB - ONE
               SUM = SUM * W * Y / XMB + U(IND)
  155       CONTINUE
            ZZ = SUM*XLAM
            IF (TFLAG) ZZ = ZZ / EPS
            Z = BESY1(X)
            Y = Z
            IF (ABS(U(2)) .GT. ABS(Y)) Y =  U(2)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Process and output statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/CONV(N))
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 2
         X = XI(I)/TWO56
         Y = BESY1(X)
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) THEN
               W = LOG(ABS(T))/ALBETA
            ELSE
               W = ALL9
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMIN
      IF (XMIN*XMAX .LT. ONE) THEN
            WRITE (IOUT,1034) X
         ELSE
            WRITE (IOUT,1035) X
      END IF
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      X = -ONE
      WRITE (IOUT,1034) X
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
C--------------------------------------------------------------------
 1000 FORMAT('1Test of Y1(X) VS Multiplication Theorem'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 '(',F5.1,',',F5.1,')'//)
 1011 FORMAT(' ABS(Y1(X)) was larger',I6,' times', /
     1     15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1  F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4E3,' = ',I4,' **',
     1  F7.2/4X,'occurred for X =',E13.6E3)
 1025 FORMAT(' The root mean square absolute error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros',//,10X,'X',15X,'BESY1(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10E3,E25.15E3,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'///)
 1034 FORMAT(' Y1 will be called with the argument ',E17.10E3/
     1     ' This may stop execution.'//)
 1035 FORMAT(' Y1 will be called with the argument ',E17.10E3/
     1     ' This should not stop execution.'//)
 1036 FORMAT(' Y1 returned the value',E25.17E3/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESY1 test program ----------
      END


program main
	implicit none
	integer :: grade
	write (*,"(A)") 'Please your initial grade:'
	read  (*,*) grade
	write (*,"(A, F0.2)") 'your final grade is ', (grade**0.5*10)
	stop
end program main