      SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR,
     $                   A, LDA, B, LDB, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute either the upper or lower triangular part of one of the
C     matrix formulas
C        _
C        R = alpha*R + beta*op( A )*B,                               (1)
C        _
C        R = alpha*R + beta*B*op( A ),                               (2)
C                                             _
C     where alpha and beta are scalars, R and R are m-by-m matrices,
C     op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m
C     and m-by-n matrices for (2), respectively, and op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A',  the transpose of A.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the matrix A appears on the left or
C             right in the matrix product as follows:
C                     _
C             = 'L':  R = alpha*R + beta*op( A )*B;
C                     _
C             = 'R':  R = alpha*R + beta*B*op( A ).
C
C     UPLO    CHARACTER*1                               _
C             Specifies which triangles of the matrices R and R are
C             computed and given, respectively, as follows:
C             = 'U':  the upper triangular part;
C             = 'L':  the lower triangular part.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER           _
C             The order of the matrices R and R, the number of rows of
C             the matrix op( A ) and the number of columns of the
C             matrix B, for SIDE = 'L', or the number of rows of the
C             matrix B and the number of columns of the matrix op( A ),
C             for SIDE = 'R'.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows of the matrix B and the number of
C             columns of the matrix op( A ), for SIDE = 'L', or the
C             number of rows of the matrix op( A ) and the number of
C             columns of the matrix B, for SIDE = 'R'.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then A and B are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry with UPLO = 'U', the leading M-by-M upper
C             triangular part of this array must contain the upper
C             triangular part of the matrix R; the strictly lower
C             triangular part of the array is not referenced.
C             On entry with UPLO = 'L', the leading M-by-M lower
C             triangular part of this array must contain the lower
C             triangular part of the matrix R; the strictly upper
C             triangular part of the array is not referenced.
C             On exit, the leading M-by-M upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L') of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k), where
C             k = N  when  SIDE = 'L', and TRANS = 'N', or
C                          SIDE = 'R', and TRANS = 'T';
C             k = M  when  SIDE = 'R', and TRANS = 'N', or
C                          SIDE = 'L', and TRANS = 'T'.
C             On entry, if SIDE = 'L', and TRANS = 'N', or
C                          SIDE = 'R', and TRANS = 'T',
C             the leading M-by-N part of this array must contain the
C             matrix A.
C             On entry, if SIDE = 'R', and TRANS = 'N', or
C                          SIDE = 'L', and TRANS = 'T',
C             the leading N-by-M part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,l), where
C             l = M  when  SIDE = 'L', and TRANS = 'N', or
C                          SIDE = 'R', and TRANS = 'T';
C             l = N  when  SIDE = 'R', and TRANS = 'N', or
C                          SIDE = 'L', and TRANS = 'T'.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,p), where
C             p = M  when  SIDE = 'L';
C             p = N  when  SIDE = 'R'.
C             On entry, the leading N-by-M part, if SIDE = 'L', or
C             M-by-N part, if SIDE = 'R', of this array must contain the
C             matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N), if SIDE = 'L';
C             LDB >= MAX(1,M), if SIDE = 'R'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is evaluated taking the triangular
C     structure into account. BLAS 2 operations are used. A block
C     algorithm can be easily constructed; it can use BLAS 3 GEMM
C     operations for most computations, and calls of this BLAS 2
C     algorithm for computing the triangles.
C
C     FURTHER COMMENTS
C
C     The main application of this routine is when the result should
C     be a symmetric matrix, e.g., when B = X*op( A )', for (1), or
C     B = op( A )'*X, for (2), where B is already available and X = X'.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS, UPLO
      INTEGER           INFO, LDA, LDB, LDR, M, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS, LUPLO
      INTEGER           J
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMV, DLASCL, DLASET, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -2
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDA.LT.1 .OR.
     $   ( ( (      LSIDE .AND. .NOT.LTRANS ) .OR.
     $       ( .NOT.LSIDE .AND.      LTRANS ) ) .AND. LDA.LT.M ) .OR.
     $   ( ( (      LSIDE .AND.      LTRANS ) .OR.
     $       ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.1 .OR.
     $       (      LSIDE .AND. LDB.LT.N ) .OR.
     $       ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN
         INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01RX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0 or N = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute the required triangle of (1) or (2) using BLAS 2
C     operations.
C
      IF( LSIDE ) THEN
         IF( LUPLO ) THEN
            IF ( LTRANS ) THEN
               DO 10 J = 1, M
                  CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1,
     $                        ALPHA, R(1,J), 1 )
   10          CONTINUE
            ELSE
               DO 20 J = 1, M
                  CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1,
     $                        ALPHA, R(1,J), 1 )
   20          CONTINUE
            END IF
         ELSE
            IF ( LTRANS ) THEN
               DO 30 J = 1, M
                  CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA,
     $                        B(1,J), 1, ALPHA, R(J,J), 1 )
   30          CONTINUE
            ELSE
               DO 40 J = 1, M
                  CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA,
     $                        B(1,J), 1, ALPHA, R(J,J), 1 )
   40          CONTINUE
            END IF
         END IF
C
      ELSE
         IF( LUPLO ) THEN
            IF( LTRANS ) THEN
               DO 50 J = 1, M
                  CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1),
     $                        LDA, ALPHA, R(1,J), 1 )
   50          CONTINUE
            ELSE
               DO 60 J = 1, M
                  CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J),
     $                        1, ALPHA, R(1,J), 1 )
   60          CONTINUE
            END IF
         ELSE
            IF( LTRANS ) THEN
               DO 70 J = 1, M
                  CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1),
     $                        LDB, A(J,1), LDA, ALPHA, R(J,J), 1 )
   70           CONTINUE
            ELSE
               DO 80 J = 1, M
                  CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1),
     $                        LDB, A(1,J), 1, ALPHA, R(J,J), 1 )
   80          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MB01RX ***
      END


program DFP
	real*8 x(2),t,g(2),A(2,2),f,p(2),b(2),ans,aro(2),s(2),y(2),H(2,2),Hf(2,2)
	data x /8,9/
	data A /8,0,0,2/
	data b /40,12/
	data H /1,0,0,1/
	open(13,file="5.6.data")
	write(13,"(5A13)")"f","x1","x2","g1","g2"
	do
	g=matmul(A,x)-b
	f=4.0*(x(1)-5)**2+(x(2)-6)**2
	write(13,"(5f13.6)")f,x,g
	call onedimenmul(g,g,2,ans)
	if(ans<0.01) exit
	p=matmul(-H,g)
	call onedimenmul(p,g,2,t)
	aro=matmul(a,p)
	call onedimenmul(p,aro,2,ans)
	t=t/ans
	y=matmul(a,x-t*p)-matmul(a,x)
	s=t*p
	x=x-t*p
	do i=1,2
	do j=1,2
	hf(i,j)=s(i)*s(j)
	end do
	end do
	call onedimenmul(s,y,2,ans)
	h=h+(1/ans)*hf
	aro=matmul(h,y)
	do i=1,2
	do j=1,2
	hf(i,j)=aro(i)*aro(j)
	end do
	end do
	call onedimenmul(y,aro,2,ans)
	h=h-(1/ans)*hf

	end do
	close(13)

end program DFP

	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
		ans=m1(i)*m2(i)+ans
	end do
	end subroutine onedimenmul


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine dt_evolve(it) ! Now coding
  use global_variables
  implicit none
  integer,intent(in) :: it
  integer :: ik,ikr,ikz
  complex(8) :: zHmat(3,3),zEig(3,3)
  complex(8) :: zc1,zc2,zc3
  real(8) :: eps_t(3),de12
  real(8) :: Act_old,Act_new,Et_old,Et_new

  Act_old = Act(it); Act_new = Act(it+1)
  Et_old = -0.5d0*(Act(it+1)-Act(it-1))/dt
  Et_new = -0.5d0*(Act(it+1+1)-Act(it+1-1))/dt

  do ik = NKrz_s,NKrz_e
    ikr = ikr_table(ik); ikz = ikz_table(ik)

!== Enforced time-reversal symmetry scheme

!== First half dt
    kz(ikz) = kz0(ikz) + Act_old
    eps_t(1) = eps_d
    eps_t(2) = eps_c1 +0.5d0/mass_c1*(kr(ikr)**2+kz(ikz)**2)
    eps_t(3) = eps_c2 +0.5d0/mass_c2*(kr(ikr)**2+kz(ikz)**2)

    zHmat(1,1) = eps_t(1); zHmat(2,2) = eps_t(2); zHmat(3,3) = eps_t(3)
    zHmat(1,2) = -zI*piz_dc1*Et_old/(eps_t(1)-eps_t(2)); zHmat(2,1)=conjg(zHmat(1,2))
    zHmat(1,3) = -zI*piz_dc2*Et_old/(eps_t(1)-eps_t(3)); zHmat(3,1)=conjg(zHmat(1,3))
    zHmat(2,3) = -zI*piz_dcc*Et_old/(eps_t(2)-eps_t(3)); zHmat(3,2)=conjg(zHmat(2,3))

!    call diag3x3(zHmat,zEig,eps_t)
    call zheevh3(zHmat,zEig,eps_t)

! state 1
    zc1=sum(conjg(zEig(:,1))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(1))
    zc2=sum(conjg(zEig(:,2))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(2))
    zc3=sum(conjg(zEig(:,3))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(3))
    zCt(:,1,ik)=zc1*zEig(:,1)+zc2*zEig(:,2)+zc3*zEig(:,3)

!== Second half dt
    kz(ikz) = kz0(ikz) + Act_new
    eps_t(1) = eps_d
    eps_t(2) = eps_c1 +0.5d0/mass_c1*(kr(ikr)**2+kz(ikz)**2)
    eps_t(3) = eps_c2 +0.5d0/mass_c2*(kr(ikr)**2+kz(ikz)**2)

    zHmat(1,1) = eps_t(1); zHmat(2,2) = eps_t(2); zHmat(3,3) = eps_t(3)
    zHmat(1,2) = -zI*piz_dc1*Et_old/(eps_t(1)-eps_t(2)); zHmat(2,1)=conjg(zHmat(1,2))
    zHmat(1,3) = -zI*piz_dc2*Et_old/(eps_t(1)-eps_t(3)); zHmat(3,1)=conjg(zHmat(1,3))
    zHmat(2,3) = -zI*piz_dcc*Et_old/(eps_t(2)-eps_t(3)); zHmat(3,2)=conjg(zHmat(2,3))

!    call diag3x3(zHmat,zEig,eps_t)
    call zheevh3(zHmat,zEig,eps_t)

! state 1
    zc1=sum(conjg(zEig(:,1))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(1))
    zc2=sum(conjg(zEig(:,2))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(2))
    zc3=sum(conjg(zEig(:,3))*zCt(:,1,ik))*exp(-0.5d0*zI*dt*eps_t(3))
    zCt(:,1,ik)=zc1*zEig(:,1)+zc2*zEig(:,2)+zc3*zEig(:,3)

  end do

  return
end subroutine dt_evolve


      double complex function qlLi2omx2(v,w,x,y)
      implicit none
      include 'qlconstants.f'
c     expression for dilog(1-(v-i*ep)*(w-i*ep)/(x-i*ep)/(y-i*ep))
C     for real v,w,x and y
      double precision v,w,x,y,omarg,arg,ddilog
      double complex qllnrat,lnarg,lnomarg,prod
      arg=(v*w)/(x*y)
      omarg=1d0-arg
      if (arg .le. 1d0) then
         if (arg .eq. 0d0 .or. arg .eq. 1d0) then
            prod=0d0
         else
            lnarg=qllnrat(v,x)+qllnrat(w,y)
            lnomarg=dcmplx(log(omarg))
            prod=lnarg*lnomarg
         endif
         qlLi2omx2=dcmplx(pisqo6-ddilog(arg))-prod
      elseif (arg .gt. 1d0) then
         arg=(x*y)/(v*w)
         lnarg=-qllnrat(v,x)-qllnrat(w,y)
         lnomarg=dcmplx(log(1d0-arg))
         qlLi2omx2=-dcmplx(pisqo6-ddilog(arg))+lnarg*lnomarg
     .   -0.5d0*lnarg**2
      endif
      return
      end


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: Kbar = 10d0
    real*8, parameter :: Lbar = 20d0
    real*8, parameter :: alpha = 0.3d0
    real*8, parameter :: beta(2) = (/ 0.3d0, 0.6d0/)

contains

    ! function to determine command optimum
    function utility(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: utility

        ! utility function
        utility = -((x(2)**beta(1)*x(1)**(1d0-beta(1)))**alpha* &
            ((Lbar-x(2))**beta(2)*(Kbar-x(1))**(1d0-beta(2)))**(1-alpha))

    end function

end module


      FUNCTION BETAI(A,B,X)
      IF(X.LT.0..OR.X.GT.1.)PAUSE 'bad argument X in BETAI'
      IF(X.EQ.0..OR.X.EQ.1.)THEN
        BT=0.
      ELSE
        BT=EXP(GAMMLN(A+B)-GAMMLN(A)-GAMMLN(B)
     *      +A*ALOG(X)+B*ALOG(1.-X))
      ENDIF
      IF(X.LT.(A+1.)/(A+B+2.))THEN
        BETAI=BT*BETACF(A,B,X)/A
        RETURN
      ELSE
        BETAI=1.-BT*BETACF(B,A,1.-X)/B
        RETURN
      ENDIF
      END


!---------------------------------------------------------------------------------------------
! Purpose : Jacobi/DIIS solver
!
! variables:
!
!   n        : integer, input, size of the matrix
!
!   lprint   : integer, input, printing flag.
!
!   diis_max : integer, input, number of points to be used for diis extrapolation
!
!              if diis_max = 0, this is just a Jacobi solver.
!
!   norm     : integer, input, norm to be used to evaluate convergence
!              1: max |x_new - x|
!              2: rms (x_new - x)
!              3: rms (x_new - x) and max |x_new - x|
!              4: norm computed by the user-provided function u_norm(n,x)
!
!   tol      : real, input, convergence criterion. if norm = 3, convergence is
!              achieved when rms (x_new - x) < tol and max |x_new - x| < 10*tol.
!
!   rhs      : real, dimension(n), input, right-hand side of the linear system
!
!   x        : real, dimension(n). In input, a guess of the solution (can be zero).
!              In output, the solution
!
!   n_iter   : integer, in input, the maximum number of iterations. In output,
!              the number of iterations needed to converge.
!
!   ok       : logical, output, T if the solver converged, false otherwise.
!
!   matvec   : external, subroutine to compute the required matrix-vector multiplication
!              format: subroutine matvec(n,x,y)
!
!   dm1vec   : external, subroutine to apply the inverse diagonal matrix to a vector.
!              format: subroutine dm1vec(n,x,y)
!
!   u_norm   : external, optional function to compute the norm of a vector.
!              format: real*8 function u_norm(n,x)
!
!---------------------------------------------------------------------------------------------
subroutine jacobi_diis( n, lprint, diis_max, norm, tol, rhs, x, n_iter, ok, matvec, &
                        dm1vec, u_norm)
!
      implicit none
      integer,               intent(in)    :: n, diis_max, norm, lprint
      real*8,                intent(in)    :: tol
      real*8,  dimension(n), intent(in)    :: rhs
      real*8,  dimension(n), intent(inout) :: x
      integer,               intent(inout) :: n_iter
      logical,               intent(inout) :: ok
      external                             :: matvec, dm1vec
      real*8,  optional                    :: u_norm
      external                             :: u_norm
!
      integer :: it, nmat, istatus, lenb
      real*8  :: rms_norm, max_norm, tol_max
      logical :: dodiis
!
      real*8, allocatable :: x_new(:), y(:), x_diis(:,:), e_diis(:,:), bmat(:,:)
!
!---------------------------------------------------------------------------------------------
!
!     check inputs
      if ( (norm.eq.4) .and. (.not.present(u_norm)) ) then
        write(6,*) ' must provide a function norm(n,x) to evaluate the norm of the increment'
        stop
      endif
!
!     DIIS extrapolation flag
      dodiis =  (diis_max.ne.0)
!
!     set tolerance
      tol_max = 10.0d0 * tol
!
!     extrapolation required
      if (dodiis) then
!
!       allocate workspaces
        lenb = diis_max + 1
        allocate( x_diis(n,diis_max), e_diis(n,diis_max), bmat(lenb,lenb) , stat=istatus )
        if (istatus .ne. 0) then
          write(*,*) ' jacobi_diis: [1] failed allocation (diis)'
          stop
        endif
!
!       an enigmatic constant
        nmat = 1
!
      endif
!
!     allocate workspaces
      allocate( x_new(n), y(n) , stat=istatus )
      if (istatus .ne. 0) then
        write(*,*) ' jacobi_diis: [2] failed allocation (scratch)'
        stop
      endif
!
!     Jacobi iterations
!     =================
      do it = 1, n_iter
!
!       y = rhs - O x
        call matvec( n, x, y )
        y = rhs - y
!
!       x_new = D^-1 y
        call dm1vec(n,y,x_new)
!
!       DIIS extrapolation
!       ==================
        if (dodiis) then
!
          x_diis(:,nmat) = x_new
          e_diis(:,nmat) = x_new - x
!
          call diis(n,nmat,diis_max,x_diis,e_diis,bmat,x_new)
!
        endif
!
!       increment
        x = x_new - x
!
!       rms/max norm of increment
        if ( norm.le.3 ) then
!
!         compute norm
          call rmsvec( n, x, rms_norm, max_norm )
!
!         check norm
          if ( norm.eq.1 ) then
!
            ok = (rms_norm.lt.tol)

          elseif ( norm.eq.2 ) then
!
            ok = (max_norm.lt.tol)
!
          else

            ok = (rms_norm.lt.tol) .and. (max_norm.lt.tol_max)
!
          endif
!
!       user-provided norm of increment
        elseif ( norm.eq.4 ) then
!
!         just a placeholder for printing
          max_norm = -1.d0
!
!         compute norm
          rms_norm = u_norm( n, x )
!
!         check norm
          ok = (rms_norm.lt.tol)
!
        endif
!
!       printing
        if ( lprint.gt.0 ) then
           if (norm.eq.1) then
             write(*,110) it, 'max', max_norm
           else if (norm.eq.2) then
             write(*,110) it, 'rms', rms_norm
           else if (norm.eq.3) then
             write(*,100) it, rms_norm, max_norm
           else if (norm.eq.4) then
             write(*,120) it, rms_norm
           end if
         end if
  100   format(t3,'iter=',i4,' residual norm (rms,max): ', 2d14.4 )
  110   format(t3,'iter=',i4,' residual norm (',a,'): ', d14.4 )
  120   format(t3,'iter=',i4,' residual norm: ', d14.4 )
!
!       update
        x = x_new
!
!       EXIT Jacobi loop here
!       =====================
        if (ok) exit
!
      enddo
!
!     record number of Jacobi iterations
      n_iter = it
!
      return
!
!
endsubroutine jacobi_diis
!---------------------------------------------------------------------------------------------
!
!
!
!---------------------------------------------------------------------------------------------
!
subroutine diis(n,nmat,ndiis,x,e,b,xnew)
implicit none
integer,                             intent(in)    :: n, ndiis
integer,                             intent(inout) :: nmat
real*8,  dimension(n,ndiis),         intent(inout) :: x, e
real*8,  dimension(ndiis+1,ndiis+1), intent(inout) :: b
real*8,  dimension(n),               intent(inout) :: xnew
!
integer :: nmat1, i, istatus
integer :: j, k
logical :: ok
!
real*8, allocatable :: bloc(:,:), cex(:)
!
real*8, parameter :: zero = 0.0d0, one = 1.0d0
!
!------------------------------------------------------------------------------
!
if (nmat.ge.ndiis) then
  do j = 2, nmat - 10
    do k = 2, nmat - 10
      b(j,k) = b(j+10,k+10)
    end do
  end do
  do j = 1, nmat - 10
    x(:,j) = x(:,j+10)
    e(:,j) = e(:,j+10)
  end do
  nmat = nmat - 10
end if
nmat1 = nmat + 1
allocate (bloc(nmat1,nmat1),cex(nmat1) , stat=istatus)
if ( istatus.ne.0 ) then
  write(*,*) 'diis: allocation failed!'
  stop
endif

call makeb(n,nmat,ndiis,e,b)
bloc   = b(1:nmat1,1:nmat1)
cex    = zero
cex(1) = one
call gjinv(nmat1,1,bloc,cex,ok)
if (.not. ok) then
  nmat = 1
  return
end if
xnew = zero
do i = 1, nmat
  xnew = xnew + cex(i+1)*x(:,i)
end do
nmat = nmat + 1
deallocate (bloc,cex , stat=istatus)
if ( istatus.ne.0 ) then
  write(*,*) 'diis: deallocation failed!'
  stop
endif
!
return
end subroutine diis
  !
subroutine makeb(n,nmat,ndiis,e,b)
implicit none
integer, intent(in) :: n, nmat, ndiis
real*8, dimension(n,ndiis),         intent(in) :: e
real*8, dimension(ndiis+1,ndiis+1), intent(inout) :: b
!
integer :: i
real*8  :: bij
real*8, parameter :: zero = 0.0d0, one = 1.0d0

! 1st built
if (nmat.eq.1) then
!
!       [ 0 |  1  ]
!   b = [ --+---- ]
!       [ 1 | e*e ]
!
  b(1,1) = zero
  b(1,2) = one
  b(2,1) = one
  b(2,2) = dot_product(e(:,1),e(:,1))
!
! subsequent builts
else
!
!   first, update the lagrangian line:
  b(nmat+1,1) = one
  b(1,nmat+1) = one
!
!   now, compute the new matrix elements:
  do i = 1, nmat - 1
    bij = dot_product(e(:,i),e(:,nmat))
    b(nmat+1,i+1) = bij
    b(i+1,nmat+1) = bij
  end do
  b(nmat+1,nmat+1) = dot_product(e(:,nmat),e(:,nmat))
end if
!
return
end subroutine makeb
!
subroutine gjinv(n,nrhs,a,b,ok)
implicit none
!
integer,                    intent(in)    :: n, nrhs
logical,                    intent(inout) :: ok
real*8,  dimension(n,n),    intent(inout) :: a
real*8,  dimension(n,nrhs), intent(inout) :: b
!
integer :: i, j, k, irow, icol, istatus
real*8  :: big, dum, pinv
real*8, parameter :: zero = 0.0d0, one = 1.0d0
!
integer, allocatable :: indxc(:), indxr(:), piv(:)
real*8,  allocatable :: scr(:)
!
allocate (indxc(n), indxr(n), piv(n) , stat=istatus)
if ( istatus.ne.0 ) then
  write(*,*)'gjinv: allocation failed! [1]'
  stop
endif
allocate (scr(n) , stat=istatus)
if ( istatus.ne.0 ) then
  write(*,*)'gjinv: allocation failed! [2]'
  stop
endif
!
ok  = .false.
piv = 0
!
irow = 0
icol = 0
do i = 1, n
  big = zero
  do j = 1, n
    if (piv(j).ne.1) then
      do k = 1, n
        if (piv(k).eq.0) then
          if (abs(a(j,k)).gt.big) then
            big  = abs(a(j,k))
            irow = j
            icol = k
          end if
        end if
      end do
    end if
  end do
!
  piv(icol) = piv(icol) + 1
  if (piv(icol) .gt. 1) then
    write(*,1000)
    return
  end if
  if (irow.ne.icol) then
    scr         = a(irow,:)
    a(irow,:)   = a(icol,:)
    a(icol,:)   = scr
    scr(1:nrhs) = b(irow,:)
    b(irow,:)   = b(icol,:)
    b(icol,:)   = scr(1:nrhs)
  end if
!
  indxr(i) = irow
  indxc(i) = icol
!
  if (a(icol,icol) .eq. zero) then
    write(*,1000)
    return
  end if
!
  pinv = one/a(icol,icol)
  a(icol,icol) = one
  a(icol,:) = a(icol,:)*pinv
  b(icol,:) = b(icol,:)*pinv
!
  do j = 1, n
    if (j.ne.icol) then
      dum       = a(j,icol)
      a(j,icol) = zero
      a(j,:)    = a(j,:) - a(icol,:)*dum
      b(j,:)    = b(j,:) - b(icol,:)*dum
    end if
  end do
end do
!
do j = n, 1, -1
  if (indxr(j) .ne. indxc(j)) then
    scr           = a(:,indxr(j))
    a(:,indxr(j)) = a(:,indxc(j))
    a(:,indxc(j)) = scr
  end if
end do
!
ok = .true.
deallocate (indxr,indxc,piv,scr , stat=istatus)
if ( istatus.ne.0 ) then
  write(*,*)'gjinv: deallocation failed! [1]'
  stop
endif

return
1000 format (' warning: singular matrix in gjinv!')
end subroutine gjinv
!
!------------------------------------------------------------------------------
! Purpose : compute root-mean-square and max norm
!------------------------------------------------------------------------------
subroutine rmsvec( n, v, vrms, vmax )
!
      implicit none
      integer,               intent(in)    :: n
      real*8,  dimension(n), intent(in)    :: v
      real*8,                intent(inout) :: vrms, vmax
!
      integer :: i
      real*8, parameter :: zero=0.0d0
!
!------------------------------------------------------------------------------
!
!     initialize
      vrms = zero
      vmax = zero
!
!     loop over entries
      do i = 1,n
!
!       max norm
        vmax = max(vmax,abs(v(i)))
!
!       rms norm
        vrms = vrms + v(i)*v(i)
!
      enddo
!
!     the much neglected square root
      vrms = sqrt(vrms/dble(n))
!
      return
!
!
endsubroutine rmsvec
!------------------------------------------------------------------------------


C NCLFORTSTART
      SUBROUTINE DWGTAREARMSE(T,Q,WGTY,WGTX,MX,NY,TMSG,QMSG,IFLAG,RMSE)
      IMPLICIT NONE
      INTEGER MX,NY,IFLAG
      DOUBLE PRECISION T(MX,NY),Q(MX,NY),WGTX(MX),WGTY(NY)
      DOUBLE PRECISION TMSG,QMSG
      DOUBLE PRECISION RMSE
C NCLEND

C NCL: rmseTQ = wgt_AreaRmse (t,q,wgty,wgtx,flag)

      INTEGER NL,ML,KMSG
      DOUBLE PRECISION SUMD,SUMW,WGTXY

C compute the weighted root-mean-square-difference [rmse]

C Nomenclature:
C INPUT:
C t      - 2D array
C q      - 2D array
C wgty   - 1D array of length "ny" [eg: cos(0.01745*lat) or gau_wgt(:)]
C wgtx   - 1D array of length "mx"
C mx     - 1st [faster varying] dimension of "t" [eg, longitude]
C ny     - 2nd [slower varying] dimension of "t" [eg, latitude ]
C tmsg   - msg value
C iflag  - flag
C          =0 compute  rmse ignoring msg values
C          =1 if any msg data is encountered return as msg
c OUTPUT:
C rmse   - root-mean-square-difference [weighted]

      SUMD = 0.0D0
      SUMW = 0.0D0
      KMSG = 0
      RMSE = TMSG

      DO NL = 1,NY
          DO ML = 1,MX
              IF (T(ML,NL).NE.TMSG .AND. Q(ML,NL).NE.QMSG) THEN
                  WGTXY = WGTX(ML)*WGTY(NL)
                  SUMD = SUMD + WGTXY* (T(ML,NL)-Q(ML,NL))**2
                  SUMW = SUMW + WGTXY
              ELSE
                  KMSG = KMSG + 1
              END IF
          END DO
c                                      return if user desired
          IF (IFLAG.EQ.1 .AND. KMSG.NE.0) RETURN
      END DO
c                          compute wgted differense
      IF (SUMW.NE.0.D0) THEN
          RMSE = SQRT(SUMD/SUMW)
      END IF

      RETURN
      END


	FUNCTION PR_WIND  ( drct, sped )
C************************************************************************
C* PR_WIND								*
C*									*
C* This function computes WIND from DRCT and SPED.  WIND is in the	*
C* form SSSDDD, where SSS is the speed and DDD is the direction.	*
C* SPED may be entered in meters/sec or knots; DRCT is in degrees	*
C* The following equation is used:					*
C*									*
C*             WIND = NINT ( SPED ) * 1000 + NINT ( DRCT )		*
C*									*
C* REAL PR_WIND  ( DRCT, SPED )						*
C*									*
C* Input parameters:							*
C*	DRCT		REAL		Wind direction in degrees	*
C*	SPED		REAL		Wind speed 			*
C*									*
C* Output parameters:							*
C*	PR_WIND		REAL		Packed speed and direction	*
C**									*
C* Log:									*
C* M. desJardins/NMC	11/91						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ( .not. ERMISS ( drct ) ) .and.
     +	      ( .not. ERMISS ( sped ) ) )  THEN
	    jdrct   = NINT ( drct )
	    jsped   = NINT ( sped )
	    PR_WIND = jdrct + jsped * 1000
	  ELSE
	    PR_WIND = RMISSD
	END IF
C*
	RETURN
	END


program iprogram
    use utilities
    use percolation
    implicit none

    integer :: num_samples, i, j, spanning_label, num_Ls, num_clusters, fileunit
    logical, dimension(:,:), allocatable :: matrix
    integer, dimension(:,:), allocatable :: label_matrix
    integer, dimension(:), allocatable :: Ls
    real(kind=dp) :: D, const, tmpM
    real(kind=dp), dimension(:), allocatable :: Ms_approx, Ms

    num_samples = 200
    Ls = 2**[(i, i=4, 11)]
    num_Ls = size(Ls)
    allocate(Ms(num_Ls))
    Ms = 0

    do i = 1, num_Ls
        associate(L => Ls(i), M => Ms(i))
            tmpM = 0
            !$omp  parallel do &
            !$omp& private(matrix, label_matrix, num_clusters, spanning_label) &
            !$omp& reduction(+:tmpM)
            do j = 1, num_samples
                matrix = create_binary_matrix(pc, L)
                call label(matrix, label_matrix, num_clusters)
                spanning_label = find_spanning_cluster(label_matrix, num_clusters)
                tmpM = tmpM + count(label_matrix == spanning_label)
            end do
            !$omp end parallel do
            M = tmpM
        end associate
    end do

    Ms = Ms/num_samples

    call linfit(log(1.0d0*Ls), log(Ms), D, const)
    Ms_approx = exp(const) * Ls**D

    open(newunit=fileunit, file="tmp/i.dat", status="replace")
    do i = 1, num_Ls
        write(unit=fileunit, fmt=*) Ls(i), Ms(i), Ms_approx(i)
    end do
    close(unit=fileunit)

    open(newunit=fileunit, file="tmp/i_D.dat", status="replace")
    write(unit=fileunit, fmt="(f0.3)") D
    close(unit=fileunit)

end program iprogram


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program gcp_from_points_prog
!===============================================================================
! Wrapper program for sg_gcp_from_s.  Given a point on a sphere and an
! azimuth through that point, return the pole to the great circle along that
! azimuth.  Reads lon, lat and azi from stdin, all in degrees

   use spherical_geometry, only: sg_gcp_from_points

   implicit none

   real(8) :: lon1,lat1,lon2,lat2,long,latg
   integer :: iostat

   if (command_argument_count() /= 0) call usage

   iostat = 0
   do while (iostat == 0)
      read(*,*,iostat=iostat) lon1,lat1,lon2,lat2
      if (iostat > 0) then
         write(0,'(a)') 'gcp_from_points: Error: problem reading lon1,lat1,lon2,lat2 (degrees) from stdin'
         stop
      endif
      if (iostat < 0) exit
      call sg_gcp_from_points(lon1,lat1,lon2,lat2,long,latg,degrees=.true.)
      write(*,'(f11.6,1x,f10.6)') long,latg
   enddo

contains
   !============================================================================
   subroutine usage()
   !============================================================================
      implicit none
      write(*,'(a)') 'Usage: gcp_from_points < [lon1] [lat1] [lon2] [lat2]',&
                     '   Reads two point on sphere from stdin (degrees)',&
                     '   Writes lon and lat of pole to great circle defined by the input to stdout.'
      stop
   end subroutine usage
   !----------------------------------------------------------------------------

end program gcp_from_points_prog
!-------------------------------------------------------------------------------


program auto_allocate
!! demonstrate Fortran 2003 automatic allocation of arrays
!!
!! NOTE: if an array is manually allocated, Fortran 2003 allows auto-reallocation bigger or smaller

implicit none (type, external)

real, allocatable, dimension(:) :: A, B, C, D, E
real :: C3(3)

!> Initial auto-allocate
A = [1,2,3]
B = [4,5,6]

C3 = A + B
C = A + B
if (any(C3 /= C)) error stop 'initial auto-allocate'
if (size(C) /= 3) error stop 'initial auto-alloc size'

!> allocate bigger
A = [1,2,3,4]
B = [5,6,7,8]
C = A + B
if (any(C /= [6,8,10,12])) error stop 'auto-alloc smaller'
if (size(C) /= 4) error stop 'auto-alloc bigger size'

!> allocate smaller
A = [1,2]
B = [3,4]
C = A + B
if (any(C /= [4,6])) error stop 'auto-alloc smaller'
if (size(C) /= 2) error stop 'auto-alloc smaller size'

!> fixed allocate first
allocate(D(3), E(3))
D = [1,2]
E = [3,4,5,7]

if (size(D) /= 2) error stop 'auto-allocate smaller'
if (size(E) /= 4) error stop 'auto-allocate bigger'

print *, 'OK: auto-allocate array'

end program


SUBROUTINE dtoplx (a, b, x, n, g, h, ierr)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-17  Time: 09:28:46

!-----------------------------------------------------------------------
!            SOLUTION OF THE TOEPLITZ SYSTEM OF EQUATIONS

!               SUM(J = 1,...,N) A(N+I-J)*X(J) = B(I)

!     FOR I = 1,...,N.
!-----------------------------------------------------------------------
!     DOUBLE PRECISION A(2*N - 1)
!----------------------

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

REAL (dp), INTENT(IN)   :: a(:)
INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(IN)   :: b(n)
REAL (dp), INTENT(OUT)  :: x(n)
REAL (dp), INTENT(OUT)  :: g(n)
REAL (dp), INTENT(OUT)  :: h(n)
INTEGER, INTENT(OUT)    :: ierr

INTEGER    :: j, k, l, m, MAX, mp1, nml, npl
REAL (dp)  :: c, c1, c2, gd, gj, gk, gn, hj, hk, hn, xd, xn

IF (a(n) == 0.d0) GO TO 100
ierr = 0
x(1) = b(1)/a(n)
IF (n == 1) RETURN
g(1) = a(n - 1)/a(n)
h(1) = a(n + 1)/a(n)
mp1 = 1

!     COMPUTE NUMERATOR AND DENOMINATOR OF X(M+1)

10 m = mp1
mp1 = m + 1
xn = -b(mp1)
xd = -a(n)
DO  j = 1,m
  l = mp1 - j
  npl = n + l
  xn = xn + a(npl)*x(j)
  xd = xd + a(npl)*g(l)
END DO
IF (xd == 0.d0) GO TO 100
x(mp1) = xn/xd

!        COMPUTE X

c = x(mp1)
DO  j = 1,m
  l = mp1 - j
  x(j) = x(j) - c*g(l)
END DO
IF (mp1 == n) RETURN

!     COMPUTE NUMERATOR AND DENOMINATOR OF G(M+1) AND H(M+1)

l = n - mp1
gn = -a(l)
gd = -a(n)
l = n + mp1
hn = -a(l)
DO  j = 1,m
  l = mp1 - j
  nml = n - l
  npl = n + l
  gn = gn + a(nml)*g(j)
  gd = gd + a(nml)*h(l)
  hn = hn + a(npl)*h(j)
END DO
IF (gd == 0.d0) GO TO 100
g(mp1) = gn/gd
h(mp1) = hn/xd

!     COMPUTE G AND H

c1 = g(mp1)
c2 = h(mp1)
MAX = mp1/2
k = m
DO  j = 1,MAX
  gj = g(j)
  gk = g(k)
  hj = h(j)
  hk = h(k)
  g(j) = gj - c1*hk
  g(k) = gk - c1*hj
  h(j) = hj - c2*gk
  h(k) = hk - c2*gj
  k = k - 1
END DO
GO TO 10

!     ERROR RETURN

100 ierr = 1
RETURN
END SUBROUTINE dtoplx


module precision
  !  This module will assign fdp (floating point double precision)
  !  isp (integer single precision), idp (integer double precision)
  !  csp (complex single precision), cdp (complex double precision)
  !  fqp (floating point quadratic precision)
  implicit none
  integer, parameter :: fqp=selected_real_kind(20,200)
  integer, parameter :: fdp=selected_real_kind(10,200)
  integer, parameter :: fsp=selected_real_kind(5,50)
  integer, parameter :: isp=selected_int_kind(6)
  integer, parameter :: idp=selected_int_kind(9)
  integer, parameter :: cdp=fdp
  integer, parameter :: csp=fsp
end module precision


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine error_norm(rms)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     this function computes the norm of the difference between the
c     computed solution and the exact solution
c---------------------------------------------------------------------

      include 'header.h'

      integer i, j, k, m, d
      double precision xi, eta, zeta, u_exact(5), rms(5), add
      double precision rms_local(5)

      do m = 1, 5
         rms(m) = 0.0d0
      enddo

!$omp parallel default(shared)
!$omp& private(i,j,k,m,zeta,eta,xi,add,u_exact,rms_local)
!$omp&        shared(rms)
      do m = 1, 5
         rms_local(m) = 0.0d0
      enddo
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do j = 0, grid_points(2)-1
            eta = dble(j) * dnym1
            do i = 0, grid_points(1)-1
               xi = dble(i) * dnxm1
               call exact_solution(xi, eta, zeta, u_exact)

               do m = 1, 5
                  add = u(m,i,j,k)-u_exact(m)
                  rms_local(m) = rms_local(m) + add*add
               enddo
            enddo
         enddo
      enddo
!$omp end do nowait
      do m = 1, 5
!$omp critical
         rms(m) = rms(m) + rms_local(m)
!$omp end critical
      enddo
!$omp end parallel

      do m = 1, 5
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine rhs_norm(rms)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      include 'header.h'

      integer i, j, k, d, m
      double precision rms(5), add
      double precision rms_local(5)

      do m = 1, 5
         rms(m) = 0.0d0
      enddo

!$omp parallel default(shared) private(i,j,k,m,add,rms_local)
!$omp&        shared(rms)
      do m = 1, 5
         rms_local(m) = 0.0d0
      enddo
!$omp do
      do k = 1, grid_points(3)-2
         do j = 1, grid_points(2)-2
            do i = 1, grid_points(1)-2
               do m = 1, 5
                  add = rhs(m,i,j,k)
                  rms_local(m) = rms_local(m) + add*add
               enddo
            enddo
         enddo
      enddo
!$omp end do nowait
      do m = 1, 5
!$omp critical
         rms(m) = rms(m) + rms_local(m)
!$omp end critical
      enddo
!$omp end parallel

      do m = 1, 5
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end


!!!!!
! This subroutine performs a calculation of the incomplete Gamma
! function required for calculating the transmission of isotropic
! radiation. For more information on the derivation, see Pinty et al.
! (2006) equations (16) and (17) and surrounding text.
!
!  Pinty, B., Lavergne, T., Dickinson, R.E., Widlowski, J.-L., Gobron,
!  N., Verstraete, M.M., 2006. Simplifying the interaction of land
!  surfaces with radiation for relating remote sensing products to
!  climate models. J. Geophys. Res. 111, D02116.
!  doi:10.1029/2005JD005952
!!!!!

module mod_biggamma
contains
function BigGamma(tau)
    implicit none
    real*8, intent(in) :: tau
    real*8 :: BigGamma

    integer :: order, i

    order = 20
    BigGamma = 0.0d0

    do i=order, 1, -1
        BigGamma = i / (1.0d0 + i / (tau + BigGamma))
    end do

    BigGamma = 1.0d0 / (tau + BigGamma)
end function BigGamma
end module mod_biggamma


      module i1

      implicit none (type, external)
      private
      public:: besi1

      contains

      SUBROUTINE CALCI1(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functioons of the first kind
C   and order one, I1(X) and EXP(-ABS(X))*I1(X), for real
C   arguments X.  It contains two function type subprograms, BESI1
C   and BESEI1, and one subroutine type subprogram, CALCI1.
C   The calling statements for the primary entries are
C
C                   Y=BESI1(X)
C   and
C                   Y=BESEI1(X)
C
C   where the entry points correspond to the functions I1(X) and
C   EXP(-ABS(X))*I1(X), respectively.  The routine CALCI1 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCI1 with the statement
C          CALL CALCI1(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCI1
C       Call              ARG                  RESULT          JINT
C
C     BESI1(ARG)    ABS(ARG) .LE. XMAX        I1(ARG)           1
C     BESEI1(ARG)    any real ARG        EXP(-ABS(ARG))*I1(ARG) 2
C
C   The main computation evaluates slightly modified forms of
C   minimax approximations generated by Blair and Edwards, Chalk
C   River (Atomic Energy of Canada Limited) Report AECL-4928,
C   October, 1974.  This transportable program is patterned after
C   the machine-dependent FUNPACK packet NATSI1, but cannot match
C   that version for efficiency or accuracy.  This version uses
C   rational functions that theoretically approximate I-SUB-1(X)
C   to at least 18 significant decimal digits.  The accuracy
C   achieved depends on the arithmetic system, the compiler, the
C   intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   beta   = Radix for the floating-point system
C   maxexp = Smallest power of beta that overflows
C   XSMALL = Positive argument such that 1.0 - X = 1.0 to
C            machine precision for all ABS(X) .LE. XSMALL.
C   XINF =   Largest positive machine number; approximately
C            beta**maxexp
C   XMAX =   Largest argument acceptable to BESI1;  Solution to
C            equation:
C               EXP(X) * (1-3/(8*X)) / SQRT(2*PI*X) = beta**maxexp
C
C
C     Approximate values for some important machines are:
C
C                          beta       maxexp       XSMALL
C
C CRAY-1        (S.P.)       2         8191       3.55E-15
C Cyber 180/855
C   under NOS   (S.P.)       2         1070       3.55E-15
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       2          128       2.98E-8
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       2         1024       5.55D-17
C IBM 3033      (D.P.)      16           63       6.95D-18
C VAX           (S.P.)       2          127       2.98E-8
C VAX D-Format  (D.P.)       2          127       6.95D-18
C VAX G-Format  (D.P.)       2         1023       5.55D-17
C
C
C                               XINF          XMAX
C
C CRAY-1        (S.P.)       5.45E+2465     5682.810
C Cyber 180/855
C   under NOS   (S.P.)       1.26E+322       745.894
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       3.40E+38         91.906
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       1.79D+308       713.987
C IBM 3033      (D.P.)       7.23D+75        178.185
C VAX           (S.P.)       1.70D+38         91.209
C VAX D-Format  (D.P.)       1.70D+38         91.209
C VAX G-Format  (D.P.)       8.98D+307       713.293
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ABS(ARG) .GT. XMAX.
C
C
C Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL  60439
C
C  Latest modification: May 31, 1989
C
C--------------------------------------------------------------------
      INTEGER J,JINT
CS    REAL
      DOUBLE PRECISION
     1    A,ARG,B,EXP40,FORTY,HALF,ONE,ONE5,P,PBAR,PP,Q,QQ,REC15,
     2    RESULT,SUMP,SUMQ,TWO25,X,XINF,XMAX,XSMALL,XX,ZERO
      DIMENSION P(15),PP(8),Q(5),QQ(6)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ONE5/15.0E0/,EXP40/2.353852668370199854E17/,
CS   1     FORTY/40.0E0/,REC15/6.6666666666666666666E-2/,
CS   2     TWO25/225.0E0/,HALF/0.5E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ONE5/15.0D0/,EXP40/2.353852668370199854D17/,
CD   1     FORTY/40.0D0/,REC15/6.6666666666666666666D-2/,
CD   2     TWO25/225.0D0/,HALF/0.5D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/2.98E-8/,XINF/3.4E38/,XMAX/91.906E0/
CD    DATA XSMALL/5.55D-17/,XINF/1.79D308/,XMAX/713.987D0/
C--------------------------------------------------------------------
C  Coefficients for XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
CS    DATA P/-1.9705291802535139930E-19,-6.5245515583151902910E-16,
CS   1       -1.1928788903603238754E-12,-1.4831904935994647675E-09,
CS   2       -1.3466829827635152875E-06,-9.1746443287817501309E-04,
CS   3       -4.7207090827310162436E-01,-1.8225946631657315931E+02,
CS   4       -5.1894091982308017540E+04,-1.0588550724769347106E+07,
CS   5       -1.4828267606612366099E+09,-1.3357437682275493024E+11,
CS   6       -6.9876779648010090070E+12,-1.7732037840791591320E+14,
CS   7       -1.4577180278143463643E+15/
CD    DATA P/-1.9705291802535139930D-19,-6.5245515583151902910D-16,
CD   1       -1.1928788903603238754D-12,-1.4831904935994647675D-09,
CD   2       -1.3466829827635152875D-06,-9.1746443287817501309D-04,
CD   3       -4.7207090827310162436D-01,-1.8225946631657315931D+02,
CD   4       -5.1894091982308017540D+04,-1.0588550724769347106D+07,
CD   5       -1.4828267606612366099D+09,-1.3357437682275493024D+11,
CD   6       -6.9876779648010090070D+12,-1.7732037840791591320D+14,
CD   7       -1.4577180278143463643D+15/
CS    DATA Q/-4.0076864679904189921E+03, 7.4810580356655069138E+06,
CS   1       -8.0059518998619764991E+09, 4.8544714258273622913E+12,
CS   2       -1.3218168307321442305E+15/
CD    DATA Q/-4.0076864679904189921D+03, 7.4810580356655069138D+06,
CD   1       -8.0059518998619764991D+09, 4.8544714258273622913D+12,
CD   2       -1.3218168307321442305D+15/
C--------------------------------------------------------------------
C  Coefficients for 15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
CS    DATA PP/-6.0437159056137600000E-02, 4.5748122901933459000E-01,
CS   1        -4.2843766903304806403E-01, 9.7356000150886612134E-02,
CS   2        -3.2457723974465568321E-03,-3.6395264712121795296E-04,
CS   3         1.6258661867440836395E-05,-3.6347578404608223492E-07/
CD    DATA PP/-6.0437159056137600000D-02, 4.5748122901933459000D-01,
CD   1        -4.2843766903304806403D-01, 9.7356000150886612134D-02,
CD   2        -3.2457723974465568321D-03,-3.6395264712121795296D-04,
CD   3         1.6258661867440836395D-05,-3.6347578404608223492D-07/
CS    DATA QQ/-3.8806586721556593450E+00, 3.2593714889036996297E+00,
CS   1        -8.5017476463217924408E-01, 7.4212010813186530069E-02,
CS   2        -2.2835624489492512649E-03, 3.7510433111922824643E-05/
CD    DATA QQ/-3.8806586721556593450D+00, 3.2593714889036996297D+00,
CD   1        -8.5017476463217924408D-01, 7.4212010813186530069D-02,
CD   2        -2.2835624489492512649D-03, 3.7510433111922824643D-05/
CS    DATA PBAR/3.98437500E-01/
CD    DATA PBAR/3.98437500D-01/
C--------------------------------------------------------------------
      X = ABS(ARG)
      IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C  Return for ABS(ARG) .LT. XSMALL
C--------------------------------------------------------------------
            RESULT = HALF * X
         ELSE IF (X .LT. ONE5) THEN
C--------------------------------------------------------------------
C  XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
            XX = X * X
            SUMP = P(1)
            DO 50 J = 2, 15
               SUMP = SUMP * XX + P(J)
   50          CONTINUE
            XX = XX - TWO25
            SUMQ = ((((XX+Q(1))*XX+Q(2))*XX+Q(3))*XX+Q(4))
     1           *XX+Q(5)
            RESULT = (SUMP / SUMQ) * X
            IF (JINT .EQ. 2) RESULT = RESULT * EXP(-X)
         ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
                  RESULT = XINF
         ELSE
C--------------------------------------------------------------------
C  15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
            XX = ONE / X - REC15
            SUMP = ((((((PP(1)*XX+PP(2))*XX+PP(3))*XX+
     1           PP(4))*XX+PP(5))*XX+PP(6))*XX+PP(7))*XX+PP(8)
            SUMQ = (((((XX+QQ(1))*XX+QQ(2))*XX+QQ(3))*XX+
     1           QQ(4))*XX+QQ(5))*XX+QQ(6)
            RESULT = SUMP / SUMQ
            IF (JINT .NE. 1) THEN
                  RESULT = (RESULT + PBAR) / SQRT(X)
               ELSE
C--------------------------------------------------------------------
C  Calculation reformulated to avoid premature overflow
C--------------------------------------------------------------------
                  IF (X .GT. XMAX-ONE5) THEN
                        A = EXP(X-FORTY)
                        B = EXP40
                     ELSE
                        A = EXP(X)
                        B = ONE
                  END IF
                  RESULT = ((RESULT * A + PBAR * A) /
     1                  SQRT(X)) * B
C--------------------------------------------------------------------
C  Error return for ABS(ARG) .GT. XMAX
C--------------------------------------------------------------------
            END IF
      END IF
      IF (ARG .LT. ZERO) RESULT = -RESULT
      RETURN
C----------- Last line of CALCI1 -----------
      END SUBROUTINE CALCI1
CS    REAL
      DOUBLE PRECISION FUNCTION BESI1(X)
C--------------------------------------------------------------------
C
C This long precision subprogram computes approximate values for
C   modified Bessel functions of the first kind of order one for
C   arguments ABS(ARG) .LE. XMAX  (see comments heading CALCI1).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=1
      CALL CALCI1(X,RESULT,JINT)
      BESI1=RESULT
      RETURN
C---------- Last line of BESI1 ----------
      END FUNCTION BESI1
CS    REAL
      DOUBLE PRECISION FUNCTION BESEI1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the first kind of order one
C   multiplied by EXP(-ABS(X)), where EXP is the
C   exponential function, ABS is the absolute value, and X
C   is any argument.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=2
      CALL CALCI1(X,RESULT,JINT)
      BESEI1=RESULT
      RETURN
C---------- Last line of BESEI1 ----------
      END FUNCTION BESEI1

      end module i1


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_N_dNdkesi_J_detJ(kesi,yita,
     &                                X_NODES,Y_NODES,
     &                                detJ,J,N,dNdkesi)

c     This function calculates N, dNdkesi, J and the determinant of Jacobian matrix.

      implicit none

      double precision,intent(in)::kesi,yita,X_NODES(4),Y_NODES(4)
      double precision,intent(out)::detJ,dNdkesi(4,2)
      double precision,intent(out):: N(2,8)
      double precision N1,N2,N3,N4
      double precision o     !zero
      double precision one   !1
      double precision fo    !4

      double precision temp(2,4),Coor(2,4),J(2,2)

      o   = 0.0D0
      one = 1.0D0
      fo  = 4.0D0

	  ! Coordinates of the element.
	  Coor(1,:) = [X_NODES(1),X_NODES(2),X_NODES(3),X_NODES(4)]
	  Coor(2,:) = [Y_NODES(1),Y_NODES(2),Y_NODES(3),Y_NODES(4)]

	  ! Calculate N.
	  N1 = (one-kesi)*(one-yita)/fo
	  N2 = (one+kesi)*(one-yita)/fo
	  N3 = (one+kesi)*(one+yita)/fo
	  N4 = (one-kesi)*(one+yita)/fo
	  N(1,:) = [N1,o,N2,o,N3,o,N4,o]
	  N(2,:) = [o,N1,o,N2,o,N3,o,N4]

	! Calculate dNdkesi.
	  temp(1,:) =[(yita-one)/fo,(-yita+one)/fo,
     &                    (yita+one)/fo,(-yita-one)/fo]
      temp(2,:) =[(kesi-one)/fo,(-kesi-one)/fo,
     &                    (kesi+one)/fo,(-kesi+one)/fo]

	  dNdkesi = transpose(temp)

	  ! Calculate the Jacobian matrix.
	  J = MATMUL(Coor,dNdkesi)

	  ! Calculate the determinant of Jacobian matrix.
      call Matrix_Det(2,J,detJ)

      return
      end SUBROUTINE Cal_N_dNdkesi_J_detJ


SUBROUTINE PACKINGBANDMATRIX(N,A,KD,AB,INFO)

! brute force packing of a banded matrix

  IMPLICIT NONE
  INTEGER, INTENT(INOUT) :: INFO
  INTEGER, INTENT(IN)    :: N,KD
  COMPLEX*16, DIMENSION(N,N)    :: A
  COMPLEX*16, DIMENSION(KD+1,N) :: AB

  INTEGER i,j,N_,I_

  DO j=1,N
     IF(1.GE.(j-KD)) THEN
        I_=1
     ELSE
        I_ = j-KD
     END IF
     ! U STORAGE
     DO i=I_,j
        AB(KD+1+i-j,j) = A(i,j)
     END DO
  END DO

END SUBROUTINE PACKINGBANDMATRIX

SUBROUTINE LAPACK_FULLEIGENVALUESBAND(AB,Z,KD,N,W,INFO)
!eigenvalues/vectors of banded matrix ab
!AB, inout, packed banded matrix
!Z, out,eigenvectors
!KD out, calcuated eigenvectors
!N, in,matrix dimension
!W, out, eigenvalues
!INFO,inout, error flag

  !H is COMPLEX*16 array, dimension (N, N)
  !  69 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
  !  70 *>          leading N-by-N upper triangular part of A contains the
  !  71 *>          upper triangular part of the matrix A.  If UPLO = 'L',
  !  72 *>          the leading N-by-N lower triangular part of A contains
  !  73 *>          the lower triangular part of the matrix A.
  !  74 *>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
  !  75 *>          orthonormal eigenvectors of the matrix A.
  !  76 *>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
  !  77 *>          or the upper triangle (if UPLO='U') of A, including the
  !  78 *>          diagonal, is destroyed.
  !
  ! The eigenvector H(:,r) corresponds to the eigenvalue W_SPACE(r)
  !
  IMPLICIT NONE
  INTEGER,                                INTENT(IN)    :: N,KD
  COMPLEX*16,       DIMENSION(KD+1,N), INTENT(INOUT)    :: AB
  COMPLEX*16,       DIMENSION(N,N),       INTENT(INOUT) :: Z
  DOUBLE PRECISION, DIMENSION(N),         INTENT(INOUT) :: W
  INTEGER,                                INTENT(OUT)   :: INFO

  !---SETTING  LAPACK VARIABLES: START ---------!
  CHARACTER         JOBZ, UPLO
  INTEGER           LDAB,LDZ
  DOUBLE PRECISION, DIMENSION(:),   ALLOCATABLE :: RWORK
  COMPLEX*16,       DIMENSION(:),   ALLOCATABLE :: WORK

  JOBZ = 'V'
  UPLO = 'U'

  LDAB = KD+1
  LDZ  = N

  ALLOCATE(WORK(N))
  ALLOCATE(RWORK(3*N-2))

!  WRITE(*,*) JOBZ, UPLO, N, KD,  LDAB, LDZ,  INFO
  CALL ZHBEV(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )
  IF(INFO /= 0) WRITE(*,*) "# DIAG FAIL 1",INFO

  DEALLOCATE(WORK)
  DEALLOCATE(RWORK)

END SUBROUTINE LAPACK_FULLEIGENVALUESBAND

SUBROUTINE LAPACK_FULLEIGENVALUES(H,N,W_SPACE,INFO)
!eigenvalues/vectors of matrix ab
!H, inout, packed banded matrix
! , out,eigenvectors
!N, in,matrix dimension
!W_space, out, eigenvalues
!INFO,inout, error flag

  !H is COMPLEX*16 array, dimension (N, N)
  !  69 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
  !  70 *>          leading N-by-N upper triangular part of A contains the
  !  71 *>          upper triangular part of the matrix A.  If UPLO = 'L',
  !  72 *>          the leading N-by-N lower triangular part of A contains
  !  73 *>          the lower triangular part of the matrix A.
  !  74 *>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
  !  75 *>          orthonormal eigenvectors of the matrix A.
  !  76 *>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
  !  77 *>          or the upper triangle (if UPLO='U') of A, including the
  !  78 *>          diagonal, is destroyed.
  !
  ! The eigenvector H(:,r) corresponds to the eigenvalue W_SPACE(r)
  !
  IMPLICIT NONE
  INTEGER,                          INTENT(IN)    :: N
  COMPLEX*16,       DIMENSION(N,N), INTENT(INOUT) :: H
  DOUBLE PRECISION, DIMENSION(N),   INTENT(INOUT) :: W_SPACE
  INTEGER,                          INTENT(OUT)   :: INFO

  !---SETTING  LAPACK VARIABLES: START ---------!
  CHARACTER         JOBZ, UPLO
  INTEGER           LWORK,LDA
  INTEGER,          DIMENSION(:),   ALLOCATABLE :: IWORK,ISUPPZ
  DOUBLE PRECISION, DIMENSION(:),   ALLOCATABLE :: RWORK
  COMPLEX*16,       DIMENSION(:),   ALLOCATABLE :: WORK
  COMPLEX*16,       DIMENSION(:,:), ALLOCATABLE :: H_AUX_
  DOUBLE PRECISION, DIMENSION(N) :: E
  JOBZ = 'V'
  UPLO = 'L'

!  write(*,*) "# call to lapack diagonalization of a matrix of size",N
!  write(*,*) H

  ALLOCATE(H_AUX_(N,N))
  H_AUX_ = 0.0
  LDA   =  N
  LWORK = 2*N

  ALLOCATE(WORK(2*N))
  ALLOCATE(RWORK(3*N-2))

  !---- use zheev to get the optimun value of LWORK
  WORK = -1
  CALL ZHEEV(JOBZ,UPLO,N,H_AUX_,LDA,W_SPACE,WORK,LWORK,RWORK,INFO)
  LWORK = INT(WORK(1))
  IF(LWORK.GT.0) THEN
     DEALLOCATE(WORK)
     ALLOCATE(WORK(LWORK))
  ELSE
     WRITE(*,*) "ERROR IN ZHEEV CALLED BY LAPACK_FULLEIGENVALUES"
  END IF
  !write(*,*) info,LWORK,UPLO,N,H
  IF(INFO /= 0) WRITE(*,*) "# DIAG FAIL 0",INFO

  CALL ZHEEV(JOBZ,UPLO,N,H,LDA,W_SPACE, WORK, LWORK, RWORK,INFO)
  !IF(INFO /= 0) WRITE(*,*) "# DIAG FAIL 1",INFO
  DEALLOCATE(WORK)
  DEALLOCATE(RWORK)
  DEALLOCATE(H_AUX_)
END SUBROUTINE LAPACK_FULLEIGENVALUES

SUBROUTINE LAPACK_SELECTEIGENVALUES(H,N,W_SPACE,L1,L2,Z,INFO)
!selected eigenvalues/vectors of hermitian matrix
!H, inout, packed banded matrix
! , out,eigenvectors
!N, in,matrix dimension
!W_space, out, eigenvalues
!L1 ordinal lowest eigenvalue
!L2 ordinal highest eigenvlaue
!Z : eigenvectors
!INFO,inout, error flag

  !USE FLOQUET
  IMPLICIT NONE
  INTEGER,                        INTENT(IN)    :: N,L1,L2
  COMPLEX*16, DIMENSION(:,:),     INTENT(INOUT) :: H
  COMPLEX*16, DIMENSION(:,:),     INTENT(OUT)   :: Z
  DOUBLE PRECISION, DIMENSION(:), INTENT(OUT)   :: W_SPACE
  INTEGER,                        INTENT(OUT)   :: INFO

  !---SETTING  LAPACK VARIABLES: START ---------!
  CHARACTER         JOBZ, UPLO, RANGE
  DOUBLE PRECISION ABSTOL, VL, VU
  INTEGER           LWORK,LDA,LRWORK, LIWORK, IL, IU, MP,LDZ,LWMAX
  INTEGER,          DIMENSION(:),   ALLOCATABLE :: IWORK,ISUPPZ
  DOUBLE PRECISION, DIMENSION(:),   ALLOCATABLE :: RWORK
  COMPLEX*16,       DIMENSION(:),   ALLOCATABLE :: WORK
  COMPLEX*16,       DIMENSION(:,:), ALLOCATABLE :: H_AUX_
  JOBZ = 'V'
  UPLO = 'L'
  RANGE = 'A'
  LWMAX  = 2000
  ABSTOL = -1.0

  ALLOCATE(H_AUX_(N,N))
  H_AUX_ = 0.0
  LDA   =   N
  LWORK = 2*N
  LDZ   =   N
  ALLOCATE(WORK(LWMAX))
  ALLOCATE(RWORK(LWMAX))
  ALLOCATE(IWORK(LWMAX))
  ALLOCATE(ISUPPZ(N))
  LWORK = -1
  LRWORK = -1
  LIWORK = -1
  VL = 0.749
  VU = 0.7503! 45.0
  IL = 1!L1!(2*N_Floquet+1)*(3) + 5*(int(0.5*(2*N_Floquet+1)) - SUBSPACES) + 1
  IU = 1!L2!IL + (2*SUBSPACES + 1)*5 - 1
  !  write(*,*) IL,IU,N
!!$  IF(JOBZ.EQ.'V')  THEN
!!$     ALLOCATE(Z(N,IU-IL + 1))
!!$  ELSE
!!$     ALLOCATE(Z(1,1))
!!$  END IF

  CALL ZHEEVR( JOBZ, RANGE, 'L', N, H_AUX_, LDA, VL, VU, IL, &
       &   IU, ABSTOL, MP, W_SPACE, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, &
       &   LRWORK, IWORK, LIWORK, INFO )
  IF(INFO /= 0) WRITE(*,*) "DIAG FAIL"
  LWORK  = WORK(1)
  LRWORK = RWORK(1)
  LIWORK = IWORK(1)
  DEALLOCATE(WORK,RWORK,IWORK)
  ALLOCATE(WORK(LWORK))
  ALLOCATE(RWORK(LRWORK))
  ALLOCATE(IWORK(LIWORK))
  !write(*,*)INFO,LWORK,LRWORK,LIWORK
  CALL ZHEEVR( JOBZ, RANGE, 'L', N, H, LDA, VL, VU, IL, &
       &   IU, ABSTOL, MP, W_SPACE, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, &
       &   LRWORK, IWORK, LIWORK, INFO )
  IF(INFO /= 0) WRITE(*,*) "DIAG FAIL"
  !  write(*,*) info

  DEALLOCATE(WORK,RWORK,IWORK,H_AUX_,ISUPPZ)

END SUBROUTINE LAPACK_SELECTEIGENVALUES


PROGRAM MolecularDynamics3
  ! This program demonstrates parallelization of a molecular dynamics program.
  ! In this program, most of the time is used in the 2 inner most loops that
  ! calculate the force between 2 particles.
  ! In this case, the inner of these 2 loops is parallelized.

  USE IFPORT

  IMPLICIT NONE
  INCLUDE 'mpif.h'

  ! Configuration
  INTEGER, PARAMETER :: n = 10
  REAL, DIMENSION(n) ::  f, x, ff

  ! MPI variables
  INTEGER               :: nprocs
  INTEGER               :: myrank
  INTEGER               :: ierr

  ! Count and temporary variables
  INTEGER :: t, i, j, irank
  REAL    :: fij

  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr)

  ! Initialize
  CALL srand(100)
  DO i = 1, n
    x(i) = 50.0*rand()
  ENDDO

  IF (myrank == 0) write (*,*) "x = ", x

  ! The main loop
  DO t = 1, 2
    DO i = 1, n
      f(i) = 0.0
    ENDDO
    irank = -1
    DO i = 1, n-1
      DO j = i+1, n
        irank = irank + 1
        IF (irank == nprocs) irank = 0
        IF (myrank == irank) THEN
          fij = 1.0 / (x(j)-x(i))
          f(i) = f(i) + fij
          f(j) = f(j) - fij
        ENDIF
      ENDDO
    ENDDO
    CALL MPI_ALLREDUCE(f, ff, n, MPI_REAL, MPI_SUM, MPI_COMM_WORLD, ierr)
    DO i = 1, n
      x(i) = x(i) + ff(i)
    ENDDO

    IF (myrank == 0) write (*,*) "x = ", x
  ENDDO

  CALL MPI_FINALIZE(ierr)
END PROGRAM MolecularDynamics3


program problem48
  implicit none
  integer*8 :: answer,temp,digits
  integer   :: i,j

  digits=(10_8)**(10)
  answer=0

  do i=1,1000
     temp=1
     do j=1,i
        temp=mod(temp*i,digits)
     end do
     answer=mod(answer+temp,digits)
  end do

  print *, answer

end program problem48


C NCLFORTSTART
      SUBROUTINE DWGTAREASUM2(T,WGT,MX,NY,TMSG,IFLAG,SUM)
      IMPLICIT NONE
      INTEGER MX,NY,IFLAG
      DOUBLE PRECISION T(MX,NY),WGT(MX,NY)
      DOUBLE PRECISION TMSG
      DOUBLE PRECISION SUM
C NCLEND

C NCL: sumX = wgt_AreaSum2(x,wgt,flag)

      INTEGER NL,ML,KMSG,KOK
      DOUBLE PRECISION SUMT

C compute the weighted area sum

C Nomenclature:
C INPUT:
C t      - 2D array
C wgt    - 2D array
C mx     - 1st [faster varying] dimension of "t" [eg, longitude]
C ny     - 2nd [slower varying] dimension of "t" [eg, latitude ]
C tmsg   - msg value
C iflag  - flag
C          =0 compute  sum ignoring msg values
C          =1 if any msg data is encountered return as msg
c OUTPUT:
C sum    - area weighted sum

      SUMT = 0.0D0
      SUM = TMSG
      KMSG = 0
      KOK = 0

      DO NL = 1,NY
          DO ML = 1,MX
              IF (T(ML,NL).NE.TMSG) THEN
                  KOK = KOK + 1
                  SUMT = SUMT + T(ML,NL)*WGT(ML,NL)
              ELSE
                  KMSG = KMSG + 1
              END IF
          END DO
c                                      return if user desired
          IF (IFLAG.EQ.1 .AND. KMSG.NE.0) RETURN
      END DO
c
      IF (KOK.GT.0) THEN
          SUM = SUMT
      END IF

      RETURN
      END


MODULE QNSTOPS_MOD
! Code for generating a latin hypercube experimental design from the QNSTOP
! software package.
!
! Credit to B. D. Amos, D. R. Easterling, L. T. Watson, W. I. Thacker,
! B. S. Castle, and M. W. Trosset. Algorithm XXX: QNSTOP -- Quasi-Newton
! Algorithm for Stochastic Optimization.
!
USE REAL_PRECISION, ONLY : R8
CONTAINS

SUBROUTINE LATINDESIGN(P, LNSTART, LB, UB, XI, LHSDESIGN)
! LATINDESIGN generates a Latin hypercube experimental design with
! LNSTART points, one of which is XI, in the P-dimensional box
! B = { x | LB <= x <= UB }.  Partition each interval [LB(J),UB(J)]
! into LNSTART equal length subintervals, which partitions the box B
! into cells. A Latin hypercube experimental design has the property
! that if the LNSTART points are projected onto any coordinate
! direction K, for 1 <= K <= P, the projection has exactly one point
! in each of the subintervals of [LB(K),UB(K)].  The cells centered
! along the diameter [LB,UB] of the box B are called the diagonal cells.
!
! The algorithm is to first generate LNSTART points in the diagonal
! cells, stored as the columns of the array LHSDESIGN(1:P,1:LNSTART).
! Then swap appropriate coordinates with the last column so that the
! given point XI can be inserted as the last column.  Finally, permute
! the coordinates within rows of LHSDESIGN(1:P,1:LNSTART-1) by doing
! LNSTART-2 random interchanges in each row.
!
! On input:
!
! P is the dimension.
!
! LNSTART is the integer number of points in the experimental design.
!
! LB(1:P) is a real array giving the lower bounds.
!
! UB(1:P) is a real array giving the upper bounds, defining the box
!   { x | LB <= x <= UB } in which design is generated.
!
! XI(1:P) is a real array containing the start point to be inserted in the
!   Latin hypercube design.
!
! On output:
!
! LHSDESIGN(1:P,1:LNSTART) is a real array whose columns are the Latin
!   hypercube experimental design, with XI being the last column.

INTEGER, INTENT(IN):: P, LNSTART
REAL(KIND=R8), DIMENSION(P), INTENT(IN):: LB, UB, XI
REAL(KIND=R8), DIMENSION(P,LNSTART), INTENT(OUT):: LHSDESIGN

! Local variables.
INTEGER:: I, J, L   ! Temporary loop variable.
REAL(KIND=R8):: TEMP  ! Used for swapping coordinates.
REAL(KIND=R8), DIMENSION(P):: WORK  ! Holds the bin sizes.
! SWAP is an array of random values for picking swap rows.
REAL(KIND=R8), DIMENSION(P,LNSTART-2):: SWAP

CALL RANDOM_NUMBER(HARVEST=LHSDESIGN(1:P,1:LNSTART))
WORK = (UB - LB)/REAL(LNSTART, KIND=R8)    ! Bin sizes.

! Start with all the points in diagonal cells.
DO J=1,LNSTART
  LHSDESIGN(1:P,J) = LB(1:P) + WORK(1:P)*(REAL(J-1, KIND=R8) + &
    LHSDESIGN(1:P,J))
END DO

! Now place the given start point XI into the last column by swapping
! coordinates.
DO J=1,P
  L = MIN(INT((XI(J) - LB(J))/WORK(J)) + 1, LNSTART )
  LHSDESIGN(J,L) = LHSDESIGN(J,LNSTART)
  LHSDESIGN(J,LNSTART) = XI(J)
END DO

CALL RANDOM_NUMBER(HARVEST=SWAP(1:P, 1:LNSTART-2))
! Permute coordinates within each row of LHSDESIGN(1:P,1:LNSTART-1) by
! doing LNSTART - 2 interchanges.
DO I=1,P
  DO J=LNSTART-1,2,-1
    L = INT(SWAP(I,J-1)*REAL(J,KIND=R8)) + 1
    TEMP = LHSDESIGN(I,J)
    LHSDESIGN(I,J) = LHSDESIGN(I,L)
    LHSDESIGN(I,L) = TEMP
  END DO
END DO
RETURN
END SUBROUTINE LATINDESIGN

END MODULE QNSTOPS_MOD


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the user supplied external subroutines that define
! the PDE(s) to be solved, and other required external subroutines.
!   pdecoefs bconds boundary_point boundary_npiece boundary_param iconds trues
!   truexs trueys update_usermod phaml_integral_kernel
!
! This version illustrates the subroutines for a single PDE, thus all the
! array arguments have dimension 1.  For a coupled system of PDEs, see
! examples/system.
!----------------------------------------------------

module phaml_user_mod
integer :: power=2
end module phaml_user_mod

!          --------
subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
!          --------

!----------------------------------------------------
! This subroutine returns the coefficient and right hand side of the PDE
! at the point (x,y)
!
! The PDE is
!
!    -( cxx(x,y) * u  )  -( cyy(x,y) * u  ) + c(x,y) * u = rs(x,y)
!                   x  x                y  y
!
! For eigenvalue problems, the right hand side is lambda * u * rs(x,y)
!
! cxy, cx and cy are not currently used and should not be set.  They are
! for future expansion.
!
! NOTE: BE CAREFUL TO GET THE SIGNS RIGHT
! e.g. cxx=cyy=1 means rs=-(uxx+uyy)
!
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Local variables

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

!----------------------------------------------------
! Begin executable code

cxx(1,1) = 1.0_my_real
cyy(1,1) = 1.0_my_real
c(1,1) = 0.0_my_real
rs(1) = -power*(power-1)*(x**(power-2)+y**(power-2))

cx=0; cy=0; cxy=0

end subroutine pdecoefs

!          ------
subroutine bconds(x,y,bmark,itype,c,rs)
!          ------

!----------------------------------------------------
! This subroutine returns the boundary conditions at the point (x,y).
!
! Each boundary condition is either
!
!    u = rs(x,y) or  u  + c(x,y)*u = rs(x,y)
!                     n
!
! itype indicates which type of condition applies to each point, using
! symbolic constants from module phaml.  It is DIRICHLET for the first
! condition, NATURAL for the second condition with c==0, and MIXED for
! the second condition with c/=0.
!
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Non-module procedures used are:

interface

   function trues(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: trues
   end function trues

end interface

!----------------------------------------------------
! Local variables

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

!----------------------------------------------------
! Begin executable code

! Dirichlet boundary conditions

itype = DIRICHLET
c = 0.0_my_real
rs(1) = trues(x,y,1,1)

end subroutine bconds

!        ------
function iconds(x,y,comp,eigen)
!        ------

!----------------------------------------------------
! This routine returns the initial condition for a time dependent problem.
! It can also be used for the initial guess for a nonlinear problem, or
! systems of equations solved by sucessive substitution.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
! For problems where there are no initial conditions, it is a dummy.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds

!----------------------------------------------------
! Begin executable code

iconds = 0.0_my_real

end function iconds

!        -----
function trues(x,y,comp,eigen) ! real (my_real)
!        -----

!----------------------------------------------------
! This is the true solution of the differential equation, if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
!----------------------------------------------------

!----------------------------------------------------
! Begin executable code

trues = x**power + y**power

end function trues

!        ------
function truexs(x,y,comp,eigen) ! real (my_real)
!        ------

!----------------------------------------------------
! This is the x derivative of the true solution of the differential
! equation, if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs
!----------------------------------------------------

!----------------------------------------------------
! Begin executable code

truexs = power*x**(power-1)

end function truexs

!        ------
function trueys(x,y,comp,eigen) ! real (my_real)
!        ------

!----------------------------------------------------
! This is the y derivative of the true solution of the differential
! equation, if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys
!----------------------------------------------------

!----------------------------------------------------
! Begin executable code

trueys = power*y**(power-1)

end function trueys

!          --------------
subroutine boundary_point(ipiece,s,x,y)
!          --------------

!----------------------------------------------------
! This routine defines the boundary of the domain.  It returns the point
! (x,y) with parameter s on piece ipiece.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: ipiece
real(my_real), intent(in) :: s
real(my_real), intent(out) :: x,y

!----------------------------------------------------
! Begin executable code

! Dummy version

x = 0.0_my_real
y = 0.0_my_real

end subroutine boundary_point

!        ---------------
function boundary_npiece(hole)
!        ---------------

!----------------------------------------------------
! This routine gives the number of pieces in the boundary definition.
! If boundary_npiece <= 0 the domain is given by triangle data files.
!----------------------------------------------------

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

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: hole
integer :: boundary_npiece
!----------------------------------------------------
! Begin executable code

boundary_npiece = 0

end function boundary_npiece

!          --------------
subroutine boundary_param(start,finish)
!          --------------

!----------------------------------------------------
! This routine gives the range of parameter values for each piece of the
! boundary.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(out) :: start(:), finish(:)
!----------------------------------------------------
! Begin executable code

! Dummy version

start = 0.0_my_real
finish = 0.0_my_real

end subroutine boundary_param

!          --------------
subroutine update_usermod(phaml_solution)
!          --------------

use phaml
use phaml_user_mod
type(phaml_solution_type), intent(in) :: phaml_solution
integer :: iparam(1)
real(my_real) :: rparam(1)

iparam(1) = power
rparam(1) = 0.0_my_real
call master_to_slaves(phaml_solution,iparam,rparam)
power = iparam(1)

end subroutine update_usermod

!        ---------------------
function phaml_integral_kernel(kernel,x,y)
!        ---------------------

use phaml
integer, intent(in) :: kernel
real(my_real), intent(in) :: x,y
real(my_real) :: phaml_integral_kernel

if (kernel == 2) then
   phaml_integral_kernel = x
else
   phaml_integral_kernel = 1.0_my_real
endif

end function phaml_integral_kernel

!        ----------
function regularity(x,y)
!        ----------

use phaml
real(my_real), intent(in) :: x(3),y(3)
real(my_real) :: regularity

! Dummy version, assume infinitely differentiable everywhere.

regularity = huge(0.0_my_real)

end function regularity


*DECK SPBSL
      SUBROUTINE SPBSL (ABD, LDA, N, M, B)
C***BEGIN PROLOGUE  SPBSL
C***PURPOSE  Solve a real symmetric positive definite band system
C            using the factors computed by SPBCO or SPBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2
C***TYPE      SINGLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SPBSL solves the real symmetric positive definite band
C     system  A*X = B
C     using the factors computed by SPBCO or SPBFA.
C
C     On Entry
C
C        ABD     REAL(LDA, N)
C                the output from SPBCO or SPBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C
C        B       REAL(N)
C                the right hand side vector.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal.  Technically, this indicates
C        singularity, but it is usually caused by improper subroutine
C        arguments.  It will not occur if the subroutines are called
C        correctly and  INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL SPBCO(ABD,LDA,N,RCOND,Z,INFO)
C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL SPBSL(ABD,LDA,N,C(1,J))
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SPBSL
      INTEGER LDA,N,M
      REAL ABD(LDA,*),B(*)
C
      REAL SDOT,T
      INTEGER K,KB,LA,LB,LM
C
C     SOLVE TRANS(R)*Y = B
C
C***FIRST EXECUTABLE STATEMENT  SPBSL
      DO 10 K = 1, N
         LM = MIN(K-1,M)
         LA = M + 1 - LM
         LB = K - LM
         T = SDOT(LM,ABD(LA,K),1,B(LB),1)
         B(K) = (B(K) - T)/ABD(M+1,K)
   10 CONTINUE
C
C     SOLVE R*X = Y
C
      DO 20 KB = 1, N
         K = N + 1 - KB
         LM = MIN(K-1,M)
         LA = M + 1 - LM
         LB = K - LM
         B(K) = B(K)/ABD(M+1,K)
         T = -B(K)
         CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   20 CONTINUE
      RETURN
      END


! Tiled fortran stencil

       SUBROUTINE stencilftiled(A, B, N, iters)
       INTEGER N, iters
       DOUBLE PRECISION A(N,N,N), B(N,N,N)
       INTEGER z
       DOUBLE PRECISION c
       c = 1 / 7.

       DO z=1,iters
         CALL tiledStencil(A, B, N, c)
         CALL tiledStencil(B, A, N, c)
       ENDDO

       RETURN
       END

       SUBROUTINE tiledStencil(A, B, N, c)
       INTEGER N
       DOUBLE PRECISION A(N,N,N), B(N,N,N)
       DOUBLE PRECISION c
       INTEGER i,j,k,bi,bj,bk,ni,nj,nk
       INTEGER blockSize

       blockSize = 16

       DO bi=2,N-1,blockSize
         DO bj=2,N-1,blockSize
           DO bk=2,N-1,blockSize
             ni = min(bi+blockSize-1,N-1)
             nj = min(bj+blockSize-1,N-1)
             nk = min(bk+blockSize-1,N-1)

             DO k=bk,nk
               DO j=bj,nj
                 DO i=bi,ni
                   A(i,j,k) = c * (B(i,j,k) + B(i+1,j,k) + B(i-1,j,k)
     .            + B(i,j+1,k) + B(i,j-1,k) + B(i,j,k+1) + B(i,j,k-1))
                 ENDDO
               ENDDO
             ENDDO
           ENDDO
         ENDDO
       ENDDO

       RETURN
       END


	subroutine vlog( vtarget, vsrc, n )
	implicit none
	integer n
	real*8 vtarget(n),vsrc(n)
	integer i
	do i=1,n
	  vtarget(i) = log( vsrc(i) )
	enddo
	return
	end subroutine vlog


PROGRAM msdmn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       ===========================================================
!       Purpose: This program computes the expansion coefficients
!                of the prolate and oblate spheroidal functions,
!                dk, using subroutine SDMN
!       Input :  m  --- Mode parameter
!                n  --- Mode parameter
!                c  --- Spheroidal parameter
!                cv --- Characteristic value
!                KD --- Function code
!                       KD=1 for prolate; KD=-1 for oblate
!       Output:  DF(k) --- Expansion coefficients dk;
!                          DF(1), DF(2),... correspond to
!                          d0, d2,... for even n-m and d1,
!                          d3,... for odd n-m
!       Example: Compute the first 12 expansion coefficients for
!                KD= 1, m=2, n=2, c=3.0 and cv=7.1511005241; and
!                KD=-1, m=2, n=2, c=3.0 and cv=4.5264604622

!                Coefficients of Prolate and oblate functions

!                  r          dr(c)             dr(-ic)
!                -------------------------------------------
!                  0     .9237882817D+00    .1115434000D+01
!                  2    -.2901607696D-01    .4888489020D-01
!                  4     .8142246173D-03    .1600845667D-02
!                  6    -.1632270292D-04    .3509183384D-04
!                  8     .2376699010D-06    .5416293446D-06
!                 10    -.2601391701D-08    .6176624069D-08
!                 12     .2209142844D-10    .5407431236D-10
!                 14    -.1494812074D-12    .3745889118D-12
!                 16     .8239302207D-15    .2103624480D-14
!                 18    -.3768260778D-17    .9768323113D-17
!                 20     .1452384658D-19    .3812753620D-19
!                 22    -.4780280430D-22    .1268321726D-21
!       ===========================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION df(200),eg(200)
WRITE(*,*)'Please enter KD, m, n and c '
! READ(*,*)KD,M,N,C
kd=1
m=2
n=2
c=3.0
CALL segv(m,n,c,kd,cv,eg)
WRITE(*,30)kd,m,n,c,cv
CALL sdmn(m,n,c,cv,kd,df)
WRITE(*,*)
IF (kd == 1) THEN
  WRITE(*,*)'Coefficients of Prolate function'
  WRITE(*,*)
  WRITE(*,*)'   r             dr(c)'
ELSE
  WRITE(*,*)'Coefficients of Oblate function'
  WRITE(*,*)
  WRITE(*,*)'   r            dr(-ic)'
END IF
WRITE(*,*)'----------------------------'
nm=25+INT(0.5*(n-m)+c)
DO  k=1,nm
  IF (n-m == 2*INT((n-m)/2)) THEN
    j=2*(k-1)
  ELSE
    j=2*k-1
  END IF
  WRITE(*,20)j,df(k)
END DO
20      FORMAT(2X,i3,4X,d18.10)
30      FORMAT(1X,3HKD=,i3,',  ',2HM=,i3,',  ',2HN=,i3,',  ',2HC=,  &
    f5.1,',  ',4HCV =,f18.10)
END PROGRAM msdmn

SUBROUTINE sdmn(m,n,c,cv,kd,df)

!       =====================================================
!       Purpose: Compute the expansion coefficients of the
!                prolate and oblate spheroidal functions, dk
!       Input :  m  --- Mode parameter
!                n  --- Mode parameter
!                c  --- Spheroidal parameter
!                cv --- Characteristic value
!                KD --- Function code
!                       KD=1 for prolate; KD=-1 for oblate
!       Output:  DF(k) --- Expansion coefficients dk;
!                          DF(1), DF(2),... correspond to
!                          d0, d2,... for even n-m and d1,
!                          d3,... for odd n-m
!       =====================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
DOUBLE PRECISION, INTENT(IN OUT)         :: cv
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: df(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION a(200),d(200),g(200)

sw=0.0
fl=0.0
nm=25+INT(0.5*(n-m)+c)
IF (c < 1.0D-10) THEN
  DO  i=1,nm
    df(i)=0D0
  END DO
  df((n-m)/2+1)=1.0D0
  RETURN
END IF
cs=c*c*kd
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
DO  i=1,nm+2
  IF (ip == 0) k=2*(i-1)
  IF (ip == 1) k=2*i-1
  dk0=m+k
  dk1=m+k+1
  dk2=2*(m+k)
  d2k=2*m+k
  a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
  d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
  g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
END DO
fs=1.0D0
f1=0.0D0
f0=1.0D-100
kb=0
df(nm+1)=0.0D0
DO  k=nm,1,-1
  f=-((d(k+1)-cv)*f0+a(k+1)*f1)/g(k+1)
  IF (DABS(f) > DABS(df(k+1))) THEN
    df(k)=f
    f1=f0
    f0=f
    IF (DABS(f) > 1.0D+100) THEN
      DO  k1=k,nm
        df(k1)=df(k1)*1.0D-100
      END DO
      f1=f1*1.0D-100
      f0=f0*1.0D-100
    END IF
  ELSE
    kb=k
    fl=df(k+1)
    f1=1.0D-100
    f2=-(d(1)-cv)/a(1)*f1
    df(1)=f1
    IF (kb == 1) THEN
      fs=f2
    ELSE IF (kb == 2) THEN
      df(2)=f2
      fs=-((d(2)-cv)*f2+g(2)*f1)/a(2)
    ELSE
      df(2)=f2
      DO  j=3,kb+1
        f=-((d(j-1)-cv)*f2+g(j-1)*f1)/a(j-1)
        IF (j <= kb) df(j)=f
        IF (DABS(f) > 1.0D+100) THEN
          DO  k1=1,j
            df(k1)=df(k1)*1.0D-100
          END DO
          f=f*1.0D-100
          f2=f2*1.0D-100
        END IF
        f1=f2
        f2=f
      END DO
      fs=f
    END IF
    EXIT
  END IF
END DO
35      su1=0.0D0
r1=1.0D0
DO  j=m+ip+1,2*(m+ip)
  r1=r1*j
END DO
su1=df(1)*r1
DO  k=2,kb
  r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su1=su1+r1*df(k)
END DO
su2=0.0D0
DO  k=kb+1,nm
  IF (k /= 1) r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su2=su2+r1*df(k)
  IF (DABS(sw-su2) < DABS(su2)*1.0D-14) EXIT
  sw=su2
END DO
55      r3=1.0D0
DO  j=1,(m+n+ip)/2
  r3=r3*(j+0.5D0*(n+m+ip))
END DO
r4=1.0D0
DO  j=1,(n-m-ip)/2
  r4=-4.0D0*r4*j
END DO
s0=r3/(fl*(su1/fs)+su2)/r4
DO  k=1,kb
  df(k)=fl/fs*s0*df(k)
END DO
DO  k=kb+1,nm
  df(k)=s0*df(k)
END DO
RETURN
END SUBROUTINE sdmn

SUBROUTINE segv(m,n,c,kd,cv,eg)

!     =========================================================
!     Purpose: Compute the characteristic values of spheroidal
!     wave functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     KD --- Function code
!     KD=1 for Prolate; KD=-1 for Oblate
!     Output:  CV --- Characteristic value for given m, n and c
!     EG(L) --- Characteristic value for mode m and n'
!     ( L = n' - m + 1 )
!     =========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: cv
DOUBLE PRECISION, INTENT(OUT)            :: eg(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION b(100),h(100),d(300),e(300),f(300),cv0(100),a(300) ,g(300)

IF (c < 1.0D-10) THEN
  DO  i=1,n
    eg(i)=(i+m)*(i+m-1.0D0)
  END DO
ELSE
  icm=INT((n-m+2)/2)
  nm=10+INT(0.5*(n-m)+c)
  cs=c*c*kd
  DO  l=0,1
    DO  i=1,nm
      IF (l == 0) k=2*(i-1)
      IF (l == 1) k=2*i-1
      dk0=m+k
      dk1=m+k+1
      dk2=2*(m+k)
      d2k=2*m+k
      a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
      d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
      g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
    END DO
    DO  k=2,nm
      e(k)=DSQRT(a(k-1)*g(k))
      f(k)=e(k)*e(k)
    END DO
    f(1)=0.0D0
    e(1)=0.0D0
    xa=d(nm)+DABS(e(nm))
    xb=d(nm)-DABS(e(nm))
    nm1=nm-1
    DO  i=1,nm1
      t=DABS(e(i))+DABS(e(i+1))
      t1=d(i)+t
      IF (xa < t1) xa=t1
      t1=d(i)-t
      IF (t1 < xb) xb=t1
    END DO
    DO  i=1,icm
      b(i)=xa
      h(i)=xb
    END DO
    DO  k=1,icm
      DO  k1=k,icm
        IF (b(k1) < b(k)) THEN
          b(k)=b(k1)
          EXIT
        END IF
      END DO
      35      IF (k /= 1.AND.h(k) < h(k-1)) h(k)=h(k-1)
      DO WHILE (1==1)
        40       x1=(b(k)+h(k))/2.0D0
        cv0(k)=x1
        IF (DABS((b(k)-h(k))/x1) < 1.0D-14) EXIT
        j=0
        s=1.0D0
        DO  i=1,nm
          IF (s == 0.0D0) s=s+1.0D-30
          t=f(i)/s
          s=d(i)-t-x1
          IF (s < 0.0D0) j=j+1
        END DO
        IF (j < k) THEN
          h(k)=x1
        ELSE
          b(k)=x1
          IF (j >= icm) THEN
            b(icm)=x1
          ELSE
            IF (h(j+1) < x1) h(j+1)=x1
            IF (x1 < b(j)) b(j)=x1
          END IF
        END IF
      END DO
      50      cv0(k)=x1
      IF (l == 0) eg(2*k-1)=cv0(k)
      IF (l == 1) eg(2*k)=cv0(k)
    END DO
  END DO
END IF
70   cv=eg(n-m+1)
RETURN
END SUBROUTINE segv


*----------------------------------------------------------------------*
      subroutine real2rat(num,den,rl)
*----------------------------------------------------------------------*
*     get best approximation of real number rl by rational number
*     rat = num/den
*
*     stupid brute force algorithm
*
*----------------------------------------------------------------------*
      implicit none

      integer, intent(out) ::
     &     num, den
      real(8), intent(in) ::
     &     rl

      integer, parameter ::
     &     maxtest = 40320  !   = 8!
      real(8), parameter ::
     &     thrsh = 1d-12

      real(8) ::
     &     arl
      integer ::
     &     numlw0, numup0, denlw0, denup0, denlw, denup, numlw, numup

      arl = abs(rl)
      if (arl.gt.1d0) then
        numlw0 = int(arl)
        numup0 = numlw0+1
        den_loop: do den = 1, maxtest
          numlw = numlw0*den
          numup = numup0*den
          do num = numlw, numup
            if (abs(dble(num)/dble(den)-arl).lt.thrsh) exit den_loop
            if (abs(dble(num)/dble(den)-arl).gt.0d0) cycle
          end do
        end do den_loop
      else
        denlw0 = int(1d0/arl)
        denup0 = denlw0+1
        num_loop: do num = 1, maxtest
          denlw = max(1,denlw0*num)
          denup = denup0*num
          do den = denlw, denup
            if (abs(dble(num)/dble(den)-arl).lt.thrsh) exit num_loop
            if (abs(dble(num)/dble(den)-arl).lt.0d0) cycle
          end do
        end do num_loop
      end if

      if (.not.(abs(dble(num)/dble(den)-arl).lt.thrsh))
     &       call quit(1,'real2rat','too stupid for this')

      if (rl.lt.0d0) num = -num

      end