! ==========================================================
! satellites_linear.f95
!
! This program calculates the control and state of a
! fully actuated satellite using optimal control with
! quadratic cost
!	I(u) = 1/2 * integ( x*Qx + u*Ru ) dt
!
! It uses a linearised model of the form
!	x' = Ax + Bu
! Presented by Yang in [Yang, Y. Analytic LQR design for
! spacecraft control system based on quaternion model.
! Journal of Aerospace Engineering, 25(3):448-453, jul 2012]
!
! INPUT:
! - "input_file": This file is created by the user.
! It contains the simulation parameters as follows:
!  T_0: Initial time
!  T_1: Final time
!  j1 j2 j3: Moments of inertia
!  q1 q2 q3 q4 q5 q6: Elemets of diagonal matrix q
!  r1 r2 r3: Elements of diagonal matrix R
!  omega_0(1) omega_0(2), omega_0(3): Initial ang. vel.
!  omega_1(1) omega_1(2), omega_1(3): Final ang. vel.
!  eul_0(1) eul_0(2) eul_0(3): Initial Euler angles
!  eul_1(1) eul_1(2) eul_1(3): Final Euler angles
!  m: Number of intervals in the discretization
!
! OUTPUT:
! - "results_control": Control
! - "results_angveloc": Angular velocities
! - "results_eulerang": Euler angles
! - "results_quaternion": Quaternion
! - "results_time": Time vector
! - "results_misc": Miscelaneous results (Cost, CPU time...)
!
! The convention for quaternion and
! Euler angles is as follows:
! q = (epsilon,eta)
! eul = (phi,theta,rho) = (yaw,pitch,roll)
!
! This program depends on LAPACK library: It must be
! compiled with -llapack and -lblas.
! ==========================================================

! ======== INITIALIZATION ========
! Variables declared here are passed to all subroutines
module initialization
implicit none
real:: q1, q2, q3, q4, q5, q6
real:: r1, r2, r3
real:: j1, j2, j3
end module initialization

! ======== MAIN PROGRAM ========
program main
use initialization
implicit none
interface
	subroutine func(n,x,t,y)
	integer, intent(in):: n
	real, intent(in):: x(n), t
	real, intent(out):: y(n)
	end subroutine func
end interface

integer, allocatable:: ipiv(:)
real, allocatable:: state_0(:), state_1(:)
real, allocatable:: state_aux_0(:), aux_solution_0_T(:)
real, allocatable:: aux_solutions(:,:), costate_0(:)
real, allocatable:: lu_fact(:,:)
real, allocatable:: state(:,:), state_costate(:,:), time(:)
integer:: n, nm, m, i, j, k
integer:: info
real:: omega_0(3), omega_1(3), eul_0(3), eul_1(3)
real:: quat_0(4), quat_1(4), eulang(3)
real:: t_0, t_1, pi, cpu_clock_ini, cpu_clock_fin
real:: cost, h
n = 6 ! Dimension of the problem
nm = 3 ! Dimension of control
pi = 4.*atan(1.)

! Open input file
open (11,file='input_file',status='old')
! Load input parameters from file
read(11,*) T_0
read(11,*) T_1
read(11,*) j1, j2, j3
read(11,*) q1, q2, q3, q4, q5, q6
read(11,*) r1, r2, r3
read(11,*) omega_0(1), omega_0(2), omega_0(3)
read(11,*) omega_1(1), omega_1(2), omega_1(3)
read(11,*) eul_0(1), eul_0(2), eul_0(3)
read(11,*) eul_1(1), eul_1(2), eul_1(3)
read(11,*) m
close(11)

allocate (state_0(n), state_1(n))
allocate (lu_fact(n,n), ipiv(n))
allocate (state_aux_0(2*n), aux_solution_0_T(n))
allocate (aux_solutions(n,n), costate_0(n))
allocate (state(m+1,n), state_costate(m+1,2*n), time(m+1))

! Here the state is (w,epsilon).
! Eta is calculated afterwards imposing |q|=1
call eul2quat(eul_0,quat_0)
call eul2quat(eul_1,quat_1)
state_0 = (/omega_0,quat_0(1:3)/)
state_1 = (/omega_1,quat_1(1:3)/)

call CPU_TIME(cpu_clock_ini)

! Solve n+1 auxiliary problems
! Problem i=0
state_aux_0 = 0. ! Construct initial condition
do k = 1,n
	state_aux_0(k) = state_0(k)
end do

! Call the solver
call rk4(func,2*n,state_aux_0,t_0,t_1,m,state_costate,time)
do k = 1,n ! Save solution at final time
	aux_solution_0_T(k) = state_costate(m+1,k)
end do

! Problems i=1,...,N
aux_solutions = 0.
do i = 1,n
	! Construct init. condition (Canonical basis of Rn)
	state_aux_0 = 0.
	state_aux_0(n+i) = 1.
	! Call the solver
	call rk4(func,2*n,state_aux_0,t_0,t_1, &
	m,state_costate,time)
	do k = 1,n ! Save solution at final time
		aux_solutions(k,i) = state_costate(m+1,k)
	end do
end do

! Solve p_0 = A^-1 (x_T-x_0(T))
! costate_0 = inv(aux_solutions)*(state_1-aux_solution_0_T)
! LU factorization
lu_fact = aux_solutions
call sgetrf(n,n,lu_fact,n,ipiv,info)
costate_0 =  state_1-aux_solution_0_T
! Solve linear problem
call sgetrs('n',n,1,lu_fact,n,ipiv,costate_0,n,info)

! Final problem
do k = 1,n
	state_aux_0(k) = state_0(k)
	state_aux_0(k+n) = costate_0(k)
end do

call rk4(func,2*n,state_aux_0,t_0,t_1,m,state_costate,time)

call CPU_TIME(cpu_clock_fin)

cost = 0. ! Calculate cost
h = (t_1-t_0)/m
do i = 1,m+1
	cost = cost + h*(q1*state_costate(i,1)**2 &
	+ q2*state_costate(i,2)**2 &
	+ q3*state_costate(i,3)**2 &
	+ q4*state_costate(i,4)**2 &
	+ q5*state_costate(i,5)**2 &
	+ q6*state_costate(i,6)**2 &
	+ r1*(-state_costate(i,7)/(j1*r1))**2 &
	+ r2*(-state_costate(i,8)/(j2*r2))**2 &
	+ r3*(-state_costate(i,9)/(j3*r3))**2)
end do

! Save results
open(11,file='results_misc', &
status='replace',action='write')
write(11,*) 'LINEAR MODEL;'
write(11,*) 'Initial time T_0;', t_0
write(11,*) 'Final time T_1;', t_1
write(11,*) 'Moments of inertia;', j1, j2, j3
write(11,*) 'Q (diagonal matix);', q1, q2, q3, q4, q5, q6
write(11,*) 'R (diagonal matix);', r1, r2, r3
write(11,*) 'Initial angular velocity w_0;', omega_0
write(11,*) 'Initial angular velocity w_1;', omega_1
write(11,*) 'Initial orientation (yaw,pitch,roll);', eul_0
write(11,*) 'Final orientation (yaw,pitch,roll);', eul_1
write(11,*) '# Intervals discretization;', m
write(11,*) 'Cost I(u) = ', cost
write(11,*) 'CPU time (s);', cpu_clock_fin-cpu_clock_ini
close(11)

open(11,file='results_control_LQR', &
status='replace',action='write')
do i = 1,m+1
	write(11,*) -state_costate(i,7)/(j1*r1), &
		    -state_costate(i,8)/(j2*r2), &
		    -state_costate(i,9)/(j3*r3)
end do
close(11)

open(11,file='results_control', &
status='replace',action='write')
do i = 1,m
	write(11,*) &
	(state_costate(i+1,1) - &
	state_costate(i,1))*m/(T_1-T_0), &
	(state_costate(i+1,2) - &
	state_costate(i,2))*m/(T_1-T_0), &
	(state_costate(i+1,3) - &
	state_costate(i,3))*m/(T_1-T_0)
end do
close(11)

open(11,file='results_quaternion', &
status='replace',action='write')
do i = 1,m+1
	write(11,*) &
	state_costate(i,4:6), &
	(1-state_costate(i,4)**2 &
	-state_costate(i,5)**2 &
	-state_costate(i,6)**2)**.5
end do
close(11)

open(11,file='results_eulerang', &
status='replace',action='write')
do i = 1,m+1
	call quat2eul((/state_costate(i,4:6), &
	(1-state_costate(i,4)**2 &
	-state_costate(i,5)**2 &
	-state_costate(i,6)**2)**.5/) &
	,eulang)
	write (11,*) eulang
end do
close(11)

open(11,file='results_angveloc', &
status='replace',action='write')
do i = 1,m+1
	write (11,*) state_costate(i,1:3)
end do
close(11)

open(11, file='results_time', &
status='replace',action='write')
do i = 1, m+1
        write (11,*) T_0+(T_1-T_0)*(i-1)/m
end do
close (11)

deallocate (ipiv)
deallocate (state_0, state_1)
deallocate (state_aux_0, aux_solution_0_T)
deallocate (aux_solutions, costate_0)
deallocate (lu_fact)
deallocate (state, state_costate, time)

end program main

! ======== 4TH ORDER RUNGE-KUTTA METHOD ========
subroutine rk4(func,n,x0,t0,t1,m,x,time)
implicit none
integer, intent(in):: n, m
real, intent(in):: x0(n), t0, t1
real, intent(out):: x(m+1,n), time(m+1)
real:: h, a1(N), a2(N), a3(N), a4(N)
integer:: i, k
h = (t1-t0)/m

do i = 1,n
	x(1,i) = x0(i)
end do

do k = 1,m
	time(k) = t0 + (k-1)*h
	call func(n,x(k,:),time(k),a1)
	a1 = h*a1
	call func(n,x(k,:)+.5*a1,time(k)+h/2.,a2)
	a2 = h*a2
	call func(n,x(k,:)+.5*a2,time(k)+h/2.,a3)
	a3 = h*a3
	call func(n,x(k,:)+a3,time(k)+h,a4)
	a4 = h*a4
	do i = 1,n
		x(k+1,i) = x(k,i) &
		+ (a1(i) + 2*a2(i)  +2*a3(i) + a4(i))/6.
	end do
end do
time(m+1) = t1
end subroutine rk4

! ======== DYNAMICS ========
subroutine func(n,x,t,y)
use initialization
implicit none
integer, intent(in):: n
real, intent(in):: x(n), t
real, intent(out):: y(n)
y(1) =  -x(7)/(r1*j1**2)
y(2) =  -x(8)/(r2*j2**2)
y(3) =  -x(9)/(r3*j3**2)
y(4) =   x(1)*.5
y(5) =   x(2)*.5
y(6) =   x(3)*.5
y(7) =  -x(10)*.5 - q1*x(1)
y(8) =  -x(11)*.5 - q2*x(2)
y(9) =  -x(12)*.5 - q3*x(3)
y(10) = -q4*x(4)
y(11) = -q5*x(5)
y(12) = -q6*x(6)
end subroutine func

! ======== EULER ANGLES TO QUATERNION ========
subroutine eul2quat(eul,q)
real, intent(in):: eul(3)
real, intent(out):: q(4)
real:: cy, sy, cp, sp, cr, sr
cy = cos(eul(1)*.5);
sy = sin(eul(1)*.5);
cp = cos(eul(2)*.5);
sp = sin(eul(2)*.5);
cr = cos(eul(3)*.5);
sr = sin(eul(3)*.5);
q(1) = cy * cp * sr - sy * sp * cr
q(2) = sy * cp * sr + cy * sp * cr
q(3) = sy * cp * cr - cy * sp * sr
q(4) = cy * cp * cr + sy * sp * sr
end subroutine eul2quat

! ======== QUATERNION TO EULER ANGLES ========
subroutine quat2eul(q,eul)
real, intent(in):: q(4)
real, intent(out):: eul(3)
eul(1) = atan2(2.*(q(4)*q(3)+q(1)*q(2)), &
1.-2.*(q(2)**2.+q(3)**2.))
eul(2) = asin(2.*(q(4)*q(2)-q(3)*q(1)))
eul(3) = atan2(2.*(q(4)*q(1)+q(2)*q(3)), &
1.-2.*(q(1)**2.+q(2)**2.))
end subroutine quat2eul


SUBROUTINE IMF_WEIGHT(mini,wght,nmass)

  !weight each star by the initial mass function (IMF)
  !such that the total initial population consists of
  !one solar mass of stars.

  !This weighting scheme assumes that the luminosity, mass, etc.
  !does not vary within the mass bin.  The point is that we
  !want each element to represent the whole bin, from
  !mass+/-0.5dm, rather than just the values at point i.
  !Then every intergral over mass is just a sum.

  USE sps_vars; USE sps_utils, ONLY : imf, funcint
  IMPLICIT NONE

  REAL(SP), INTENT(inout), DIMENSION(nm) :: wght
  REAL(SP), INTENT(in), DIMENSION(nm)    :: mini
  INTEGER, INTENT(in) :: nmass
  INTEGER  :: i
  REAL(SP) :: m1,m2

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

  wght = 0.0

  DO i=1,nmass

     IF (mini(i).LT.imf_lower_limit.OR.&
          mini(i).GT.imf_upper_limit) CYCLE

     IF (i.EQ.1) THEN
        !note that this is not equal to imf_lower_limit
        !only for the Geneva models, which do not extend below 1.0 Msun
        m1 = imf_lower_bound
     ELSE
        m1 = mini(i) - 0.5*(mini(i)-mini(i-1))
     ENDIF
     IF (i.EQ.nmass) THEN
        m2 = mini(i)
     ELSE
        m2 = mini(i) + 0.5*(mini(i+1)-mini(i))
     ENDIF

     IF (m2.LT.m1) THEN
        WRITE(*,*) 'IMF_WEIGHT WARNING: non-monotonic mass!',m1,m2,m2-m1
        CYCLE
     ENDIF

     IF (m2.EQ.m1) CYCLE

     wght(i) = funcint(imf,m1,m2)

  ENDDO

  !normalize the weights as an integral from lower to upper limits
  imf_type = imf_type + 10
  wght = wght / funcint(imf,imf_lower_limit,imf_upper_limit)
  imf_type = imf_type - 10

  RETURN

END SUBROUTINE IMF_WEIGHT


      subroutine pvYcalc(q1,q2,q3,m1s,m2s,m3s,m4s)
      implicit none
      integer nu
      logical qlzero,qlnonzero
      double precision q1(4),q2(4),q3(4),q4(4),m1s,m2s,m3s,m4s,
     . Y(4,4),pvdot
      do nu=1,4
      q4(nu)=0d0
      enddo

      Y(1,1)=m1s
      Y(2,2)=m2s
      Y(3,3)=m3s
      Y(4,4)=m4s

      Y(1,2)=0.5d0*(m1s+m2s-pvdot(q4,q4)-pvdot(q1,q1)+2d0*pvdot(q1,q4))
      Y(1,3)=0.5d0*(m1s+m3s-pvdot(q4,q4)-pvdot(q2,q2)+2d0*pvdot(q2,q4))
      Y(1,4)=0.5d0*(m1s+m4s-pvdot(q4,q4)-pvdot(q3,q3)+2d0*pvdot(q3,q4))

      Y(2,3)=0.5d0*(m2s+m3s-pvdot(q1,q1)-pvdot(q2,q2)+2d0*pvdot(q1,q2))
      Y(2,4)=0.5d0*(m2s+m4s-pvdot(q1,q1)-pvdot(q3,q3)+2d0*pvdot(q1,q3))

      Y(3,4)=0.5d0*(m3s+m4s-pvdot(q2,q2)-pvdot(q3,q3)+2d0*pvdot(q2,q3))

c      write(6,*) 'row1',Y(1,1),Y(1,2),Y(1,3),Y(1,4)
c      write(6,*) 'row2',Y(1,2),Y(2,2),Y(2,3),Y(2,4)
c      write(6,*) 'row3',Y(1,3),Y(2,3),Y(3,3),Y(3,4)
c      write(6,*) 'row4',Y(1,4),Y(2,4),Y(3,4),Y(4,4)

      if (qlzero(Y(1,3))
     .  .and. qlnonzero(Y(1,2)) .and. qlnonzero(Y(3,4))) then
      write(6,*) 'swapping 1 and 2'
      call pvswap(q1,q2,m2s,m3s)

      elseif (qlzero(Y(2,4))
     . .and. qlnonzero(Y(1,4)) .and. qlnonzero(Y(2,3))) then
      call pvswap(q2,q3,m3s,m4s)
      write(6,*) 'swapping 2 and 3'

      elseif (qlzero(Y(2,4))
     . .and. qlnonzero(Y(1,2)) .and. qlnonzero(Y(3,4))) then
      call pvswap(q2,q3,m3s,m4s)
      call pvswap(q1,q2,m2s,m3s)
      write(6,*) '231 --> 123'
      endif

c      Y(1,2)=0.5d0*(m1s+m2s-pvdot(q4,q4)-pvdot(q1,q1)+2d0*pvdot(q1,q4))
c      Y(1,3)=0.5d0*(m1s+m3s-pvdot(q4,q4)-pvdot(q2,q2)+2d0*pvdot(q2,q4))
c      Y(1,4)=0.5d0*(m1s+m4s-pvdot(q4,q4)-pvdot(q3,q3)+2d0*pvdot(q3,q4))

c      Y(2,3)=0.5d0*(m2s+m3s-pvdot(q1,q1)-pvdot(q2,q2)+2d0*pvdot(q1,q2))
c      Y(2,4)=0.5d0*(m2s+m4s-pvdot(q1,q1)-pvdot(q3,q3)+2d0*pvdot(q1,q3))

c      Y(3,4)=0.5d0*(m3s+m4s-pvdot(q2,q2)-pvdot(q3,q3)+2d0*pvdot(q2,q3))

c      write(6,*) 'new1',Y(1,1),Y(1,2),Y(1,3),Y(1,4)
c      write(6,*) 'new2',Y(1,2),Y(2,2),Y(2,3),Y(2,4)
c      write(6,*) 'new3',Y(1,3),Y(2,3),Y(3,3),Y(3,4)
c      write(6,*) 'new4',Y(1,4),Y(2,4),Y(3,4),Y(4,4)

      return
      end


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Integer arithmetic operations (+, *, - , /), including
*   constant folding.

	program p
    	parameter (n=24)
	integer rslts(N), expect(N)
	data expect / -7, -398, 7, 1,
     +                6, 87, 2, -8,
     +                -8, 73, -4, -2,
     +                -7, 560, -3, 15,
     +                -7, 1, 0, -2,
     +                100000000, 10, 90, -1  /

	data i7, in1, i4, in4, i9 / 7, -1, 4, -4, 9 /

c  tests 1 - 4:  unary minus and plus operators:

 	rslts(1) = -i7
	rslts(2) = +(-398)
  	rslts(3) = -(-(+i7))
  	rslts(4) = -(-1)

c  tests 5 - 8:  plus operator:

   	rslts(5) = i7 + in1
    	rslts(6) = i7 + 80
    	rslts(7) = 3 + in1
     	rslts(8) = -3+(-5)

c  tests 9 - 12:  minus operator:

     	rslts(9) = in1 - i7
     	rslts(10) = 80 - i7
      	rslts(11) = in1 - 3
       	rslts(12) = -5-(-3)

c  tests 13 - 16:  multiply operator:

	rslts(13) = in1 * i7
	rslts(14) = 80 * i7
	rslts(15) = in1 * 3
	rslts(16) = -5 * (-3)

c  tests 17 - 24:  divide operator:

	rslts(17) = i7 / in1
        rslts(18) = i7 / i4
        rslts(19) = 1 / in4
	rslts(20) = (-8) / 3
	rslts(21) = 900000000 / i9
	rslts(22) = -51 / (-5)
        rslts(23) = 900000000 / 10000000
	rslts(24) = i7 / (-4)

c  check results:

	call check(rslts, expect, N)
	end


SUBROUTINE tfpoint(thetas,phis,tweights,ln)
  !************************************************!
  !     GENERATES POINTS ON A UNIT SPHERE          !
  !************************************************!
  IMPLICIT NONE
  !
  REAL*8, intent(out)  :: thetas(ln+1), phis(2*ln+1), tweights(ln+1)! spt(2,(ln+1)*(2*ln+1)),weight((ln+1)*(2*ln+1))
  INTEGER, intent(in)  :: ln
  !
  REAL*8 :: dsum
  REAL*8 :: fake_shift, phi, pi
  INTEGER :: i, j, lg
  !
  PI=4.D0*ATAN(1.D0)
  lg = ln+1
  !
  CALL GRULE(lg,thetas,tweights) ! Gauss points in the interval [1...0]
  !
  do i=1,(lg+1)/2                ! adding symmetrical points to [0,...-1]
     j = lg+1-i
     thetas(j)=-thetas(i)
     tweights(j)=tweights(i)
  enddo
  do i=1,lg
     thetas(i) = dacos(thetas(i))
  enddo
  !
  fake_shift=EXP(-4.D0)  ! small shift such that we do not start at phi=0
  DO i=0,2*lg-2       ! 2*l-1 points in phi direction
     PHI=PI*(2*dble(i)/dble(2*lg-1) + fake_shift)
     phis(i+1)=PHI
  ENDDO
  !
  dsum = sum(tweights)
  tweights(:) = tweights(:)*2./dsum
  !write(6,*)'Gauss-Legendre grid of ',lg,'x',2*lg-1
  return
end SUBROUTINE tfpoint

SUBROUTINE apoint(spt,weight,ln)
  !************************************************!
  !     GENERATES POINTS ON A UNIT SPHERE          !
  !************************************************!
  IMPLICIT NONE
  !
  REAL*8, intent(out)  :: spt(2,(ln+1)*(2*ln+1)),weight((ln+1)*(2*ln+1))
  INTEGER, intent(in)  :: ln
  !
  REAL*8 :: XX((ln+1)*(2*ln+1))
  REAL*8 :: dsum
  REAL*8 :: fake_shift, phi, pi
  REAL*8 :: weight0(ln+1)
  INTEGER :: i, j, index, lg
  !
  PI=4.D0*ATAN(1.D0)
  lg = ln+1
  !
  CALL GRULE(lg,XX,WEIGHT) ! Gauss points in the interval [0...1]
  !
  DO i=1,(lg+1)/2
     j = lg+1-i
     XX(j)=-XX(i)
     WEIGHT(j)=WEIGHT(i)
  ENDDO
  weight0(:) = WEIGHT(:lg)
  !
  fake_shift=EXP(-4.D0)  ! small shift such that we do not start at phi=0
  INDEX=0
  DO j=1,lg            ! over all theta points
     DO i=0,2*lg-2       ! 2*l-1 points in phi direction
        PHI=PI*(2*dble(i)/dble(2*lg-1) + fake_shift)
        !INDEX=lg*i+j
        INDEX=INDEX+1
        WEIGHT(INDEX)=weight0(j)
        SPT(1,INDEX)=dacos(XX(j))
        SPT(2,INDEX)=PHI
     ENDDO
  ENDDO
  !
  dsum = sum(weight)
  weight(:) = weight(:)*4.D0*PI/dsum
  write(6,*)'Gauss-Legendre grid of ',lg,'x',2*lg-1
  return
end SUBROUTINE apoint

SUBROUTINE gpoint(spt,weight,ln)
  !************************************************!
  !     GENERATES POINTS ON A UNIT SPHERE          !
  !************************************************!
  IMPLICIT NONE
  !
  REAL*8, intent(out)  :: spt(3,(ln+1)*(2*ln+1)),weight((ln+1)*(2*ln+1))
  INTEGER, intent(in)  :: ln
  !
  REAL*8 :: XX((ln+1)*(2*ln+1))
  REAL*8 :: dsum
  REAL*8 :: fake_shift, phi, pi, rxy, z
  INTEGER :: i, j, index, lg
  !
  PI=4.D0*ATAN(1.D0)
  lg = ln+1
  !
  CALL GRULE(lg,XX,WEIGHT) ! Gauss points in the interval [0...1]
  !
  DO i=1,(lg+1)/2
     j = lg+1-i
     XX(j)=-XX(i)
     WEIGHT(j)=WEIGHT(i)
  ENDDO
  !
  fake_shift=EXP(-4.D0)  ! small shift such that we do not start at phi=0
  DO j=1,lg            ! over all theta points
     Z=XX(j)             ! z   = cos(theta)
     RXY=sqrt(1.D0-Z*Z)  ! rxy = sin(theta)
     DO i=0,2*lg-2       ! 2*l-1 points in phi direction
        PHI=PI*(2*dble(i)/dble(2*lg-1) + fake_shift)
        INDEX=lg*i+j
        WEIGHT(INDEX)=WEIGHT(j)
        SPT(1,INDEX)=COS(PHI)*RXY
        SPT(2,INDEX)=SIN(PHI)*RXY
        SPT(3,INDEX)=Z
     ENDDO
  ENDDO
  !
  dsum = sum(weight)
  weight(:) = weight(:)*4.D0*PI/dsum
  write(6,*)'Gauss-Legendre grid of ',lg,'x',2*lg-1
  return
end SUBROUTINE gpoint

SUBROUTINE GRULE(N,X,W)
  IMPLICIT NONE
  !
  !     DETERMINES THE (N+1)/2 NONNEGATIVE POINTS X(I) AND
  !     THE CORRESPONDING WEIGHTS W(I) OF THE N-POINT
  !     GAUSS-LEGENDRE INTEGRATION RULE, NORMALIZED TO THE
  !     INTERVAL \-1,1\. THE X(I) APPEAR IN DESCENDING ORDER.
  !
  !     THIS ROUTINE IS FROM 'METHODS OF NUMERICAL INTEGRATION',
  !     P.J. DAVIS AND P. RABINOWITZ, PAGE 369.
  !
  INTEGER, intent(in) :: N
  REAL*8, intent(out) :: X(*), W(*)
  !
  REAL*8  :: D1, d2pn, d3pn, d4pn, den, dp, dpn, e1, fx, h, p, pi, pk, pkm1, pkp1, t, t1, u, v, x0
  INTEGER :: i, it, k, m
  !
  PI=4.D0*ATAN(1.D0)
  M=(N+1)/2
  E1=N*(N+1)
  DO I=1,M         ! 1
     T=(4*I-1)*PI/(4*N+2)
     X0=(1.D0-(1.D0-1.D0/N)/(8.D0*N*N))*COS(T)
     !--->    ITERATE ON THE VALUE  (M.W. JAN. 1982)
     DO IT=1,3     ! 2
        PKM1=1.D0
        PK=X0
        DO K=2,N   ! 3
           T1=X0*PK
           PKP1=T1-PKM1-(T1-PKM1)/K+T1
           PKM1=PK
           PK=PKP1
        ENDDO      ! 3
        DEN=1.D0-X0*X0
        D1=N*(PKM1-X0*PK)
        DPN=D1/DEN
        D2PN=(2.D0*X0*DPN-E1*PK)/DEN
        D3PN=(4.D0*X0*D2PN+(2.D0-E1)*DPN)/DEN
        D4PN=(6.D0*X0*D3PN+(6.D0-E1)*D2PN)/DEN
        U=PK/DPN
        V=D2PN/DPN
        H=-U*(1.D0+.5D0*U*(V+U*(V*V-U*D3PN/(3.D0*DPN))))
        P=PK+H*(DPN+.5D0*H*(D2PN+H/3.D0*(D3PN+.25D0*H*D4PN)))
        DP=DPN+H*(D2PN+.5D0*H*(D3PN+H*D4PN/3.D0))
        H=H-P/DP
        X0=X0+H
     ENDDO
     X(I)=X0
     FX=D1-H*E1*(PK+.5D0*H*(DPN+H/3.D0*(D2PN+.25D0*H*(D3PN+.2D0*H*D4PN))))
     W(I)=2.D0*(1.D0-X(I)*X(I))/(FX*FX)
  ENDDO
  IF(M+M.GT.N) X(M)=0.D0
  RETURN
END SUBROUTINE GRULE


c
c     file tcud3cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the MUDPACK solver cud3cr
c
c ... required MUDPACK files
c
c     cud3cr.f, cudcom.f
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cud3cr (see cud3cr.d)
c
c **********************************************************
c **********************************************************
c
c     a sample program/test driver for cud3cr is below. it can be
c     executed as an initial test.  The output from executing
c     the code in this file is listed after the problem description.
c
c     Problem Description:
c
c     test cud3cr by solving the complex nonseparable 3-d elliptic pde
c     with cross derivative terms:
c
c          cxx*pxx + cyy*pyy + czz*pzz + cx*px + cy*py + cz*pz + ce*pe +
c
c          cxy*pxy + cxz*pxz + cyz*pyz = r(x,y,z).
c
c     on the region 0 < x < 1, 0 < y < (pi+pi), 0 < z < 1.
c     let s = sin(y), c = cos(y).  the complex coefficients are
c     given by:
c
c          cxx = cmplx(1.0+0.5*s*z,1.0+0.5*c*z)
c
c          cyy = (1.,1.)+cmplx(x,z)
c
c          czz = cmplx(1.0+0.5*s*x,1.0+0.5*c*x)
c
c          cx = cy = cz = (0.0,0.0)
c
c          ce = -cmplx(z,x)
c
c          cxy = cmplx(sqrt(real(cxx)*real(cyy),sqrt(aimag(cxx)*aimag(cyy))
c
c          cxz = (0.0,0.0)
c
c          cyz = cmplx(sqrt(real(cyy)*real(czz),sqrt(aimag(cyy)*aimag(czz))
c
c     assume the solution is periodic in y and is specified at x=0 and z=0.
c     further assume mixed oblique derivative conditions of the form
c
c          px + cmplx(z,1-z)*py + cmplx(s,c)*pz - p(1,y,z) = g(y,z)
c
c     at x=1 and mixed normal derivative conditions of the form
c
c          pz + cmplx(x,s*s)*p(x,y,1)  = h(x,y)
c
c     at z=1.  for testing purposes, use the exact solution
c
c          p(x,y,z) = exp(x*z)*cmplx(c,s)
c
c     to set boundary conditions, the right hand side, and compute
c     exact error.  results from approximating this problem on a
c     25 by 65 by 25 x-y-z grid using cud3cr are given below.  point
c     relaxation and an error tolerance of .001 are used.
c
c ******************************************************
c     output (32 bit floating point arithmetic)
c *******************************************************
c
c      cud3cr test
c
c      input arguments
c      intl =  0
c      nxa =  1 nxb =  2
c      nyc =  0 nyd =  0
c      nze =  1 nzf =  2
c      ixp =  3 jyq =  2 kzr =  3
c      iex =  3 jey =  6 kez =  3
c      nx =  13 ny =  65 nz =  13
c      iguess =  0 maxcy =  2
c      method =  0 work space input =  173394
c      xa =  0.00 xb =  1.00
c      yc =  0.00 yd =  6.28
c      ze =  0.00 zf =  1.00
c      tolmax =  0.000E+00
c
c      multigrid options
c      mgopt(1)  =  0
c
c      new cud3cr arguments
c      icrs
c         1    0    1
c      tol = 0.0010
c      maxit =  10
c
c      initial call
c      intl =  0
c      iguess =  0
c      ierror =  0
c      minimum required work space length =   173394
c
c      approximation call
c      intl =  1
c      iguess =  0
c      ierror =   0
c      number of outer iterations executed =   9
c      relative difference profile:
c      0.6567  0.1462  0.0638  0.0203  0.0099  0.0051  0.0016  0.0011  0.0004
c      exact least squares error =  0.127E-02
c
c ************************************************************
c     end of output
c ************************************************************
c
      program tcd3cr
      implicit none
c
c     set grid sizes and predetermined minimal required equired work
c     with parameter statements
c
      integer iixp,jjyq,kkzr,iiex,jjey,kkez,nnx,nny,nnz,llengt,mmaxit
      parameter(iixp=3,jjyq=2,kkzr=3)
      parameter (iiex=3,jjey=6,kkez=3)
      parameter(nnx = iixp*2**(iiex-1)+1)
      parameter(nny = jjyq*2**(jjey-1)+1)
      parameter(nnz = kkzr*2**(kkez-1)+1)
      parameter(llengt=173394)
      parameter(mmaxit = 10)
      complex rhs(nnx,nny,nnz),phi(nnx,nny,nnz),work(llengt)
      integer iparm(23),mgopt(4),icrs(3)
      integer i,j,k,ierror,maxit,iouter
      real fparm(8),rmax(mmaxit)

c
c     use labelled common to identify integer and floating point arguments
c
      integer intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,lwkmin,itero
      common /iprm/intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,lwkmin,itero
      real xa,xb,yc,yd,ze,zf,tolmax,relmax
      common/fprm/xa,xb,yc,yd,ze,zf,tolmax,relmax
      real pi,dx,dy,dz,c,s,x,y,z,tol,err2
      complex cxx,cyy,czz,cx,cy,cz,ce,cxy,cyz
      complex pxx,pyy,pzz,px,py,pz,pxy,pxz,pyz,pe
      equivalence(iparm,intl)
      equivalence(fparm,xa)
      external cof,bd3cr,cxyf,cxzf,cyzf
      pi = 4.*atan(1.)
c
c     set interval end points
c
      xa = 0.0
      xb = 1.0
      yc = 0.0
      yd = pi+pi
      ze = 0.0
      zf = 1.0
c
c     set required no error control within multigrid cycling
c
      tolmax = 0.0
c
c     set integer input arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 1
      nxb = 2
      nyc = 0
      nyd = 0
      nze = 1
      nzf = 2
c
c     set grid size arguments from parameter statements
c
      ixp = iixp
      jyq = jjyq
      kzr = kkzr
      iex = iiex
      jey = jjey
      kez = kkez
      nx = nnx
      ny = nny
      nz = nnz
c
c     flag nonzero xy and yz and zero xz cross derivatives terms
c
      icrs(1) = 1
      icrs(2) = 0
      icrs(3) = 1
c
c     set two multigrid cycles per outer iteration
c
      maxcy = 2
c
c     set point relaxation
c
      method = 0
      meth2 = 0
c
c     set work space length input
c
      nwork = llengt
c
c     set uniform grid interval lengths in each dimension
c
      dx = (xb-xa)/(nx-1)
      dy = (yd-yc)/(ny-1)
      dz = (zf-ze)/(nz-1)
c
c     set right hand side and preset solution to zero
c     this also sets specified (Dirchlet) b.c. in phi
c
      do j=1,ny
	y = (j-1)*dy
	s = sin(y)
	do k=1,nz
	  z = (k-1)*dz
	  do i=1,nx
	    x = (i-1)*dx
	    call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	    call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
	    call cxyf(x,y,z,cxy)
	    call cyzf(x,y,z,cyz)
	    rhs(i,j,k) = cxx*pxx+cyy*pyy+czz*pzz+cxy*pxy+cyz*pyz+
     +                   cx*px+cy*py+cz*pz+ce*pe
	    phi(i,j,k) = 0.0
	  end do
	end do
      end do
c
c     set default multigrid options
c
      mgopt(1) = 0
c
c     set error control tolerance and outer iteration limit of 10
c
      tol = .001
      maxit = mmaxit
c
c     print input arguments shared with cud3
c
      write(*,50)
   50 format(//' cud3cr test ' )
      write(*,100)intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,kez,
     +            nx,ny,nz,iguess,maxcy,method,nwork,xa,xb,yc,yd,ze,zf,
     +            tolmax,mgopt(1)
  100 format(/' input arguments ',
     +/' intl = ',i2,
     +/' nxa = ',i2,' nxb = ',i2,
     +/' nyc = ',i2,' nyd = ',i2,
     +/' nze = ',i2,' nzf = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' kzr = ',i2,
     +/' iex = ',i2, ' jey = ',i2, ' kez = ',i2,
     +/' nx = ',i3,' ny = ',i3,' nz = ',i3,
     +/' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space input = ',i7,
     +/' xa = ',f5.2,' xb = ',f5.2,
     +/' yc = ',f5.2,' yd = ',f5.2,
     +/' ze = ',f5.2,' zf = ',f5.2,
     +/' tolmax = ' ,e10.3
     +//' multigrid options '
     +/' mgopt(1)  = ',i2)
c
c     print new cud3cr arguments
c
      write(*,101) (icrs(i),i=1,3),tol,maxit
  101 format(/' new cud3cr arguments ', / ' icrs '/ 3i5,
     +/' tol = ',f6.4 /' maxit = ',i3)
c
c *** initialization call
c
      intl = 0
      iguess = 0
      call cud3cr(iparm,fparm,work,cof,bd3cr,rhs,phi,mgopt,icrs,
     +cxyf,cxzf,cyzf,tol,maxit,iouter,rmax,ierror)
      write (*,200) intl,iguess,ierror,iparm(22)
  200 format(/' initial call', /' intl = ',i2, /' iguess = ',i2,
     +/' ierror = ',i2, /' minimum required work space length = ',i8)
      if (ierror.gt.0) call exit(0)
c
c *** noninitial call
c
      intl = 1
      iguess = 0
      call cud3cr(iparm,fparm,work,cof,bd3cr,rhs,phi,mgopt,icrs,
     +cxyf,cxzf,cyzf,tol,maxit,iouter,rmax,ierror)
      write (*,201) intl,iguess,ierror,iouter,(rmax(i),i=1,iouter)
  201 format(/' approximation call ', /' intl = ',i2, /' iguess = ',i2,
     +/' ierror = ',i3,
     +/' number of outer iterations executed = ',i3,
     +/' relative difference profile:', /(10(f6.4,2x)))
c
c     compute and print exact least squares error after iouter iterations
c
      err2 = 0.
      do j=1,ny
	y = (j-1)*dy
	c = cos(y)
	do k=1,nz
	  z = (k-1)*dz
	  do i=1,nx
	    x = (i-1)*dx
	    pe = cmplx((x*c*z)**3,0.0)
	    err2 = err2 + cabs(pe - phi(i,j,k))**2
	  end do
	end do
      end do
      err2 = sqrt(err2/(nx*ny*nz))
      write(*,202) err2
  202 format(' exact least squares error = ',e10.3)
      end

      subroutine exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
c
c     set exact solution and partial derivatives: p(x,y,z) = (x*cos(y)*z)**3
c
      implicit none
      real x,y,z
      complex pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz
      real s,c,exz
      real xc,xz,cz,xcz
      c = cos(y)
      s = sin(y)
      xc = x*c
      xz = x*z
      cz = c*z
      xcz = xc*z
      pe = cmplx(xcz**3,0.0)
      px = cmplx(3.*x*x*cz**3,0.0)
      pxx = cmplx(6.*x*cz**3,0.0)
      py =cmplx( -3.*c*c*s*xz**3,0.0)
      pyy = cmplx(-3.*xz**3*(c**3-2.*c*s**2),0.0)
      pz = cmplx(3.*z*z*xc**3,0.0)
      pzz = cmplx(6.*z*xc**3,0.0)
      pxy = cmplx(-9.*x**2*c*c*s*z**3,0.0)
      pxz = cmplx(9.*xz**2*c**3,0.0)
      pyz =cmplx( -9.*c*c*s*x**3*z**2,0.0)
      return
      exz = exp(x*z)
      pe = exz*cmplx(c,z)
      px = z*pe
      py = -exz*s
      pz = x*pe +exz*cmplx(c,1.0)
      pxx = z*px
      pyy = -exz*c
      pzz =  x*(pz+exz*cmplx(c,1.0))
      return
      end

      subroutine cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
c
c     set noncross derivative pde coefficients
c
      implicit none
      real x,y,z,s,c
      complex cxx,cyy,czz,cx,cy,cz,ce
      s = sin(y)
      c = cos(y)
      cxx = cmplx(1.+0.5*s*z, 1.+0.5*c*z)
      cyy = cmplx(1.+x,1.+z)
      czz = cmplx(1+0.5*s*x,1.+0.5*c*x)
      cx = (0.,0.)
      cy = cx
      cz = cz
      ce = -cmplx(x+z,0.0)
      return

      cxx = cmplx(1.+0.5*s*z,0.0)
      cyy = cmplx(1.+x*z,0.0)
      czz = cmplx(1.+0.5*x*s,0.0)
      cx = (0.0,0.0)
      cy = cmplx(-x*z,0.0)
      cz = (0.0,0.0)
      ce = cmplx(-(x+z),0.0)
      return

      cxx = (1.0,1.0)+0.5*cmplx(s*z,c*z)
      cyy = (1.0,1.0)+cmplx(x,z)
      czz = (1.0,1.0)+0.5*cmplx(x*s,x*c)
      cx = (0.0,0.0)
      cy = cmplx(-x*z,x*z)
      cz = (0.0,0.0)
      ce = -cmplx((x+z),0.0)
      return
      end

      subroutine cxyf(x,y,z,cxy)
c
c     set x-y cross term coefficient at (x,y,z)
c
      implicit none
      real x,y,z,cxxr,cxxi,cyyr,cyyi,cxyr,cxyi
      complex cxx,cyy,czz,cx,cy,cz,ce,cxy
      call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
      cxxr = cxx
      cxxi = aimag(cxx)
      cyyr = cyy
      cyyi = aimag(cyy)
      cxyr = sqrt(cxxr*cyyr)
      cxyi = sqrt (cxxi*cyyi)
      cxy = cmplx(cxyr,cxyi)
      return
      end

      subroutine cxzf(x,y,z,cxz)
c
c     this is a dummy subroutine since cxz=0.0 for all (x,y,z)
c
      return
      end

      subroutine cyzf(x,y,z,cyz)
c
c     set y-z cross term coefficient at (x,y,z)
c
      real x,y,z,czzr,czzi,cyyr,cyyi,cyzr,cyzi
      complex cxx,cyy,czz,cx,cy,cz,ce,cyz
      call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
      cyyr = cyy
      cyyi = aimag(cyy)
      czzr = czz
      czzi = aimag(czz)
      cyzr = sqrt(cyyr*cyyi)
      cyzi = sqrt (cyyi*czzi)
      cyz = cmplx(cyzr,cyzi)
      return
      end

      subroutine bd3cr(kbdy,xory,yorz,a,b,c,g)
c
c     pass mixed derivative boundary conditions to cud3cr
c
      implicit none
      integer kbdy
      real x,y,z,xory,yorz
      complex a,b,c,g
      complex pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz
      if (kbdy.eq.2) then
c
c     upper x boundary (mixed oblique)
c
	x = 1.0
	y = xory
	z = yorz
	a = cmplx(z,1.-z)
	b = cmplx(sin(y),cos(y))
	c = - (1.0,1.0)
	call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	g = px + a*py + b*pz + c*pe
	return
      else if (kbdy.eq.6) then
c
c     upper z boundary (mixed normal)
c
	z = 1.0
	x = xory
	y = yorz
	c = cmplx(x,sin(y)**2)
	call exact(x,y,z,pe,px,py,pz,pxx,pyy,pzz,pxy,pxz,pyz)
	g = pz + a*px + b*py + c*pe
	return
      end if
      end


PROGRAM LA_DGEEVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GEEVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, INFO, N, ILO, IHI
   REAL(WP) :: ABNRM
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), SCALE(:), RCONDE(:), RCONDV(:)
   REAL(WP), ALLOCATABLE :: A(:,:), WR(:), WI(:), VL(:,:), VR(:,:), DUMMY(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'DGEEVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
   PRINT *, 'N = ', N
   ALLOCATE ( A(N,N), AA(N,N), WR(N), WI(N), VL(N,N), VR(N,N), SCALE(N), &
              RCONDE(N), RCONDV(N) )
!
   READ (NIN, *) AA
   A=AA
   WRITE(NOUT,*) 'The matrix A:'
   DO I = 1, N; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DGEEVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL, VR, BALANC, &'
   WRITE(NOUT,*) '               ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL, VR, 'N', ILO, IHI, SCALE, &
                  ABNRM, RCONDE, RCONDV, INFO )
   WRITE(NOUT,*) ' ILO, IHI, INFO:', ILO, IHI, INFO
   WRITE(NOUT,*) ' SCALE, ABNRM, RCONDE, RCONDV:'
   WRITE(NOUT,*)   SCALE, ABNRM, RCONDE, RCONDV
   WRITE(NOUT,*) ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
   WRITE(NOUT,*) 'Eigenvectors ( VL and VR ):'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
   WRITE(NOUT,*) 'Eigenvectors ( Only VL ):'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VL(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VR )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VR )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
   WRITE(NOUT,*) 'Eigenvectors ( Only VR ):'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VR(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, BALANC=''P'', INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, BALANC='P', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, BALANC=''S'', INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, BALANC='S', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, BALANC=''B'', INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, BALANC='B', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, BALANC=''1'', INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, BALANC='1', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( DUMMY, WR, WI, VL, VR, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( DUMMY, WR, WI, VL, VR, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR(1:N-1), WI, VL, VR, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR(1:N-1), WI, VL, VR, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI(1:N-1), VL, VR, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI(1:N-1), VL, VR, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL(1:N-1,:), VR, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL(1:N-1,:), VR, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL(:,1:N-1), VR, INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL(:,1:N-1), VR, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL, VR(1:N-1,:), INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL, VR(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEEVX( A, WR, WI, VL, VR(:,1:N-1), INFO=INFO )'
   A=AA
   CALL LA_GEEVX( A, WR, WI, VL, VR(:,1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_DGEEVX_ET_EXAMPLE


!==============================================================================!
  real function Normalized_Root_Mean_Square(ni, r, a, x, norm)
!------------------------------------------------------------------------------!
!   Calculates root means square of vector r, normalizing it with entries      !
!   in the system matrix (a), values of unknown (x) and optional norm.         !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: ni
  real              :: r(:)  ! this may be only in inner cells
  type(Matrix_Type) :: a
  real              :: x(:)  ! presumably, this goes to buffer cells
  real, optional    :: norm  ! optional number for normalization
!-----------------------------------[Locals]-----------------------------------!
  real    :: rms, x_max, x_min
  integer :: i
!==============================================================================!

  ! Compute rms normalizing it with main diagonal in the system matrix
  rms = 0.0
  do i = 1, ni
    rms = rms + r(i)**2 / a % val(a % dia(i))**2
  end do
  call Comm_Mod_Global_Sum_Real(rms)
  rms = sqrt(rms)

  ! Normalize it with absolute values of the unknown
  if(.not. present(norm)) then
    x_min = minval(x(1:ni))
    x_max = maxval(x(1:ni))
  else
    x_min = 0.0
    x_max = norm
  endif
  call Comm_Mod_Global_Min_Real(x_min)
  call Comm_Mod_Global_Max_Real(x_max)

  ! Create a plateau for very small sources and values
  if( (x_max-x_min) < NANO .and. rms < NANO ) then
    rms = PICO
  else
    rms = rms / (x_max - x_min + TINY)
  end if

  Normalized_Root_Mean_Square = rms

  end function


      PROGRAM xtoeplz
C     driver for routine toeplz
      INTEGER N,N2
      PARAMETER(N=5,N2=2*N)
      INTEGER i,j
      REAL sum,x(N),y(N),r(N2)
      do 11 i=1,N
        y(i)=0.1*i
11    continue
      do 12 i=1,2*N-1
        r(i)=1./i
12    continue
      call toeplz(r,x,y,N)
      write(*,*) 'Solution vector:'
      do 13 i=1,N
        write(*,'(5x,a2,i1,a4,e13.6)') 'X(',i,') = ',x(i)
13    continue
      write(*,'(/1x,a)') 'Test of solution:'
      write(*,'(1x,t6,a,t19,a)') 'mtrx*soln','original'
      do 15 i=1,N
        sum=0.0
        do 14 j=1,N
          sum=sum+r(N+i-j)*x(j)
14      continue
        write(*,'(1x,2f12.4)') sum,y(i)
15    continue
      END

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


PROGRAM freq2d
! Generate pairs of random numbers and put into 256 x 256 bins.

IMPLICIT NONE
INTEGER              :: i, j, k, l, lower, ndf, nrows, ncols, upper
REAL                 :: x(2), aver, stdev, chisq
INTEGER, ALLOCATABLE :: freq(:,:), seed(:)
CHARACTER (LEN=200)  :: text

WRITE(*, *) 'Enter number of rows & columns (e.g. 24  64): '
READ(*, *) nrows, ncols
ALLOCATE( freq(0:nrows-1,0:ncols-1) )

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
CALL RANDOM_SEED(get=seed)
WRITE(*, *)'Old random number seeds: ', seed

WRITE(*, '(a, i4, a)') ' Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

! Generate 4096 x 4096 pairs of random numbers

freq = 0
DO i = 1, 4096
  DO j = 1, 4096
    CALL RANDOM_NUMBER(x)
    k = nrows * x(1)
    l = ncols * x(2)
    freq(k,l) = freq(k,l) + 1
  END DO
END DO

! Average & variance of number in each cell = 4096 x 4096 / (nrows x ncols)
aver = 4096. * 4096. / (nrows * ncols)
stdev = SQRT(aver)
upper = aver + 3.*stdev + 0.5
lower = aver - 3.*stdev + 0.5

chisq = 0.0
DO k = 0, nrows-1
  text = ' '
  DO l = 0, ncols-1
    IF (freq(k,l) >= lower .AND. freq(k,l) <= upper) THEN
      text(l+3:l+3) = '+'
    ELSE IF (freq(k,l) > upper) THEN
      text(l+3:l+3) = CHAR(219)
    END IF
    chisq = chisq + (freq(k,l) - aver)**2
  END DO
  WRITE(*, '(a)') TRIM(text)
END DO

WRITE(*, *) '  If most of the cells are NOT pluses, its a bad generator'

chisq = chisq / aver
ndf = nrows * ncols - 1
WRITE(*, '(a, f10.1, a, i6, a)')  &
         ' Chi-squared =', chisq, ' with', ndf, ' deg. of freedom'
chisq = ndf + 2.0*SQRT(2.0*ndf)
WRITE(*, '(a, f10.1)') ' Chi-squared should be less than', chisq

STOP
END PROGRAM freq2d


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program sys_sim502

! Looks at how to deal with correlation errors given null assumption about
! a uniform distribution for the underlying true correlation distirubtions.
! Generates a huge sample of [-1, 1) uniform correlations, then samples these,
! and keeps track of the sample correlation / true correlation pairs. Then
! it bins these together over small sample correlation ranges and looks at
! the value of alpha that would minimize errors. NOTE: this gives much less
! info than group filter because group filter draws from a much more
! meaningful prior (i.e. from what the model and assim have generated).

use types_mod, only : r8
use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian, &
   twod_gaussians, random_uniform

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer, parameter :: num_bins = 50
real(r8) :: sum(num_bins) = 0.0, sum2(num_bins)
integer  :: num(num_bins) = 0.0
type (random_seq_type) :: r
real(r8) :: correl, cov(2, 2), zero_2(2) = 0.0, correl_mean, correl_var, sd
real(r8) :: q, alpha, alpha2, mean_abs_correl, sample_correl, real_correl
real(r8), allocatable :: pairs(:, :)
real(r8) :: bottom_cor, top_cor, sum_sample2, sum_sample_real, sum_real
real(r8) :: q_factor
integer :: ens_size, n_samples, i, j, k, sample_size, bin

! Generate a bazillion cases where the background correlation is assumed to
! be U(-1, 1)
! For each case sampled from this, create a SAMPLE correlation
! and store the sample correlation and the actual correlation in a huge
! array.

! Initialize repeatable random sequence
call init_random_seq(r)

! For now have a set of free parameters that may be too large
write(*, *) 'Input ensemble size'
read(*, *) ens_size
write(*, *) 'Input number of samples for statistics'
read(*, *) n_samples

! Allocate storage for sample from this correlation
allocate(pairs(2, ens_size))

! Loop through a set of sample draws from uniform (-1, 1)
do k = 1, n_samples
   111 real_correl = -1.0 + 2.0 * random_uniform(r)
   ! Generate the covariance matrix for this correlation
   cov(1, 1) = 1.0;    cov(2, 2) = 1.0
   cov(1, 2) = real_correl; cov(2, 1) = real_correl

   ! Loop to generate an ensemble size sample from this correl
   ! Generate a random sample of size ens_size from something with this correlation
   do i = 1, ens_size
      call twod_gaussians(r, zero_2, cov, pairs(:, i))
   end do

   ! Compute the sample correlation
   call comp_correl(pairs, ens_size, sample_correl)

   !!!   if(sample_correl > 0.1 .or. sample_correl < -0.1) goto 111

   !!!write(*, *) k, real_correl, sample_correl

   ! Now adjust the information for the appropriate sample_correl bin
   bin = (sample_correl + 1.0) / 2.0 * (num_bins) + 1

   num(bin) = num(bin) + 1
   sum(bin) = sum(bin) + real_correl
   sum2(bin) = sum2(bin) + real_correl*real_correl

end do

do i = 1, num_bins
   ! Output sample and mean real for this bin
   sample_correl = ((i - 0.5) / num_bins) * 2.0 - 1.0
   real_correl = sum(i) / num(i)
   sd = sqrt((sum2(i) - num(i) * real_correl**2) / (num(i) - 1.0))
   q = sd / abs(real_correl)
   q_factor = (num(i) - q**2) / ((num(i) - 1) * q + num(i))
   write(*, 11) i, num(i), sample_correl, real_correl, &
      real_correl / sample_correl, sd, q_factor
   11 format(i4, 1x, i8, 1x, 5(e10.4, 1x))
end do

if(1 == 1) stop

!!!   write(*, *) 'optimal alpha is ', sum_sample_real / sum_sample2, sample_size
!!!   write(*, *) 'mean real_correl is ', sum_real / sample_size

end program sys_sim502

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

subroutine comp_correl(ens, n, correl)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: ens(2, n)
double precision, intent(out) :: correl
double precision :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

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

subroutine sample_mean_var(x, n, mean, var)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: x(n)
double precision, intent(out) :: mean, var

double precision :: sx, s_x2

sx = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var


      double complex function Aslcphiqarbmppm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      include 'deltar.f'
      double precision s12,s13,s41,s23,s24,s34
      double precision s123,s234,s341,s412,mhsq
      double complex Vslc,Lsm1_2me,L0,L1,lnrat,A0phiqarbmppm
      integer j1,j2,j3,j4
      s12=s(j1,j2)
      s13=s(j1,j3)
      s41=s(j4,j1)
      s23=s(j2,j3)
      s24=s(j2,j4)
      s34=s(j3,j4)
      s123=s12+s13+s23
      s234=s23+s24+s34
      s341=s34+s41+s13
      s412=s41+s12+s24
      mhsq=s12+s13+s41+s23+s24+s34

C---arXIv:09060008v1 Eq.(4.11)
      Vslc=
     & -epinv**2*2d0
     & -epinv*lnrat(musq,-s12)-epinv*lnrat(musq,-s34)
     & -0.5d0*lnrat(musq,-s12)**2-0.5d0*lnrat(musq,-s34)**2
     & -3d0/2d0*(2d0*epinv+lnrat(musq,-s12)+lnrat(musq,-s34))
     & -Lsm1_2me(s412,s123,s12,mhsq)
     & -Lsm1_2me(s234,s341,s34,mhsq)
     & -7d0-deltar

C---arXIv:09060008v1 Eq.(4.10)
c--- the function defined in this routine is in fact (-i*A_4),
c---   i.e. complete LHS
      Aslcphiqarbmppm=A0phiqarbmppm(j1,j2,j3,j4,za,zb)*Vslc
     & +0.5d0*za(j1,j2)*za(j3,j4)*zb(j2,j3)**2
     & *(L1(-s123,-s12)/s12**2 + L1(-s234,-s34)/s34**2)
     & - za(j1,j4)*zb(j2,j3)*(L0(-s123,-s12)/s12+L0(-s234,-s34)/s34)
      return
      end


function ifft2(yh) result(y)
! IFFT2 function
complex(kind=8), intent(in)     :: yh(:,:)
integer(kind=8)                 :: plan_backward
complex(kind=8), allocatable    :: y(:,:)
allocate(yh(size(y,1),size(y,2)))
call dfftw_plan_dft_2d_ (plan_backward, size(yh,1), size(yh,2), yh, y, FFTW_BACKWARD, FFTW_MEASURE)
call dfftw_execute(plan_backward)
y = y/real(size(y,1) * size(y,2),dp)
end function ifft2


module  elemental_procedure
  implicit none
contains
  elemental real function f(x,y)
    real, intent(in) :: x,y
    f = sqrt(x**2 + y**2)
  end function f
end module elemental_procedure


!/*******************************************************
! * Calculating Pi with using midpoint rectangle method:*
! *  integral 4.0/(1+x^2) dx = pi	     	       	*
! *  or 						*
! *  summation (for i=0 to n) 4.0/(1+x_i^2)             *
! *  	where x_i = (i + 1/2) * delta x			*
! * 	   OpenMP Version 1	  			*
! *******************************************************/
program pi_serial
implicit none
integer*8 :: num_steps = 1000000000
integer i
real*8 :: PI_ref=3.1415926535897932,step,x,pi
real*8 :: summation=0.0
real   :: start,finish,omp_get_wtime
start=omp_get_wtime()
step = 1/(1.0 * num_steps)
	do i =1,num_steps
 ! Write an algorithm which first evaluates the
 ! 	evaluate midpoint of ith rectangle (x_i)
 ! 	updates the sum by evaluating f(x) at x
	end do
 ! Uptade value of pi
finish=omp_get_wtime()
	write(*,*) "Estimated value of pi =",pi
	write(*,*) "Error =", abs(PI_ref - pi)
	write(*,*) "Compute time=", (finish-start)," seconds"
	end


SUBROUTINE linmul_sky(kv,disps,loads,kdiag)
!
! This subroutine forms the product of symmetric matrix stored as
! a skyline and a vector.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:),disps(0:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,j,low,lup,k
 REAL(iwp)::x,zero=0.0_iwp
 n=UBOUND(disps,1)
 DO i=1,n
   x=zero
   lup=kdiag(i)
   IF(i==1)low=lup
   IF(i/=1)low=kdiag(i-1)+1
   DO j=low,lup
     x=x+kv(j)*disps(i+j-lup)
   END DO
   loads(i)=x
   IF(i==1)CYCLE
   lup=lup-1
   DO j=low,lup
     k=i+j-lup-1
     loads(k)=loads(k)+kv(j)*disps(i)
   END DO
 END DO
RETURN
END SUBROUTINE linmul_sky


program ising ! 2D Monte Carlo Simulation of Ising Model
! Lisa Larrimore, lisal@sccs.swarthmore.edu
! 3 May 2002
! Physics 114 Final Project
! This program is adapted from the Ising Model program written in
! BASIC by Elaine Chandler that appears on p. 184 of David Chandler’s
! Introduction to Modern Statistical Mechanics.

 ! The input parameters for this program are in "ising.in", and they
 ! allow the size, length, and initial configuration of the simulation
 ! to be changed. See comments in file.

 ! This program has three output files:
 !
 ! "spin-array" Contains snapshots of the spin lattice at the end of
 ! each temperature run (or throughout the middle of the
 ! run, if only looking at one temperature). Can be
 ! visualized with the IDL program see_spins.pro
 !
 ! "magnetization" Contains four columns: each temperature, the
 ! average magnetization at that temp, the ave magnetizaion
 ! squared at that temp, and the susceptibility.
 !
 ! "energy" Contains four columns: each temperature, the
 ! average energy at that temp, the ave energy squared
 ! at that temp, and the heat capacity.

 implicit none

 ! Variable declarations:
 integer :: i, j, m, n, m2, n2 ! dummy integers
 integer, allocatable :: A(:,:) ! matrix containing spins
 integer :: nrows, ncols ! number of rows and cols of A
 real :: temp, beta ! temperature, inverse temperature
 integer :: ConfigType ! starting configuration type
 integer :: npass ! number of passes for MC algorithm
 integer :: ipass ! the current pass number
 integer :: nequil ! number of equilibration steps
 integer :: trial_spin ! values of changed spin
 real :: high_temp ! starting temp for scan
 real :: low_temp ! final temp for scan
 real :: temp_interval ! interval between scan points
 integer :: nscans ! number of scans (each at diff T)
 integer :: iscan ! current scan number
 logical :: MovieOn ! set to .true. to make movie of 1 temp
 real :: deltaU ! change in energy between 2 configs
 real :: deltaU1 ! energy changes for lattice gas
 real :: log_eta ! log of random number to compare to
 real :: magnetization ! magnetization of all spins in lattice
 real :: magnetization_ave ! cumulative average magnetization
 real :: magnetization2_ave ! cumulative average of mag. squared
 real :: energy ! energy of all spins in lattice
 real :: energy_ave ! cumulative average of energy
 real :: energy2_ave ! cumulative average of energy squared
 integer :: output_count ! # times things have been added to averages

 print*, "________________MONTE CARLO 2D ISING MODEL________________"
 print*, "Monte Carlo Statistics for 2D Ising Model with"
 print*, " periodic boundary conditions."
 print*, "The critical temperature is approximately 2.3, as seen on"
 print*, " Chandler p. 123."

 ! Read in input parameters from file "ising.in"
 open(UNIT=11,FILE='ising.in',STATUS='old',ACTION='read')
 read(11,*);read(11,*) nrows
 read(11,*);read(11,*) ncols
 read(11,*);read(11,*) npass
 read(11,*);read(11,*) nequil
 read(11,*);read(11,*) high_temp
 read(11,*);read(11,*) low_temp
 read(11,*);read(11,*) temp_interval
 read(11,*);read(11,*) ConfigType
 read(11,*);read(11,*) MovieOn
 close(11)

 ! Set the dimensions of the matrix of spin arrays. This program uses
 ! periodic boundary conditions, so the first two rows and columns are
 ! the same as the last two.
 allocate(A(nrows+2,ncols+2))

 ! Open output files:
 open(unit=32,file='spin-array',status='replace',action='write')
 write(32,*) nrows
 write(32,*) ncols
 nscans = int((high_temp - low_temp)/temp_interval) + 1
 if (MovieOn) then
 write(32,*) 51
 write(32,*) 1
 else
 write(32,*) nscans
 write(32,*) 2
 endif

 open(unit=33,file='magnetization',status='replace',action='write')
 write(33,*) "temp ave_magnetization ave_magnetization^2 susceptibility"
 open(unit=34,file='energy',status='replace',action='write')
 write(34,*) "temp ave_energy ave_energy^2 C_v"

 scan_loop: do iscan = 1, nscans
 temp = high_temp - temp_interval*(iscan-1)
 print*, "Running program for T =", temp

 ! Initialize variables
 beta = 1.0/temp
 output_count = 0
 energy_ave = 0.0
 energy2_ave = 0.0
 magnetization_ave = 0.0
 magnetization2_ave = 0.0

 ! Set up the initial spin configuration.
 select case(ConfigType)
 case(1) ! checkerboard setup

 !A(1,1) = 1
 do i = 1, nrows+2
 !A(i+1,1) = -A(i,1)

 do j = 1, ncols+2
 A(i,j) = 1
 !A(:,j+1) = -A(:,j)
 enddo
 enddo
 ! (note: the requirement that nrows and ncols are even is to
 ! ensure that the first two rows/cols start out the same as the
 ! last two)
 case(2) ! interface
 do i = 1, nrows+2
 do j = 1, (ncols+2)/2
 A(i,j) = 1
 enddo
 do j = (ncols+2)/2 + 1, ncols+2
 A(i,j) = -1
 enddo
 enddo
 case(3) ! unequal interface
 do i = 1, nrows+2
 do j = 1, (ncols+2)/4
 A(i,j) = 1
 enddo
 do j = (ncols+2)/4 + 1, ncols+2
 A(i,j) = -1
 enddo
 enddo
 case default
 print*, "Error! Check ConfigType parameter in ising.in"
 stop
 end select

 ! Main loop containing Monte Carlo algorithm:
 MC_passes: do ipass = 0, npass

 ! If MovieOn is .true., write the spin array to an output every
 ! npass/50 steps.
 if ((MovieOn) .and. (mod(ipass,npass/50) == 0)) then
 do i = 2, nrows+1
 do j = 2, ncols+1
 write(32,*) A(i,j)
 enddo
 enddo
 endif

 ! If ipass is greater than nequil (the number of equilibration steps),
 ! calculate the magnetization and energy:
 if (ipass > nequil) then
 output_count = output_count + 1
 magnetization = sum(A(2:nrows+1,2:nrows+1))/(ncols*nrows*1.0)
 magnetization_ave = magnetization_ave + magnetization
 magnetization2_ave = magnetization2_ave + magnetization**2
 energy = 0.0
 do i = 2, nrows + 1
 do j = 2, ncols + 1
 energy = energy - A(m,n)*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))
 enddo
 enddo
 ! Divide the energy by the total number of spins to get the ave
 ! energy per spin, and divide by 2 to account for double counting.
 energy = energy/(ncols*nrows*2.0)
 energy_ave = energy_ave + energy
 energy2_ave = energy2_ave + energy**2
 endif

 ! Randomly choose a spin to change:
 m = nint((nrows-1)*ran1(5) + 2) ! choose a random row
 n = nint((ncols-1)*ran1(5) + 2) ! choose a random column
 trial_spin = -A(m,n) ! trial spin value

 ! Find change in energy (deltaU) due to trial move.
 ! If exp(-beta*deltaU) > eta, where eta is random, accept move:
 deltaU = -trial_spin*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))*2
 log_eta = dlog(ran1(5) + 1.0d-10) ! random number 0-1 (+ tiny offset)
 if (-beta*deltaU > log_eta) then
 A(m,n) = trial_spin
 if (m == 2) A(nrows+2,n) = trial_spin
 if (m == nrows+1) A(1,n) = trial_spin
 if (n == 2) A(m,ncols+2) = trial_spin
 if (n == ncols+1) A(m,1) = trial_spin
 endif

 enddo MC_passes

 ! Write final spin array to output file
 if (.not. MovieOn) then
 do i = 2, nrows + 1
 do j = 2, ncols + 1
 write(32,*) A(i,j)
 enddo
 enddo
 endif
 write(33,*) temp, abs(magnetization_ave/output_count), &
 magnetization2_ave/output_count, &
 beta*(magnetization2_ave/output_count - (magnetization_ave/output_count)**2)
 write(34,*) temp, energy_ave/output_count, energy2_ave/output_count, &
 (beta**2)*(energy2_ave/output_count - (energy_ave/output_count)**2)

 enddo scan_loop

 close(32)
 close(33)
 close(34)

 print*, "Program ising.f90 complete!"
 print*, "Look at ’spin-array’ with IDL program see_spins.pro"

 contains

 !_______RANDOM NUMBER GENERATING FUNCTION______!

 double precision function ran1(idum)
 implicit none
 double precision :: r(97)
 integer, intent(IN) :: idum
 save
 integer, parameter :: M1=259200,IA1=7141,IC1=54773
 real, parameter :: RM1=1.0d0/M1
 integer, parameter :: M2=134456,IA2=8121,IC2=28411
 real, parameter :: RM2=1.0d0/M2
 integer, parameter :: M3=243000,IA3=4561,IC3=51349
 integer :: IX1, IX2, IX3, jjj
 integer :: iff=0
 if (idum < 0 .or. iff == 0) then
 iff = 1
 IX1 = mod(IC1-idum,M1)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IX1,M2)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX3 = mod(IX1,M3)
 do jjj = 1,97
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end do
 end if
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 IX3 = mod(IA3*IX3+IC3,M3)
 jjj = 1+(97*IX3)/M3
 if (jjj > 97 .or. jjj < 1) write(*,*) "asd"
 ran1 = r(jjj)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end function ran1

 end program ising


      double complex function A51mmppp(j1,j2,j3,j4,j5,za,zb)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      include 'epinv.f'
      include 'scale.f'
      double complex Vf,Vs,Ff,Fs,L0,L2,miA5tree,lnrat
      integer j1,j2,j3,j4,j5
C----Eq.(8,10) of hep-ph/9302280v1 of BDK multiplied by 16*pi^2*(-i)
C--- to give (16*pi^2)*(-i)*A^{[1/2]}_{5;1}
      miA5tree=za(j1,j2)**4
     & /(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j4,j5)*za(j5,j1))
      Vf=dcmplx(-2.5d0*epinv-2d0)
     & -0.5d0*(lnrat(musq,-s(j2,j3))+lnrat(musq,-s(j5,j1)))
      Vs=-Vf/3d0+dcmplx(2d0/9d0)
      Ff=-za(j1,j2)**2*L0(-s(j2,j3),-s(j5,j1))
     & *(za(j2,j3)*zb(j3,j4)*za(j4,j1)+za(j2,j4)*zb(j4,j5)*za(j5,j1))
     & /(2d0*za(j2,j3)*za(j3,j4)*za(j4,j5)*za(j5,j1)*s(j5,j1))
      Fs=-Ff/3d0
     & -zb(j3,j4)*za(j4,j1)*za(j2,j4)*zb(j4,j5)*L2(-s(j2,j3),-s(j5,j1))
     & *(za(j2,j3)*zb(j3,j4)*za(j4,j1)+za(j2,j4)*zb(j4,j5)*za(j5,j1))
     & /(3d0*za(j3,j4)*za(j4,j5)*s(j5,j1)**3)
     & -za(j3,j5)*zb(j3,j5)**3
     & /(3d0*zb(j1,j2)*zb(j2,j3)*za(j3,j4)*za(j4,j5)*zb(j5,j1))
     & +za(j1,j2)*zb(j3,j5)**2
     & /(3d0*zb(j2,j3)*za(j3,j4)*za(j4,j5)*zb(j5,j1))
     & +za(j1,j2)*zb(j3,j4)*za(j4,j1)*za(j2,j4)*zb(j4,j5)
     & /(6d0*s(j2,j3)*za(j3,j4)*za(j4,j5)*s(j5,j1))
      A51mmppp=-(Vf+Vs)*miA5tree-(Ff+Fs)

c      write(6,*) 'j1,j2,j3,j4,j5,miA5tree',j1,j2,j3,j4,j5,miA5tree
      return
      end


    MODULE mod_kep
    CONTAINS
    SUBROUTINE kep(kep_io)
    IMPLICIT NONE
    INCLUDE 'kep_struct.h'
    TYPE(kep_struct) :: kep_io
!=======================================================================
!
!   SUBROUTINE kep computes the k-th eigenpair of generalized symmetric
!   definite eigenproblems.
!
!   TYPE(kep_struct) kep_io includes the following variables:
!
!   n       : <INPUT, INTEGER>
!             matrix size
!
!   nz_a    : <INPUT, INTEGER>
!             number of non-zero elements of matrix A
!   indx_a  : <INPUT, INTEGER array, ALLOCATABLE(:)>
!             row index of non-zero elements of matrix A.
!             ALLOCATE with dimension nz_a and assign values before call
!   jndx_a  : <INPUT, INTEGER array, ALLOCATABLE(:)>
!             column index of non-zero elements of matrix A.
!             ALLOCATE with dimension nz_a and assign values before call
!   rval_a  : <INPUT, DOUBLE PRECISION array, ALLOCATABLE(:)>
!             value of non-zero elements of matrix A.
!             ALLOCATE with dimension nz_a and assign values before call
!
!   nz_b    : <INPUT, INTEGER>
!             number of non-zero elements of matrix B
!   indx_b  : <INPUT, INTEGER array, ALLOCATABLE(:)>
!             row index of non-zero elements of matrix B.
!             ALLOCATE with dimension nz_b and assign values before call
!   jndx_b  : <INPUT, INTEGER array, ALLOCATABLE(:)>
!             column index of non-zero elements of matrix B.
!             ALLOCATE with dimension nz_b and assign values before call
!   rval_b  : <INPUT, DOUBLE PRECISION array, ALLOCATABLE(:)>
!             value of non-zero elements of matrix B.
!             ALLOCATE with dimension nz_b and assign values before call
!
!   k       : <INPUT, INTEGER>
!             target index.
!             Required to satisfy 1 < k < n
!
!   iprm    : <INPUT, INTEGER array, DIMENSION(31)>
!             parameters for SUBROUTINE kep
!   iprm(1) : stopping criterion for bisection
!             ( = maximum number of eigenpairs computed together).
!             Required to satisfy 1 <= iprm(1) < n.
!             See m_max in reference [1]
!   iprm(2) : 10**-iprm(2) is tolerance for relative residual 2-norm.
!             Required to satisfy 1 <= iprm(2) <= 16.
!             See tau_res in [1]
!   iprm(3) : 10**-iprm(3) is tolerance for relative difference 2-norm.
!             Required to satisfy 1 <= iprm(3) <= 16.
!             See tau_diff in [1]
!   iprm(11): maximum iterations to set an initial interval
!             ( = maximum iterations for Lanczos).
!             Required to satisfy 2 <= iprm(11) <= n.
!             See Algorithm 2 in [1]
!   iprm(12): maximum iterations to narrow down the interval
!             ( = maximum iterations for Bisection).
!             Required to satisfy 0 <= iprm(12) <= 64.
!             See Algorithm 1' in [1]
!   iprm(13): maximum iterations to compute eigenpairs of the interval
!             ( = maximum iterations for shift-and-invert Lanczos).
!             Required to satisfy iprm(1) <= iprm(13) <= n.
!             See Algorithm 3 in [1]
!   iprm(21): If iprm(21) > 0, print details of computation to terminal
!   iprm(22): If iprm(22) =< 0, output only the k-th eigenpair.
!             Otherwise, output all computed eigenpairs.
!             See the description of kndx, kval, and kvec below
!
!   kndx    : <OUTPUT, INTEGER array, ALLOCATABLE(:)>
!             If iprm(22) =< 0, kndx includes only the index k.
!             Otherwise, kndx includes the index of all computed
!             eigenpairs in increasing order
!   kval    : <OUTPUT, DOUBLE PRECISON array, ALLOCATABLE(:)>
!             If iprm(22) =< 0, kval includes only the k-th eigenvalue.
!             Otherwise, kval includes all computed eigenvalues in
!             increasing order
!   kvec   :  <OUTPUT, DOUBLE PRECISON array, ALLOCATABLE(:)>
!             If iprm(22) =< 0, kvec includes only the k-th eigenvector
!             normalized with respect to 2-norm. Otherwise, kvec
!             includes all computed eigenvectors
!
!   info    : <OUTPUT, INTEGER>
!             diagonostic information
!   info = 0: successful exit
!   info < 0: illegal value in k, iprm
!   info > 0: failed to find the k-th eigenpair
!
!-----------------------------------------------------------------------
!
!   References
!   [1] D. Lee, T. Hoshi, T. Sogabe, Y. Miyatake, S.-L. Zhang,
!       Solution of the k-th eigenvalue problem
!       in large-scale electronic structure calculations,
!       https://arxiv.org/abs/1710.05134.
!
!=======================================================================
!
!   Convert data to Compressed Row Storage (CRS) format
    INTEGER :: row_pntr_a,col_indx_a,row_pntr_b,col_indx_b
    DOUBLE PRECISION :: a,b
    DIMENSION :: row_pntr_a(kep_io%n+1),col_indx_a(kep_io%nz_a),&
        &        row_pntr_b(kep_io%n+1),col_indx_b(kep_io%nz_b),&
        &        a(kep_io%nz_a),b(kep_io%nz_b)
!
!   MUMPS
    INCLUDE 'mpif.h'
    INCLUDE 'dmumps_struc.h'
    INTEGER :: ierr,m_ord
    TYPE(DMUMPS_STRUC) :: m_1,m_2,m_3
    ALLOCATABLE :: m_ord
    DIMENSION :: m_ord(:)
!
!   Lanczos
    INTEGER :: imax_lanc,its_lanc,ijob
    DOUBLE PRECISION :: v,bv,alpha,beta,theta
    ALLOCATABLE :: v,bv,alpha,beta,theta
    DIMENSION :: alpha(:),theta(:),beta(:)
    DIMENSION :: v(:,:),bv(:,:)
!
!   Bisection
    INTEGER :: imax_bi,mmax
!
!   Shift-and-invert Lanczos
    INTEGER :: imax_si,its_si,ijob_si,ijob_test,info_test
    DOUBLE PRECISION :: tol_res,tol_dif,                    &
    &   v_si,bv_si,alpha_si,beta_si,theta_si,               &
    &   y,lngth,egnval,egnvec,egnvec_old,resnorm,difnorm
    ALLOCATABLE :: v_si,bv_si,alpha_si,beta_si,theta_si,y,  &
    &   egnval,egnvec,egnvec_old,resnorm,difnorm
    DIMENSION :: alpha_si(:),theta_si(:),beta_si(:),        &
    &   egnval(:),resnorm(:),difnorm(:)
    DIMENSION :: v_si(:,:),bv_si(:,:),y(:,:),egnvec(:,:),egnvec_old(:,:)
!
!   Time
    INTEGER :: clock_1,clock_2,clock_rate,clock_max
    REAL :: cmpt_time
    DIMENSION :: cmpt_time(10)
!
!   Results
    INTEGER :: icnt
    DIMENSION :: icnt(10)
    TYPE :: shift_inertia
        SEQUENCE
        DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: shift
        INTEGER, ALLOCATABLE, DIMENSION(:) :: inertia
    END TYPE shift_inertia
    TYPE(shift_inertia) :: si_1,si_2_l,si_2_r,si_3
!
!   Local arguments
    INTEGER :: i,j
    DOUBLE PRECISION :: dtmp
!
!---Initialize----------------------------------------------------------
!
!   Check matrices
    kep_io%info=0
    IF(.NOT.(ALLOCATED(kep_io%indx_a).AND.ALLOCATED(kep_io%jndx_a).AND.&
        &    ALLOCATED(kep_io%indx_b).AND.ALLOCATED(kep_io%jndx_b).AND.&
        &    ALLOCATED(kep_io%rval_a).AND.ALLOCATED(kep_io%rval_b))   )&
        & kep_io%info=-1
    IF(kep_io%info.NE.0) THEN
        CALL kep_info(kep_io%info)
        RETURN
    END IF
!
!   Check parameters
    CALL kep_checkprm(kep_io%n,kep_io%k,kep_io%iprm,kep_io%info)
    IF(kep_io%info.NE.0) THEN
        CALL kep_info(kep_io%info)
        RETURN
    END IF
!
!   Initialize counts and info
    icnt=0
    info_test=0
!
!   Lanczos
    imax_lanc=kep_io%iprm(11)
    its_lanc=1
    ijob=1
!
!   Bisection
    imax_bi=kep_io%iprm(12)
    mmax=kep_io%iprm(1)
!
!   Shift-and-invert Lanczos
    imax_si=kep_io%iprm(13)
    its_si=1
    ijob_si=1
    ijob_test=1
    tol_res=1.0D1**(-REAL(2*kep_io%iprm(2)))
    tol_dif=1.0D1**(-REAL(2*kep_io%iprm(3)))
!
!   Time and results
    cmpt_time=0.0E0
!
    ALLOCATE(si_1%shift(0:imax_lanc),si_1%inertia(0:imax_lanc))
    ALLOCATE(si_2_l%shift(0:imax_bi),si_2_l%inertia(0:imax_bi), &
    &        si_2_r%shift(0:imax_bi),si_2_r%inertia(0:imax_bi))
    ALLOCATE(si_3%shift(1),si_3%inertia(1))
    ALLOCATE(egnval(mmax),egnvec(kep_io%n,mmax+2),                     &
    &        egnvec_old(kep_io%n,mmax),resnorm(mmax),difnorm(mmax))
!
!   Convert data to Compressed Row Storage (CRS) format
    CALL kep_mtx2crs(kep_io%n,kep_io%nz_a,kep_io%indx_a,kep_io%jndx_a,&
        &            kep_io%rval_a,row_pntr_a,col_indx_a,a)
    CALL kep_mtx2crs(kep_io%n,kep_io%nz_b,kep_io%indx_b,kep_io%jndx_b,&
        &            kep_io%rval_b,row_pntr_b,col_indx_b,b)
!
!   MUMPS
    CALL mpi_init(ierr)
    INCLUDE 'm_1'
    INCLUDE 'm_2'
!
!---Step 1 : set an initial interval------------------------------------
!
!   Task (i) : symbolic factorizaion of B
    CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
    m_1%job=1
    CALL dmumps(m_1)
    IF(m_1%infog(1).NE.0) THEN
        kep_io%info=11
        CALL kep_info(kep_io%info)
        RETURN
    END IF
    CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
    cmpt_time(1)=REAL(clock_2-clock_1)/REAL(clock_rate)
!
!   Recycle and reuse fill-reducing ordering
    m_ord=m_1%sym_perm
    m_2%perm_in=m_ord
!
!   Task (ii) : numerical factorizaion of B
    CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
    m_1%JOB=2
    CALL dmumps(m_1)
    IF(m_1%infog(1).NE.0) THEN
        kep_io%info=12
        CALL kep_info(kep_io%info)
        RETURN
    END IF
    CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
    cmpt_time(2)=REAL(clock_2-clock_1)/REAL(clock_rate)
!
!   Task (iii) : Lanczos method with reverse communication==============
!
    ALLOCATE(alpha(imax_lanc),theta(imax_lanc),beta(0:imax_lanc),&
    &   v(kep_io%n,imax_lanc+1),bv(kep_io%n,0:imax_lanc+1))
!
!   Initialize
    CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
    CALL kep_lanczos(kep_io%n,imax_lanc,its_lanc,ijob,v,bv,&
        &            alpha,beta,theta)
    CALL kep_matvec(kep_io%n,kep_io%nz_b,row_pntr_b,col_indx_b,b,&
        &           v(:,1),bv(:,1))
    CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
    cmpt_time(3)=cmpt_time(3)+REAL(clock_2-clock_1)/REAL(clock_rate)
!
    DO i=1,imax_lanc
!       Expand subspace and solve tridiagonal eigenproblem
        CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
        CALL kep_lanczos(kep_io%n,imax_lanc,its_lanc,ijob,v,bv,&
            &            alpha,beta,theta)
        CALL kep_matvec(kep_io%n,kep_io%nz_a,row_pntr_a,col_indx_a,a,&
            &           v(:,its_lanc),bv(:,its_lanc+1))
        CALL kep_lanczos(kep_io%n,imax_lanc,its_lanc,ijob,v,bv,&
            &            alpha,beta,theta)
        m_1%rhs=bv(:,its_lanc+1)
        m_1%job=3
        CALL dmumps(m_1)
        IF(m_1%infog(1).NE.0) THEN
            kep_io%info=13
            CALL kep_info(kep_io%info)
            RETURN
        END IF
        v(:,its_lanc+1)=m_1%rhs
        CALL kep_lanczos(kep_io%n,imax_lanc,its_lanc,ijob,v,&
            &            bv,alpha,beta,theta)
        CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
        cmpt_time(3)=cmpt_time(3)+REAL(clock_2-clock_1)/REAL(clock_rate)
!
!       Task (iv) : inertia computation
        CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
        IF(si_1%inertia(i-1).GE.kep_io%k) THEN
            si_1%shift(i)=theta(1)
        ELSE
            si_1%shift(i)=theta(i)
        END IF
        m_2%a(1:kep_io%nz_a)=a
        m_2%a(kep_io%nz_a+1:kep_io%nz_a+kep_io%nz_b)=-si_1%shift(i)*b
        m_2%job=4
        CALL dmumps(m_2)
        IF(m_2%infog(1).NE.0) THEN
            kep_io%info=14
            CALL kep_info(kep_io%info)
            RETURN
        END IF
        si_1%inertia(i)=m_2%infog(12)
        CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
        cmpt_time(4)=cmpt_time(4)+REAL(clock_2-clock_1)/REAL(clock_rate)
!
        icnt(1)=i
        IF(i.NE.1) THEN
            IF((si_1%inertia(i-1).GE.kep_io%k).AND.&
                & (si_1%inertia(i).LT.kep_io%k)) THEN
                EXIT
            ELSE IF((si_1%inertia(i-1).LT.kep_io%k).AND.&
                & (si_1%inertia(i).GE.kep_io%k)) THEN
                EXIT
            ELSE IF(i.EQ.imax_lanc) THEN
!               Failed to find an initial interval
                kep_io%info=1
                DEALLOCATE(alpha,theta,beta,v,bv)
                DEALLOCATE(m_1%irn,m_1%jcn,m_1%a,m_1%rhs)
                DEALLOCATE(m_ord)
                DEALLOCATE(m_2%irn,m_2%jcn,m_2%a,m_2%perm_in)
                m_1%job=-2
                m_2%job=-2
                CALL dmumps(m_1)
                CALL dmumps(m_2)
                CALL mpi_finalize(ierr)
                CALL kep_info(kep_io%info)
                IF(kep_io%iprm(21).GT.0) CALL kep_summary(mmax,icnt,cmpt_time,&
                &   si_1,si_2_l,si_2_r,si_3,egnval,resnorm,difnorm,kep_io%info)
                DEALLOCATE(si_1%shift,si_1%inertia,                         &
                &   si_2_l%shift,si_2_l%inertia,si_2_r%shift,si_2_r%inertia,&
                &   si_3%shift,si_3%inertia,egnval,resnorm,difnorm,egnvec,egnvec_old)
                RETURN
            END IF
        END IF
    END DO
!
!   End of Lanczos method===============================================
!
    DEALLOCATE(alpha,theta,beta,v,bv)
    DEALLOCATE(m_1%irn,m_1%jcn,m_1%a,m_1%rhs)
    m_1%job=-2
    CALL dmumps(m_1)
!
!---Step 2 : narrow down the interval-----------------------------------
!
!   Initialize
    si_2_l%shift(0)=MIN(si_1%shift(icnt(1)-1),si_1%shift(icnt(1)))
    si_2_r%shift(0)=MAX(si_1%shift(icnt(1)-1),si_1%shift(icnt(1)))
    si_2_l%inertia(0)=MIN(si_1%inertia(icnt(1)-1),si_1%inertia(icnt(1)))
    si_2_r%inertia(0)=MAX(si_1%inertia(icnt(1)-1),si_1%inertia(icnt(1)))
!
!   Bisection===========================================================
!
    DO i=1,imax_bi+1
 !
        icnt(2)=i-1
        icnt(3)=si_2_r%inertia(i-1)-si_2_l%inertia(i-1)
        IF(icnt(3).LE.mmax) THEN
            EXIT
        ELSE IF(i-1.EQ.imax_bi) THEN
!           Failed to narrow down an interval
            kep_io%info=2
            DEALLOCATE(m_ord)
            DEALLOCATE(m_2%irn,m_2%jcn,m_2%a,m_2%perm_in)
            m_2%job=-2
            CALL dmumps(m_2)
            CALL mpi_finalize(ierr)
            CALL kep_info(kep_io%info)
            IF(kep_io%iprm(21).GT.0) CALL kep_summary(mmax,icnt,cmpt_time,&
            &   si_1,si_2_l,si_2_r,si_3,egnval,resnorm,difnorm,kep_io%info)
            DEALLOCATE(si_1%shift,si_1%inertia,                         &
            &   si_2_l%shift,si_2_l%inertia,si_2_r%shift,si_2_r%inertia,&
            &   si_3%shift,si_3%inertia,egnval,resnorm,difnorm,egnvec,egnvec_old)
            RETURN
        END IF
!
!       Task (v) : bisection and inertia computation
        CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
        dtmp=(si_2_l%shift(i-1)+si_2_r%shift(i-1))*0.5D0
        m_2%a(1:kep_io%nz_a)=a
        m_2%a(kep_io%nz_a+1:kep_io%nz_a+kep_io%nz_b)=-dtmp*b
        m_2%job=4
        CALL dmumps(m_2)
        IF(m_2%infog(1).NE.0) THEN
            kep_io%info=15
            CALL kep_info(kep_io%info)
            RETURN
        END IF
!
        si_2_l%shift(i) = si_2_l%shift(i-1)
        si_2_r%shift(i) = si_2_r%shift(i-1)
        si_2_l%inertia(i) = si_2_l%inertia(i-1)
        si_2_r%inertia(i) = si_2_r%inertia(i-1)
!
        IF(m_2%infog(12).GE.kep_io%k) THEN
            si_2_r%shift(i)=dtmp
            si_2_r%inertia(i)=m_2%infog(12)
        ELSE
            si_2_l%shift(i)=dtmp
            si_2_l%inertia(i)=m_2%infog(12)
        END IF
        CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
        cmpt_time(5)=cmpt_time(5)+REAL(clock_2-clock_1)/REAL(clock_rate)
    END DO
!
!   End of bisection====================================================
!
    DEALLOCATE(m_2%irn,m_2%jcn,m_2%a,m_2%perm_in)
    m_2%job=-2
    CALL dmumps(m_2)
!
!---Step 3 : compute eigenpairs of the interval-------------------------
!
!   Initialize
    lngth=(si_2_r%shift(icnt(2))-si_2_l%shift(icnt(2)))*0.5D0
    egnvec_old=0.0D0
!
!   MUMPS
    INCLUDE 'm_3'
!
!   Reuse fill-reducing ordering
    m_3%perm_in=m_ord
    DEALLOCATE(m_ord)
!
!   Task (vi) : numerical factorization of A-sigma*B
    CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
    dtmp=(si_2_l%shift(icnt(2))+si_2_r%shift(icnt(2)))*0.5D0
    m_3%a(1:kep_io%nz_a)=a
    m_3%a(kep_io%nz_a+1:kep_io%nz_a+kep_io%nz_b)=-dtmp*b
    m_3%JOB=4
    CALL dmumps(m_3)
    IF(m_3%infog(1).NE.0) THEN
        kep_io%info=16
        CALL kep_info(kep_io%info)
        RETURN
    END IF
    si_3%shift(1)=dtmp
    si_3%inertia(1)=m_3%infog(12)
    CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
    cmpt_time(6)=REAL(clock_2-clock_1)/REAL(clock_rate)
!
!   Task (vii) : shift-and-invert Lanczos with reverse communication====
!
    ALLOCATE(alpha_si(imax_si),theta_si(imax_si),beta_si(0:imax_si),&
    &   v_si(kep_io%n,imax_si+1),bv_si(kep_io%n,0:imax_si+1),y(imax_si,imax_si))
!
!   Initialize shift-and-invert Lanczos
    CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
    CALL kep_silanczos(kep_io%n,imax_si,its_si,ijob_si,&
    &   v_si,bv_si,alpha_si,beta_si,theta_si,y,icnt(3))
    CALL kep_matvec(kep_io%n,kep_io%nz_b,row_pntr_b,col_indx_b,b,&
        &           bv_si(:,1),v_si(:,1))
    CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
    cmpt_time(7)=cmpt_time(7)+REAL(clock_2-clock_1)/REAL(clock_rate)
!
    DO i=1,imax_si
!       Expand subspace and solve tridiagonal eigenproblem
        CALL SYSTEM_CLOCK(clock_1,clock_rate,clock_max)
        CALL kep_silanczos(kep_io%n,imax_si,its_si,ijob_si,&
        &   v_si,bv_si,alpha_si,beta_si,theta_si,y,icnt(3))
        m_3%rhs=v_si(:,its_si)
        m_3%job=3
        CALL dmumps(m_3)
        IF(m_3%infog(1).NE.0) THEN
            kep_io%info=17
            CALL kep_info(kep_io%info)
            RETURN
        END IF
        bv_si(:,its_si+1)=m_3%rhs
        CALL kep_silanczos(kep_io%n,imax_si,its_si,ijob_si,&
        &   v_si,bv_si,alpha_si,beta_si,theta_si,y,icnt(3))
        CALL kep_matvec(kep_io%n,kep_io%nz_b,row_pntr_b,col_indx_b,b,&
        &   bv_si(:,its_si+1),v_si(:,its_si+1))
        CALL kep_silanczos(kep_io%n,imax_si,its_si,ijob_si,&
        &   v_si,bv_si,alpha_si,beta_si,theta_si,y,icnt(3))
!
!       Convergence test with reverse communication
        CALL kep_convtest(kep_io%n,imax_si,mmax,tol_res,tol_dif,i,j,&
        &   ijob_test,v_si,bv_si,beta_si,theta_si,&
        &   y,icnt(3),lngth,si_3%shift(1),&
        &   egnval,egnvec,egnvec_old,resnorm,difnorm,info_test)
        DO j=1,icnt(3)
            IF(info_test.EQ.0) THEN
                CALL kep_convtest(kep_io%n,imax_si,mmax,tol_res,tol_dif,i,j,&
                &   ijob_test,v_si,bv_si,beta_si,theta_si,&
                &   y,icnt(3),lngth,si_3%shift(1),&
                &   egnval,egnvec,egnvec_old,resnorm,difnorm,info_test)
                CALL kep_matvec(kep_io%n,kep_io%nz_a,row_pntr_a,col_indx_a,a,&
                &   egnvec(:,j),egnvec(:,mmax+1))
                CALL kep_matvec(kep_io%n,kep_io%nz_b,row_pntr_b,col_indx_b,b,&
                &   egnvec(:,j),egnvec(:,mmax+2))
                CALL kep_convtest(kep_io%n,imax_si,mmax,tol_res,tol_dif,i,j,&
                &   ijob_test,v_si,bv_si,beta_si,theta_si,&
                &   y,icnt(3),lngth,si_3%shift(1),&
                &   egnval,egnvec,egnvec_old,resnorm,difnorm,info_test)
            END IF
        END DO
        IF(info_test.EQ.0) THEN
            ijob_test=4
            CALL kep_convtest(kep_io%n,imax_si,mmax,tol_res,tol_dif,i,j,&
            &   ijob_test,v_si,bv_si,beta_si,theta_si,&
            &   y,icnt(3),lngth,si_3%shift(1),&
            &   egnval,egnvec,egnvec_old,resnorm,difnorm,info_test)
        END IF
        CALL SYSTEM_CLOCK(clock_2,clock_rate,clock_max)
        cmpt_time(7)=cmpt_time(7)+REAL(clock_2-clock_1)/REAL(clock_rate)
!
        icnt(4)=i
        IF(info_test.EQ.0) THEN
            EXIT
        ELSE IF(i.EQ.imax_si) THEN
!           Failed to be converged
            kep_io%info=3
            DEALLOCATE(alpha_si,theta_si,beta_si,v_si,bv_si,y)
            DEALLOCATE(m_3%irn,m_3%jcn,m_3%a,m_3%perm_in,m_3%rhs)
            m_3%job=-2
            CALL dmumps(m_3)
            CALL mpi_finalize(ierr)
            CALL kep_info(kep_io%info)
            IF(kep_io%iprm(21).GT.0) CALL kep_summary(mmax,icnt,cmpt_time,&
            &   si_1,si_2_l,si_2_r,si_3,egnval,resnorm,difnorm,kep_io%info)
            DEALLOCATE(si_1%shift,si_1%inertia,                         &
            &   si_2_l%shift,si_2_l%inertia,si_2_r%shift,si_2_r%inertia,&
            &   si_3%shift,si_3%inertia,egnval,resnorm,difnorm,egnvec,egnvec_old)
            RETURN
        ELSE IF(info_test.GE.3) THEN
            egnvec_old(:,1:icnt(3))=egnvec(:,1:icnt(3))
        END IF
        info_test=0
        ijob_test=1
    END DO
!
    IF(ALLOCATED(kep_io%kndx).AND.ALLOCATED(kep_io%kval).AND.&
        & ALLOCATED(kep_io%kvec)) THEN
        DEALLOCATE(kep_io%kndx,kep_io%kval,kep_io%kvec)
    END IF
!
    IF(kep_io%iprm(22).LE.0) THEN
        ALLOCATE(kep_io%kndx(1),kep_io%kval(1),kep_io%kvec(kep_io%n,1))
        kep_io%kndx=kep_io%k
        kep_io%kval=egnval(kep_io%k-si_2_l%inertia(icnt(2)))
        kep_io%kvec(:,1)=egnvec(:,kep_io%k-si_2_l%inertia(icnt(2)))
    ELSE
        ALLOCATE(kep_io%kndx(icnt(3)),kep_io%kval(icnt(3)),&
            &    kep_io%kvec(kep_io%n,icnt(3)))
        DO i=1,icnt(3)
            kep_io%kndx(i)=si_2_l%inertia(icnt(2))+i
        END DO
        kep_io%kval=egnval(1:icnt(3))
        kep_io%kvec=egnvec(:,1:icnt(3))
    END IF
!
!   End of Shift-and-invert Lanczos method==============================
!
    DEALLOCATE(alpha_si,theta_si,beta_si,v_si,bv_si,y)
    DEALLOCATE(m_3%irn,m_3%jcn,m_3%a,m_3%perm_in,m_3%rhs)
    m_3%job=-2
    CALL dmumps(m_3)
    CALL mpi_finalize(ierr)
!
!---Time and results----------------------------------------------------
!
    IF(kep_io%iprm(21).GT.0) CALL kep_summary(mmax,icnt,cmpt_time,&
        &   si_1,si_2_l,si_2_r,si_3,egnval,resnorm,difnorm,kep_io%info)
    DEALLOCATE(si_1%shift,si_1%inertia,                         &
    &   si_2_l%shift,si_2_l%inertia,si_2_r%shift,si_2_r%inertia,&
    &   si_3%shift,si_3%inertia,egnval,resnorm,difnorm,egnvec,egnvec_old)
!
!-----------------------------------------------------------------------
!
    RETURN
    END SUBROUTINE kep
    END MODULE mod_kep


\ this example is from KsanaVM forth lesson 16, thanks to Sir yap.

\ calculate factorial using recursion
: fac ( n -- fac_n )
  dup 2 < if
    drop 1                \ fac(0) = fac(1) = 1
  else
    dup 1 - recurse *     \ fac(n) = n * fac(n-1)         when we want to call 'fac' here, use 'recurse' instead when 'fac' is still under construction.
  then
;
cr .( fac of 10 is ) 10 fac . cr cr bye


      subroutine irev_eqrpsi(n_a1,n_alpha,n_beta,n_rPHI,n_rPI,nm1_rpsi,n
     &p1_rpsi,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rPI(Nx)
      real*8 nm1_rpsi(Nx)
      real*8 np1_rpsi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_rpsi(i) + np1_rpsi(i)) /
     # ht - 0.1D1 * n_alpha(i) / n_a1(i) * n_rPI(i) - 0.1D1 * n_beta(i)
     #* n_rPHI(i)
      res(i)=qb
      end do
      END


      subroutine SBESPQ(X,V,P,Q)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-05-25 SBESPQ Krogh Minor change for making .f90 version.
C>> 1998-10-29 SBESPQ Krogh  Moved external statement up for mangle.
C>> 1995-11-13 SBESPQ Krogh  Converted SFTRAN to Fortran
C>> 1994-10-19 SBESPQ Krogh  Changes to use M77CON
C>> 1994-04-19 SBESPQ CLL  Edited to make DP & SP files similar.
C>> 1992-03-13 SBESPQ FTK  Removed implicit statements.
C>> 1986-03-18 SBESPQ Lawson  Initial code.
c--S replaces "?": ?BESPQ, ?ERM1, ?ERV1
C
c     This subr evaluates asymptotic series for P and Q.
c     These can be used to compute Bessel functions by the formulas
c
c          J = sqrt(2/(pi*X)) * (P * cos(chi) - Q * sin(chi))
c
c          Y = sqrt(2/(pi*X)) * (P * sin(chi) + Q * cos(chi))
c     where
c          chi = X - (0.5 * V + 0.25) * pi
c
C          Reference: NBS AMS55 Eqs 9,2.9 and 9,2.10
c
c          We assume V is limited to the range [0,2].
c          To compute P with a relative accuracy of at least
c     10**(-s), X must be restricted to be not less than XPQ,
c     where XPQ = 1.1293 * s - 0.59
c     (This formula for XPQ was determined for s in the range from
c     5 to 25, and limiting V to [0,2].)
c          Let s0 = -log10( machine_eps )
c     and let s1 = s0 + .3,  s2 = s0 + .6
c     We will set XPQ using s2, and then sum the series till a
c     term less than 10**(-s1) is reached.
c     By setting XPQ using s2 we provide some tolerance to assure
c     that the series will contain a term less than 10**(-s1).
c        We add the constant term of each series in last to
c     reduce the amount of accumulated rounding error.
c
c     1984 Apr 2, JPL, C. L. Lawson and S. Chan.
c     ------------------------------------------------------------------
c
c     >     Let the terms of these two series be numbered
c     1, 3, 5,... in the P series, and 2, 4, 6,... in the Q series.
c     For X >> V these terms decrease in magnitude in the order 1, 2,
c     3, 4,... to some smallest term, say number N, and then
c     following terms increase in magnitude.
c     >     For V = 2 and for given X, let N be the number of the
c     smallest term, and let SIZE be the magitude of this
c     smallest term.  Here are some values of X, N, and -LOG10(SIZE):
c
c               X = 5    10     15     20     25     30     35
c               N =12    22     32     42     52     62     72
c     -LOG10(SIZE)= 4.79  9.35  13.81  18.23  22.63  27.02  31.40
c     ------------------------------------------------------------------
      external         R1MACH, SERM1, SERV1
      real             R1MACH
      real             A0,A1,A2,B,C11293,C59,C9,CP3,EIGHT,EMU
      real             FOUR,HALF,ONE,P,PSUM,Q,Q1,QSUM,SIG,SMALL,TERM
      real             TWO,V,X,X8,XPQ,ZERO
      parameter ( ZERO = 0.E0)
      save XPQ, SMALL
c     ----------
C
      data ONE,TWO,FOUR,EIGHT,C9 / 1.E0,2.E0,4.E0,8.E0,9.E0 /
      data XPQ, C11293, CP3, C59 / ZERO, 1.1293E0, 0.30103E0, 0.59E0/
      data HALF / 0.5E0 /
c     ------------------------------------------------------------------
C
      if ( XPQ .EQ. ZERO ) then
         SMALL = HALF * R1MACH(3)
         XPQ = C11293 * (CP3 - log10(SMALL)) - C59
      end if
c     ------------------------------------------------------------------
      if ( X .lt. XPQ  .or.  V .lt. ZERO  .or.  V .gt. TWO) then
         call SERM1('SBESPQ',1,0,
     * 'Require X .ge. XPQ and V in [0.,2.].',
     * 'X', X, ',')
         call SERV1( 'V', V, ',')
         call SERV1( 'XPQ', XPQ, '.')
         P = ZERO
         Q = ZERO
         return
      end if
c     ------------------------------------------------------------------
      EMU = FOUR * (V*V)
      X8 = EIGHT * X
      A0 = C9
      A1 = EIGHT
      A2 = EIGHT
      B = TWO
      SIG = -ONE
      PSUM = ZERO
      TERM = (EMU - ONE) / X8
      Q1 = TERM
      QSUM = ZERO
C
   20 continue
        TERM = TERM * (EMU-A0) / (B*X8)
        if ( ABS(TERM) .LE. SMALL ) go to 40
        PSUM = PSUM + SIG*TERM
        A1 = A1 + A2
        A0 = A0 + A1
        B = B + 1
c
        TERM = TERM * (EMU-A0) / (B*X8)
        if ( ABS(TERM) .LE. SMALL ) go to 40
        QSUM = QSUM + SIG*TERM
        A1 = A1 + A2
        A0 = A0 + A1
        B = B + 1
c
        SIG = -SIG
        go to 20
C
   40 continue
      P = HALF + ( HALF + PSUM )
      Q = Q1  + QSUM
      return
      end