program example
  ! Implementation of example 10.4 from NMUM (Fink & Mathews): Crank/Nicholson
  ! for the heat equation.

  !  REQUIREMENTS: This file must be compiled against...
  !     LAPACK
  !     Write2d.f90
  !     ModOutput.f90

  ! Always start with this implicit none.  It's the most important line
  ! in any fortran program.  It forces the user to declare all variables.
  use ModHeatCN, ONLY: init_sim, integrate, finalize_sim, &
       DomainNow, nX, xGrid, dt, dx

  implicit none

  ! Constants:
  real, parameter :: cPi = 3.14159265359
  integer :: i
  !--------------------------------------------------------------------------
  write(*,*) 'Beginning Simulation.'

  ! Initialize the system.
  call init_sim(0.1, 0.01)

  ! We want non-zero initial conditions!
  do i=1, nX
     DomainNow(i) = sin(cPi*xGrid(i)) + sin(3.0*cPi*xGrid(i))
  end do

  DomainNow(1)  = 0.0
  DomainNow(nX) = 0.0

  ! Integrate!
  write(*,*) '...integrating...'
  call integrate()

  ! Wrap things up.
  call finalize_sim()

end program example


! Homework 9 - PIMC Integration
! Problem 2
implicit none
real*8 x(2), xmax, dtau, tau, acc, accav
real*8 e, el(1000000), elav, stderr, anal
real*8 pi
integer n, i, j

open(unit = 16, file = 'acceptance.pl')
open(unit = 17, file = 'var.pl')
open(unit = 18, file = 'varfine.pl')
open(unit = 19, file = 'analvar.pl')

pi = 3.14159265359d0

call random_number(e)

n = 1000000

do j = 2, 20
  tau = 0.5d0 * j
  dtau = tau / 2
  accav = 0.d0
  e = 0.d0
  el = 0.d0
  xmax = 2.5d0
  call random_number(x)

  do i = 1, 2000
    call metro(x, xmax, acc, dtau)
  end do

  do i = 1, n

    call metro(x, xmax, acc, dtau)
    accav = accav + acc

    call getE(e, x(1), x(2), dtau)
    el(i) = el(i) + e / 2
    call getE(e, x(2), x(1), dtau)
    el(i) = el(i) + e / 2
    !write(*,*) el(i)

  end do

  accav = accav / n
  elav = sum(el) / n
  el(:) = el(:) - elav
  el = el**2
  stderr = dsqrt(sum(el) / (n - 1)) / dsqrt(dble(n))
  write(*,*) j
  write(16,*) tau, accav
  write(17,*) tau, elav, stderr
  call getReal(anal, tau)
  write(18,*) tau, elav - anal, stderr
  write(19,*) tau, anal
end do

!goto 69
!69 continue

end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine relpfun(relp, x1, x2, dtau, dx)
real*8 relp, x1, x2, dx(2), dtau
real*8 s12, s21

call getS(s12, x1, x2, dtau)
call getS(s21, x2, x1, dtau)
relp = 1 / exp(s12 + s21)

call getS(s12, x1 + dx(1), x2 + dx(2), dtau)
call getS(s21, x2 + dx(2), x1 + dx(1), dtau)
relp = 1 / exp(s12 + s21) / relp

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine metro(x, xmax, acc, dtau)
real*8 x(2), dx(2), xmax, relp, rng, acc, dtau

call random_number(dx)

dx = xmax * (dx - 0.5d0)
call relpfun(relp, x(1), x(2), dtau, dx)
call random_number(rng)
if (rng.lt.relp) then
  x = x + dx
  acc = 1.d0
else
  acc = 0.d0
end if

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine getS(s, x, xp, dtau)
real*8 s, x, xp, dtau

s = 0.5d0 * log(2 * 3.1415926535898d0 * dtau) !!!!!!!!!!!!!!!!!!
s = s + (x - xp)**2 / 2 / dtau
s = s + dtau * (x**2 + xp**2) / 4

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine getE(e, x, xp, dtau)
real*8 e, x, xp, dtau

e = (1 / dtau + dtau / 2 - ((x - xp) / dtau + 0.5d0 * dtau * x)**2 + x**2) / 2

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine getReal(anal, tau)
real*8 anal, tau

anal = 0.5d0 + 1 / (exp(tau) - 1)

return
end


subroutine create_I2(k,ncomp)

    use constants_module
    use arrays_module
    use arrays_section_module
    use xsec_attribute_module

    implicit none
    save

    integer, intent(in) :: k, ncomp

    integer :: i, pp
    real(kind=4) :: usTabProperty(2,nel),dsTabProperty(2,nel)
    real(kind=4) :: currentElev(nel),currentDpth(nel),currentWidth(nel),usWidth(nel),dsWidth(nel), cal_new_I2p(nel),cal_new_I2c(nel)
    real(kind=4) :: x1(nel), y1(nel), dbdxp(nel),dbdxc(nel)
    real(kind=4) :: increm, xt, r_interpo_nn

    currentElev = xsec_tab(1,:,k)
    currentWidth = xsec_tab(6,:,k)
    currentDpth = currentElev - currentElev(1)

    if (k .gt. 1) then

        usTabProperty(1,:) = xsec_tab(1,:,k-1)
        usTabProperty(2,:) = xsec_tab(6,:,k-1)

        x1=usTabProperty(1,:) - usTabProperty(1,1)
        y1=usTabProperty(2,:)
        do i=1,nel
            xt=currentDpth(i)
            usWidth(i)=r_interpo_nn(x1,y1,nel,xt)
        end do
    end if

    if (k .lt. ncomp) then

        dsTabProperty(1,:) = xsec_tab(1,:,k+1)
        dsTabProperty(2,:) = xsec_tab(6,:,k+1)
        x1=dsTabProperty(1,:) - dsTabProperty(1,1)
        y1=dsTabProperty(2,:)
        do i=1,nel
            xt=currentDpth(i)
            dsWidth(i)=r_interpo_nn(x1,y1,nel,xt)
        end do
    end if

    cal_new_I2p=0.0
    cal_new_I2c=0.0

    write(file_num,'(i4.4)')k
    open(22,file=trim(xSection_path)//file_num//'_I2')
    write(22,'(30a)')' Elev(m)    dbdxp(-)    dbdxc(-)      I2p     I2c'

    increm=currentElev(2)-currentElev(1)

    do i=1,nel
        if (k .eq. 1) then
            dbdxp(i)= 0
            dbdxc(i)=(dsWidth(i)-currentWidth(i))/(dx(k))
        elseif (k .eq. ncomp) then
            dbdxp(i)=(currentWidth(i)-usWidth(i))/(dx(k-1))
            dbdxc(i)= 0
        else
            dbdxp(i)=(currentWidth(i)-usWidth(i))/(dx(k-1))
            dbdxc(i)=(dsWidth(i)-currentWidth(i))/(dx(k))
        end if

        ! I2 calculation
        if (i .gt. 1) then
            do pp=2,i
                cal_new_I2p(i)=cal_new_I2p(i)+(currentElev(i)-currentElev(pp)+0.5*increm)*((dbdxp(pp)+dbdxp(pp-1))/2)*increm
                cal_new_I2c(i)=cal_new_I2c(i)+(currentElev(i)-currentElev(pp)+0.5*increm)*((dbdxc(pp)+dbdxc(pp-1))/2)*increm
            end do
        end if
        write(22,*)currentElev(i),dbdxp(i),dbdxc(i),cal_new_I2p(i),cal_new_I2c(i)
!10      format(3f12.2)
        xsec_tab(9,i,k) = cal_new_I2p(i)
        xsec_tab(10,i,k) = cal_new_I2c(i)
    end do
    close (22)

end subroutine create_I2


      subroutine diskpotentialestimate

      include 'commonblocks'
      common /diskestimate/ ddens(0:nmax),dpot(0:nmax),dfr(0:nmax)

      eps = dr/10.
      ntheta = 100

      do ir=0,nr
         r=ir*dr
         if(r.eq.0.) r = eps
         cthetamax = min(1.,10.*zdisk/r)
         dctheta=cthetamax/float(ntheta)
         s=s+dpolardiskdens(r,cthetamax)+dpolardiskdens(r,0.0)
         do is=1,ntheta-1,2
            ctheta=is*dctheta
            s=s+4*dpolardiskdens(r,ctheta)
         enddo
         do is=2,ntheta-2,2
            ctheta=is*dctheta
            s=s+2*dpolardiskdens(r,ctheta)
         enddo
         s=s*dctheta/3.
         ddens(ir)=s
 77   enddo

c     now get the potential harmonics of this new density. (BT 2-208)
c     Simpson's rule integration.

      s1(0)=0
      r = 2*dr
      s1(2)=(r*dr/3.)*(4*ddens(1)*(1.0-dr/r)**2+ddens(2))
      rold = r
      do ir=4,nr,2
         r=ir*dr
         s1a = (r*dr/3.)*(ddens(ir-2)*(1.0-2*dr/r)**2+
     +        4*ddens(ir-1)*(1.0-dr/r)**2+ddens(ir))
         s1(ir) = s1a + s1(ir-2)*rold/r
         rold = r
      enddo
      s2(nr)=0
      rold = nr*dr
      do ir=nr-2,2,-2
         r=ir*dr
         s2a = (r*dr/3.)*(ddens(ir+2)*(1.0+2*dr/r)+
     &        4*ddens(ir+1)*(1.0+dr/r)+ddens(ir))
         s2(ir) = s2a + s2(ir+2)
         rold = r
      enddo

      do ir = 2,nr,2
         r = ir*dr
         dpot(ir)=(4.*pi)*(s1(ir)+s2(ir))
         dfr(ir)=-(4.*pi)*s1(ir)/r
      enddo

      dpot(0)=3*(dpot(2)-dpot(4))+dpot(6)
      dfr(0)=0.0

c     then linearly interpolate other bins.

      do ir=1,nr-1,2
         dpot(ir)=(dpot(ir-1)+dpot(ir+1))/2.
         dfr(ir)=(dfr(ir-1)+dfr(ir+1))/2.
      enddo

      return
      end

      function diskforce(r)

      include 'commonblocks'
      common /diskestimate/ ddens(0:nmax),dpot(0:nmax),dfr(0:nmax)

      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      diskforce = (t*dfr(ihi)+ tm1*dfr(ihi-1))

      return
      end

      function diskdensity(r)

      include 'commonblocks'
      common /diskestimate/ ddens(0:nmax),dpot(0:nmax),dfr(0:nmax)

      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      diskdensity = (t*ddens(ihi)+ tm1*ddens(ihi-1))

      return
      end


subroutine test_obsens(xincr,xsens)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    test_obsens
!   prgmmr: tremolet
!
! abstract: Test accuracy of increment sensitivity to observations
!
! program history log:
!   2007-11-15  tremolet
!   2009-01-18  todling - carry summations in quad precision
!   2009-08-13  lueken - update documentation
!   2010-08-19  lueken - add only to module use;no machine code, so use .f90
!
!   input argument list:
!    xincr - current increment in control space
!    xsens - A_k^{-T}*xincr where A_k is the estimate of the Hessian
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
! ------------------------------------------------------------------------------
use kinds, only: i_kind,r_quad
use constants, only: zero
use jfunc, only: xhatsave
use obsmod, only: lsaveobsens,l_do_adjoint
use mpimod, only: mype
use obs_sensitivity, only: iobsconv, lobsensincr, dot_prod_obs
use control_vectors, only: control_vector,allocate_cv,deallocate_cv, &
    dot_product,assignment(=)
! ------------------------------------------------------------------------------
implicit none
type(control_vector), intent(in   ) :: xincr,xsens

real(r_quad) :: zx,zy,zb,zz,zcost
type(control_vector) :: gwork
integer(i_kind) :: nprt
logical :: lupdfgs

if (.not.(lobsensincr.or.iobsconv>0)) then
   write(6,*)'test_obsens: only for validation',lobsensincr,iobsconv
   call stop2(315)
end if

! Apply R^{-1} H and save output in obsdiags
if (iobsconv>0) then
   lsaveobsens=.true.
   l_do_adjoint=.false.
   nprt=1
   lupdfgs=.false.
   call allocate_cv(gwork)
   gwork=zero

   call evaljgrad(xsens,zcost,gwork,lupdfgs,nprt,'test_obsens')

   call deallocate_cv(gwork)
   lsaveobsens=.false.
   l_do_adjoint=.true.
endif

! Compute <dJ/dy,d>
zy=dot_prod_obs()

! Scalar products in control space
!    <dJ/dx,dx>=<dx,dx>
zx=dot_product(xincr,xincr,r_quad)
!    <A_k^{-1}dx,b_j>
zb=dot_product(xsens,xhatsave,r_quad)

! Observations impact validation
if (mype==0) then
   write(6,'(A)')'Incr sensitivity to obs. 0.123456789012345678'
   write(6,'(A,ES25.18)')'Incr sensit  <dF/dy,d>= ',zy
   write(6,'(A,ES25.18)')'Incr sensit  <b,dx>   = ',zb
   write(6,'(A,ES25.18)')'Incr sensit  <dx,dx>  = ',zx
   if ( abs(zx) > sqrt(tiny(zz)) ) then
      zz=abs((zy-zb-zx)/zx)
      write(6,'(A,ES25.18)')'Incr sensit  rel error= ',zz
   else
      zz=abs(zy-zb-zx)
      write(6,'(A,ES25.18)')'Incr sensit  abs error= ',zz
   endif
endif

return
end subroutine test_obsens


c     # ------------------------------------------------------------
c     # Compute edge centered and cell-centered velocity fields
c     #
c     # Edge : Compute velocity from a stream function.
c     # This defines the average velocity at each edge
c     #
c     #      u = curl \Psi  (div u = 0)
c     #
c     # Center : Defines cell-centered velocities from a streamfunction
c     #
c     #      u = n cross grad \Psi  (div u = 0)
c     #
c     # or using basis functions
c     #
c     #      u = u1*t1 + u2*t2   (div u might not be zero)
c     #
c     # NOTE: All arguments to routines here should be in computational
c     # coordinates (x,y) in [0,1]x[0,1].  Mapping from brick domains
c     # to [0,1]x[0,1] should be done from calling routines, as should
c     # any mappings that convert from an orthogonal coordinate system
c     # to a non-orthogonal system.
c     # ------------------------------------------------------------

c     # ------------------------------------------------------------
c     # Edge : u = \nabla cross \Psi - curl \Psi
c     # ------------------------------------------------------------
      subroutine torus_edge_velocity(x1,y1,x2,y2,ds,vn)
      implicit none

      double precision x1,y1,x2,y2, ds, vn, torus_psi

      vn = (torus_psi(x1,y1) - torus_psi(x2,y2))/ds

      end

c     # ------------------------------------------------------------
c     # Center : u = n cross grad \Psi   (div u = 0)
c     #
c     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
c     # ------------------------------------------------------------
      subroutine torus_center_velocity(x,y,vel)
      implicit none

      double precision x,y,vel(3)

      double precision t1(3), t2(3)
      double precision t1inv(3), t2inv(3)
      double precision nvec(3), gradpsi(3), sv

      double precision p, px, py
      double precision u(2)

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer use_stream
      common /velocity_comm/ use_stream

      integer k

      use_stream = 1
      if (example .eq. 0 .and. use_stream .eq. 1) then
c         # Divergence free velocity field : u = n cross \Psi
          call torus_psi_derivs(x,y,p,px,py)

          call torus_contravariant_basis(x,y, t1inv,t2inv)

          do k = 1,3
              gradpsi(k) = px*t1inv(k) + py*t2inv(k)
          end do

c         Outward directed normal
          call torus_cross(t1inv,t2inv,nvec,sv)

c         # Normalize surface normal
          do k = 1,3
              nvec(k) = nvec(k)/sv
          end do

c         # v = nvec x grad \Psi
          call torus_cross(nvec,gradpsi,vel,sv)
      else
c         # Vector field defined as u1*tau1 + u2*tau2

          call torus_covariant_basis(x, y, t1,t2)
          call torus_velocity_components(x,y,u)

          do k = 1,3
              vel(k) = u(1)*t1(k) + u(2)*t2(k)
          enddo
      endif

      end

      subroutine torus_covariant_basis(x,y,t1,t2)
      implicit none

      double precision x,y,t1(3),t2(3)
      double precision t(3,2),tinv(3,2), tderivs(3,2,2)
      integer flag, k

c     # Compute covariant derivatives only
      flag = 1
      call torus_basis_complete(x,y, t, tinv, tderivs, flag)

      do k = 1,3
          t1(k) = t(k,1)
          t2(k) = t(k,2)
      enddo

      end

      subroutine torus_contravariant_basis(x,y,t1inv,t2inv)
      implicit none

      double precision x,y
      double precision t1inv(3), t2inv(3)
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)
      integer k, flag

      flag = 3
      call torus_basis_complete(x,y, t, tinv,tderivs, flag)

      do k = 1,3
          t1inv(k) = tinv(k,1)
          t2inv(k) = tinv(k,2)
      end do

      end

c     # ----------------------------------------------------------------
c     # Utility functions
c     # ----------------------------------------------------------------

      subroutine torus_cross(u,v,uxv,w)
      implicit none

      double precision u(3),v(3),uxv(3),w, torus_dot

      uxv(1) =   u(2)*v(3) - u(3)*v(2)
      uxv(2) = -(u(1)*v(3) - u(3)*v(1))
      uxv(3) =   u(1)*v(2) - u(2)*v(1)

      w = torus_dot(uxv,uxv)
      w = sqrt(w)

      end

      double precision function torus_dot(u,v)
      implicit none

      double precision u(3),v(3)

      torus_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


*DECK QNG
      SUBROUTINE QNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL,
     +   IER)
C***BEGIN PROLOGUE  QNG
C***PURPOSE  The routine calculates an approximation result to a
C            given definite integral I = integral of F over (A,B),
C            hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A1A1
C***TYPE      SINGLE PRECISION (QNG-S, DQNG-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES,
C             NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C NON-ADAPTIVE INTEGRATION
C STANDARD FORTRAN SUBROUTINE
C REAL VERSION
C
C           F      - Real version
C                    Function subprogram defining the integrand function
C                    F(X). The actual name for F needs to be declared
C                    E X T E R N A L in the driver program.
C
C           A      - Real version
C                    Lower limit of integration
C
C           B      - Real version
C                    Upper limit of integration
C
C           EPSABS - Real
C                    Absolute accuracy requested
C           EPSREL - Real
C                    Relative accuracy requested
C                    If  EPSABS.LE.0
C                    And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                    The routine will end with IER = 6.
C
C         ON RETURN
C           RESULT - Real
C                    Approximation to the integral I
C                    Result is obtained by applying the 21-POINT
C                    GAUSS-KRONROD RULE (RES21) obtained by optimal
C                    addition of abscissae to the 10-POINT GAUSS RULE
C                    (RES10), or by applying the 43-POINT RULE (RES43)
C                    obtained by optimal addition of abscissae to the
C                    21-POINT GAUSS-KRONROD RULE, or by applying the
C                    87-POINT RULE (RES87) obtained by optimal addition
C                    of abscissae to the 43-POINT RULE.
C
C           ABSERR - Real
C                    Estimate of the modulus of the absolute error,
C                    which should EQUAL or EXCEED ABS(I-RESULT)
C
C           NEVAL  - Integer
C                    Number of integrand evaluations
C
C           IER    - IER = 0 normal and reliable termination of the
C                            routine. It is assumed that the requested
C                            accuracy has been achieved.
C                    IER.GT.0 Abnormal termination of the routine. It is
C                            assumed that the requested accuracy has
C                            not been achieved.
C           ERROR MESSAGES
C                    IER = 1 The maximum number of steps has been
C                            executed. The integral is probably too
C                            difficult to be calculated by DQNG.
C                        = 6 The input is invalid, because
C                            EPSABS.LE.0 AND
C                            EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28).
C                            RESULT, ABSERR and NEVAL are set to zero.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  QNG
C
      REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,EPSABS,EPSREL,F,FCENTR,
     1  FVAL,FVAL1,FVAL2,FV1,FV2,FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43,
     2  RES87,RESABS,RESASC,RESKH,R1MACH,SAVFUN,UFLOW,W10,W21A,W43A,
     3  W43B,W87A,W87B,X1,X2,X3,X4
      INTEGER IER,IPX,K,L,NEVAL
      EXTERNAL F
C
      DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22),
     1  W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23),
     2  SAVFUN(21)
C
C           THE FOLLOWING DATA STATEMENTS CONTAIN THE
C           ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED.
C
C           X1      ABSCISSAE COMMON TO THE 10-, 21-, 43-
C                   AND 87-POINT RULE
C           X2      ABSCISSAE COMMON TO THE 21-, 43- AND
C                   87-POINT RULE
C           X3      ABSCISSAE COMMON TO THE 43- AND 87-POINT
C                   RULE
C           X4      ABSCISSAE OF THE 87-POINT RULE
C           W10     WEIGHTS OF THE 10-POINT FORMULA
C           W21A    WEIGHTS OF THE 21-POINT FORMULA FOR
C                   ABSCISSAE X1
C           W21B    WEIGHTS OF THE 21-POINT FORMULA FOR
C                   ABSCISSAE X2
C           W43A    WEIGHTS OF THE 43-POINT FORMULA FOR
C                   ABSCISSAE X1, X3
C           W43B    WEIGHTS OF THE 43-POINT FORMULA FOR
C                   ABSCISSAE X3
C           W87A    WEIGHTS OF THE 87-POINT FORMULA FOR
C                   ABSCISSAE X1, X2, X3
C           W87B    WEIGHTS OF THE 87-POINT FORMULA FOR
C                   ABSCISSAE X4
C
      SAVE X1, X2, X3, X4, W10, W21A, W21B, W43A, W43B, W87A, W87B
      DATA X1(1),X1(2),X1(3),X1(4),X1(5)/
     1     0.9739065285171717E+00,     0.8650633666889845E+00,
     2     0.6794095682990244E+00,     0.4333953941292472E+00,
     3     0.1488743389816312E+00/
      DATA X2(1),X2(2),X2(3),X2(4),X2(5)/
     1     0.9956571630258081E+00,     0.9301574913557082E+00,
     2     0.7808177265864169E+00,     0.5627571346686047E+00,
     3     0.2943928627014602E+00/
      DATA X3(1),X3(2),X3(3),X3(4),X3(5),X3(6),X3(7),X3(8),
     1  X3(9),X3(10),X3(11)/
     2     0.9993333609019321E+00,     0.9874334029080889E+00,
     3     0.9548079348142663E+00,     0.9001486957483283E+00,
     4     0.8251983149831142E+00,     0.7321483889893050E+00,
     5     0.6228479705377252E+00,     0.4994795740710565E+00,
     6     0.3649016613465808E+00,     0.2222549197766013E+00,
     7     0.7465061746138332E-01/
      DATA X4(1),X4(2),X4(3),X4(4),X4(5),X4(6),X4(7),X4(8),X4(9),
     1  X4(10),X4(11),X4(12),X4(13),X4(14),X4(15),X4(16),X4(17),X4(18),
     2  X4(19),X4(20),X4(21),X4(22)/   0.9999029772627292E+00,
     3     0.9979898959866787E+00,     0.9921754978606872E+00,
     4     0.9813581635727128E+00,     0.9650576238583846E+00,
     5     0.9431676131336706E+00,     0.9158064146855072E+00,
     6     0.8832216577713165E+00,     0.8457107484624157E+00,
     7     0.8035576580352310E+00,     0.7570057306854956E+00,
     8     0.7062732097873218E+00,     0.6515894665011779E+00,
     9     0.5932233740579611E+00,     0.5314936059708319E+00,
     1     0.4667636230420228E+00,     0.3994248478592188E+00,
     2     0.3298748771061883E+00,     0.2585035592021616E+00,
     3     0.1856953965683467E+00,     0.1118422131799075E+00,
     4     0.3735212339461987E-01/
      DATA W10(1),W10(2),W10(3),W10(4),W10(5)/
     1     0.6667134430868814E-01,     0.1494513491505806E+00,
     2     0.2190863625159820E+00,     0.2692667193099964E+00,
     3     0.2955242247147529E+00/
      DATA W21A(1),W21A(2),W21A(3),W21A(4),W21A(5)/
     1     0.3255816230796473E-01,     0.7503967481091995E-01,
     2     0.1093871588022976E+00,     0.1347092173114733E+00,
     3     0.1477391049013385E+00/
      DATA W21B(1),W21B(2),W21B(3),W21B(4),W21B(5),W21B(6)/
     1     0.1169463886737187E-01,     0.5475589657435200E-01,
     2     0.9312545458369761E-01,     0.1234919762620659E+00,
     3     0.1427759385770601E+00,     0.1494455540029169E+00/
      DATA W43A(1),W43A(2),W43A(3),W43A(4),W43A(5),W43A(6),W43A(7),
     1  W43A(8),W43A(9),W43A(10)/      0.1629673428966656E-01,
     2     0.3752287612086950E-01,     0.5469490205825544E-01,
     3     0.6735541460947809E-01,     0.7387019963239395E-01,
     4     0.5768556059769796E-02,     0.2737189059324884E-01,
     5     0.4656082691042883E-01,     0.6174499520144256E-01,
     6     0.7138726726869340E-01/
      DATA W43B(1),W43B(2),W43B(3),W43B(4),W43B(5),W43B(6),
     1  W43B(7),W43B(8),W43B(9),W43B(10),W43B(11),W43B(12)/
     2     0.1844477640212414E-02,     0.1079868958589165E-01,
     3     0.2189536386779543E-01,     0.3259746397534569E-01,
     4     0.4216313793519181E-01,     0.5074193960018458E-01,
     5     0.5837939554261925E-01,     0.6474640495144589E-01,
     6     0.6956619791235648E-01,     0.7282444147183321E-01,
     7     0.7450775101417512E-01,     0.7472214751740301E-01/
      DATA W87A(1),W87A(2),W87A(3),W87A(4),W87A(5),W87A(6),
     1  W87A(7),W87A(8),W87A(9),W87A(10),W87A(11),W87A(12),
     2  W87A(13),W87A(14),W87A(15),W87A(16),W87A(17),W87A(18),
     3  W87A(19),W87A(20),W87A(21)/
     4     0.8148377384149173E-02,     0.1876143820156282E-01,
     5     0.2734745105005229E-01,     0.3367770731163793E-01,
     6     0.3693509982042791E-01,     0.2884872430211531E-02,
     7     0.1368594602271270E-01,     0.2328041350288831E-01,
     8     0.3087249761171336E-01,     0.3569363363941877E-01,
     9     0.9152833452022414E-03,     0.5399280219300471E-02,
     1     0.1094767960111893E-01,     0.1629873169678734E-01,
     2     0.2108156888920384E-01,     0.2537096976925383E-01,
     3     0.2918969775647575E-01,     0.3237320246720279E-01,
     4     0.3478309895036514E-01,     0.3641222073135179E-01,
     5     0.3725387550304771E-01/
      DATA W87B(1),W87B(2),W87B(3),W87B(4),W87B(5),W87B(6),W87B(7),
     1  W87B(8),W87B(9),W87B(10),W87B(11),W87B(12),W87B(13),W87B(14),
     2  W87B(15),W87B(16),W87B(17),W87B(18),W87B(19),W87B(20),
     3  W87B(21),W87B(22),W87B(23)/    0.2741455637620724E-03,
     4     0.1807124155057943E-02,     0.4096869282759165E-02,
     5     0.6758290051847379E-02,     0.9549957672201647E-02,
     6     0.1232944765224485E-01,     0.1501044734638895E-01,
     7     0.1754896798624319E-01,     0.1993803778644089E-01,
     8     0.2219493596101229E-01,     0.2433914712600081E-01,
     9     0.2637450541483921E-01,     0.2828691078877120E-01,
     1     0.3005258112809270E-01,     0.3164675137143993E-01,
     2     0.3305041341997850E-01,     0.3425509970422606E-01,
     3     0.3526241266015668E-01,     0.3607698962288870E-01,
     4     0.3669860449845609E-01,     0.3712054926983258E-01,
     5     0.3733422875193504E-01,     0.3736107376267902E-01/
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTEGRATION INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTEGRATION INTERVAL
C           FCENTR - FUNCTION VALUE AT MID POINT
C           ABSC   - ABSCISSA
C           FVAL   - FUNCTION VALUE
C           SAVFUN - ARRAY OF FUNCTION VALUES WHICH
C                    HAVE ALREADY BEEN COMPUTED
C           RES10  - 10-POINT GAUSS RESULT
C           RES21  - 21-POINT KRONROD RESULT
C           RES43  - 43-POINT RESULT
C           RES87  - 87-POINT RESULT
C           RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F)
C           RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  QNG
c      EPMACH = R1MACH(4)
c      UFLOW = R1MACH(1)

      epmach = 1.0e-30
      uflow = 1.0e-30
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      NEVAL = 0
      IER = 6
      IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.MAX(0.5E-14,0.5E+02*EPMACH))
     1  GO TO 80
      HLGTH = 0.5E+00*(B-A)
      DHLGTH = ABS(HLGTH)
      CENTR = 0.5E+00*(B+A)
      FCENTR = F(CENTR)
      NEVAL = 21
      IER = 1
C
C          COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA.
C
      DO 70 L = 1,3
      GO TO (5,25,45),L
    5 RES10 = 0.0E+00
      RES21 = W21B(6)*FCENTR
      RESABS = W21B(6)*ABS(FCENTR)
      DO 10 K=1,5
        ABSC = HLGTH*X1(K)
        FVAL1 = F(CENTR+ABSC)
        FVAL2 = F(CENTR-ABSC)
        FVAL = FVAL1+FVAL2
        RES10 = RES10+W10(K)*FVAL
        RES21 = RES21+W21A(K)*FVAL
        RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2))
        SAVFUN(K) = FVAL
        FV1(K) = FVAL1
        FV2(K) = FVAL2
   10 CONTINUE
      IPX = 5
      DO 15 K=1,5
        IPX = IPX+1
        ABSC = HLGTH*X2(K)
        FVAL1 = F(CENTR+ABSC)
        FVAL2 = F(CENTR-ABSC)
        FVAL = FVAL1+FVAL2
        RES21 = RES21+W21B(K)*FVAL
        RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2))
        SAVFUN(IPX) = FVAL
        FV3(K) = FVAL1
        FV4(K) = FVAL2
   15 CONTINUE
C
C          TEST FOR CONVERGENCE.
C
      RESULT = RES21*HLGTH
      RESABS = RESABS*DHLGTH
      RESKH = 0.5E+00*RES21
      RESASC = W21B(6)*ABS(FCENTR-RESKH)
      DO 20 K = 1,5
        RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH))
     1                  +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH))
   20 CONTINUE
      ABSERR = ABS((RES21-RES10)*HLGTH)
      RESASC = RESASC*DHLGTH
      GO TO 65
C
C          COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA.
C
   25 RES43 = W43B(12)*FCENTR
      NEVAL = 43
      DO 30 K=1,10
        RES43 = RES43+SAVFUN(K)*W43A(K)
   30 CONTINUE
      DO 40 K=1,11
        IPX = IPX+1
        ABSC = HLGTH*X3(K)
        FVAL = F(ABSC+CENTR)+F(CENTR-ABSC)
        RES43 = RES43+FVAL*W43B(K)
        SAVFUN(IPX) = FVAL
   40 CONTINUE
C
C          TEST FOR CONVERGENCE.
C
      RESULT = RES43*HLGTH
      ABSERR = ABS((RES43-RES21)*HLGTH)
      GO TO 65
C
C          COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA.
C
   45 RES87 = W87B(23)*FCENTR
      NEVAL = 87
      DO 50 K=1,21
        RES87 = RES87+SAVFUN(K)*W87A(K)
   50 CONTINUE
      DO 60 K=1,22
        ABSC = HLGTH*X4(K)
        RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC))
   60 CONTINUE
      RESULT = RES87*HLGTH
      ABSERR = ABS((RES87-RES43)*HLGTH)
   65 IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00)
     1  ABSERR = RESASC*MIN(0.1E+01,
     2  (0.2E+03*ABSERR/RESASC)**1.5E+00)
      IF (RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX
     1  ((EPMACH*0.5E+02)*RESABS,ABSERR)
      IF (ABSERR.LE.MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0
C ***JUMP OUT OF DO-LOOP
      IF (IER.EQ.0) GO TO 999
   70 CONTINUE
   80 CALL XERMSG ('SLATEC', 'QNG', 'ABNORMAL RETURN', IER, 0)
  999 RETURN
      END


SUBROUTINE lnsrch_sp(xold,fold,g,p,x,f,stpmax,check,func)

  use mo_kind,   only: sp, i4, lgt
  use mo_nrutil, only: assert_eq,nrerror,vabs

  IMPLICIT NONE

  REAL(SP), DIMENSION(:), INTENT(IN)    :: xold,g
  REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
  REAL(SP),               INTENT(IN)    :: fold,stpmax
  REAL(SP), DIMENSION(:), INTENT(OUT)   :: x
  REAL(SP),               INTENT(OUT)   :: f
  LOGICAL(lgt),           INTENT(OUT)   :: check

  INTERFACE
     FUNCTION func(x)
       use mo_kind, only: sp
       IMPLICIT NONE
       REAL(SP)                           :: func
       REAL(SP), DIMENSION(:), INTENT(IN) :: x
     END FUNCTION func
  END INTERFACE

  REAL(SP), PARAMETER :: ALF=1.0e-4_sp,TOLX=epsilon(x)
  INTEGER(I4)         :: ndum
  REAL(SP)            :: a,alam,alam2,alamin,b,disc,f2,fold2
  REAL(SP)            :: pabs,rhs1,rhs2,slope,tmplam

  ndum=assert_eq(size(g),size(p),size(x),size(xold),'lnsrch')
  check=.false.
  pabs=vabs(p(:))
  if (pabs > stpmax) p(:)=p(:)*stpmax/pabs
  slope=dot_product(g,p)
  alamin=TOLX/maxval(abs(p(:))/max(abs(xold(:)),1.0_sp))
  alam=1.0_sp
  do
     x(:)=xold(:)+alam*p(:)
     f=func(x)
     if (alam < alamin) then
        x(:)=xold(:)
        check=.true.
        RETURN
     else if (f <= fold+ALF*alam*slope) then
        RETURN
     else
        if (alam == 1.0_sp) then
           tmplam=-slope/(2.0_sp*(f-fold-slope))
        else
           rhs1=f-fold-alam*slope
           rhs2=f2-fold2-alam2*slope
           a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
           b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/&
                (alam-alam2)
           if (a == 0.0_sp) then
              tmplam=-slope/(2.0_sp*b)
           else
              disc=b*b-3.0_sp*a*slope
              if (disc < 0.0_sp) call nrerror('roundoff problem in lnsrch')
              tmplam=(-b+sqrt(disc))/(3.0_sp*a)
           end if
           if (tmplam > 0.5_sp*alam) tmplam=0.5_sp*alam
        end if
     end if
     alam2=alam
     f2=f
     fold2=fold
     alam=max(tmplam,0.1_sp*alam)
  end do
END SUBROUTINE lnsrch_sp

SUBROUTINE lnsrch_dp(xold,fold,g,p,x,f,stpmax,check,func)

  use mo_kind,   only: dp, i4, lgt
  use mo_nrutil, only: assert_eq,nrerror,vabs

  IMPLICIT NONE

  REAL(DP), DIMENSION(:), INTENT(IN)    :: xold,g
  REAL(DP), DIMENSION(:), INTENT(INOUT) :: p
  REAL(DP),               INTENT(IN)    :: fold,stpmax
  REAL(DP), DIMENSION(:), INTENT(OUT)   :: x
  REAL(DP),               INTENT(OUT)   :: f
  LOGICAL(lgt),           INTENT(OUT)   :: check

  INTERFACE
     FUNCTION func(x)
       use mo_kind, only: dp
       IMPLICIT NONE
       REAL(DP)                           :: func
       REAL(DP), DIMENSION(:), INTENT(IN) :: x
     END FUNCTION func
  END INTERFACE

  REAL(DP), PARAMETER :: ALF=1.0e-4_dp,TOLX=epsilon(x)
  INTEGER(I4)         :: ndum
  REAL(DP)            :: a,alam,alam2,alamin,b,disc,f2,fold2
  REAL(DP)            :: pabs,rhs1,rhs2,slope,tmplam

  ndum=assert_eq(size(g),size(p),size(x),size(xold),'lnsrch')
  check=.false.
  pabs=vabs(p(:))
  if (pabs > stpmax) p(:)=p(:)*stpmax/pabs
  slope=dot_product(g,p)
  alamin=TOLX/maxval(abs(p(:))/max(abs(xold(:)),1.0_dp))
  alam=1.0_dp
  do
     x(:)=xold(:)+alam*p(:)
     f=func(x)
     if (alam < alamin) then
        x(:)=xold(:)
        check=.true.
        RETURN
     else if (f <= fold+ALF*alam*slope) then
        RETURN
     else
        if (alam == 1.0_dp) then
           tmplam=-slope/(2.0_dp*(f-fold-slope))
        else
           rhs1=f-fold-alam*slope
           rhs2=f2-fold2-alam2*slope
           a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
           b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/&
                (alam-alam2)
           if (a == 0.0_dp) then
              tmplam=-slope/(2.0_dp*b)
           else
              disc=b*b-3.0_dp*a*slope
              if (disc < 0.0_dp) call nrerror('roundoff problem in lnsrch')
              tmplam=(-b+sqrt(disc))/(3.0_dp*a)
           end if
           if (tmplam > 0.5_dp*alam) tmplam=0.5_dp*alam
        end if
     end if
     alam2=alam
     f2=f
     fold2=fold
     alam=max(tmplam,0.1_dp*alam)
  end do
END SUBROUTINE lnsrch_dp


      program dc
      double complex a, b, c, d, e, f, g, h
      double precision x
      complex w, z

      a = (1.0,1.0)
      b = 1
      c = 1.0e0
      d = 1.0d0

      e = a + b
      f = COS(e)
      x = ABS(f)
      f = DCMPLX(x)
      h = LOG(g) + SQRT(f) + SIN(e) + EXP(a)

      print *, h

      w = (1.0, 1.0)
      z = w + 1

      w = CMPLX(1.0, 1.0)
      z = w + 1

      end


      SUBROUTINE ksone(data,n,func,d,prob)
      INTEGER n
      REAL d,data(n),func,prob
      EXTERNAL func
CU    USES probks,sort
      INTEGER j
      REAL dt,en,ff,fn,fo,probks
      call sort(n,data)
      en=n
      d=0.
      fo=0.
      do 11 j=1,n
        fn=j/en
        ff=func(data(j))
        dt=max(abs(fo-ff),abs(fn-ff))
        if(dt.gt.d)d=dt
        fo=fn
11    continue
      en=sqrt(en)
      prob=probks((en+0.12+0.11/en)*d)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ksone.for


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

program sys_sim101

! NOTE: THIS ACTUALLY MINIMIZES THE SQUARE ERROR! MAY WORK WELL, BUT NOT
! NECESSARILY RIGHT QUESTION. GET 1/(x**2 + 1) for the alpha where x
! is the ratio of s.d. to sample mean. Use a single enseble member to
! get appropriate results.
! A look at sampling errors for regression coefficients for ensemble filters
! designed to help with localization from multiple ensembles. Notes (if they
! exist) from late August 2003 describe the problem in more detail. Here, we
! ask the question, if a distance to move comes from a distibution with
! a given ratio of standard deviation to value, when a given size sample
! is used to evaluate this, how should the resulting distance be scaled
! to extract the most useful information.
!

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

implicit none

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

type (random_seq_type) :: r
double precision :: sd_ratio, mean_move, mean_move_2, alpha
double precision, allocatable :: rnum(:), var_hist(:)
double precision :: sample_sigma_y_p
double precision :: c(2, 2), sum_err_var, sigma_y_p, sigma_y_o, sigma_x_p
double precision :: y_truth, y_o, sample_correl, reg_coef, sample_reg_coef
double precision :: sigma_y_u, y_u, sigma_x_u, x_u, sample_x_u, x_error
double precision :: x_error_var, total_err_var, mean(2), correl, est_err_var
double precision :: temp_sum, pe_2_sum, xx, s_xx, s_xx_2, xx_mean, xx_var
double precision, allocatable :: sample_mean(:), x_var(:)
double precision :: sum_sample_mean, sum_sample_sigma, sum_y_u, sum_sigma_y_u, sum_y_u_2
double precision :: sum_err, sum_err_2, inf_sigma_y_u, var_mean, var_var
integer :: n, i, j, n_samples, index

! Initialize repeatable random sequence
call init_random_seq(r)

! Free parameters are ratio and ensemble size
! Just assume that base value is 1.0 (move is 1.0); can't do case where expected move is 0
! but know the answer to this case (DON"T MOVE!)
write(*, *) 'Input ratio of ensemble standard deviation to mean'
read(*, *) sd_ratio
write(*, *) 'Input group size, NORMALLY 1 for this problem'
read(*, *) n
write(*, *) 'Input number of samples for statistics'
read(*, *) n_samples

! Allocate storage for the sample means
allocate(sample_mean(n_samples), rnum(n))

! Loop through the number of samples
do i = 1, n_samples

! Need an ensemble sized sample of the recursion value
   do j = 1, n
      rnum(j) = random_gaussian(r, dble(1.0), sd_ratio)
   end do

! Compute the sample mean and variance
   call sample_mean_var(rnum, n, sample_mean(i), sample_sigma_y_p)
end do

! Need the sum of the squared sample_mean and sum of the sample mean
mean_move = sum(sample_mean)
mean_move_2 = sum(sample_mean**2)

! Expected value of alpha to minimize squared difference between sample and actual value
alpha = 1.0 * mean_move / mean_move_2

write(*, *) 'alpha is ', alpha

end program sys_sim101

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

subroutine comp_correl(ens, n, correl)

implicit none

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

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

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

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

end subroutine comp_correl

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

subroutine sample_mean_var(x, n, mean, var)

implicit none

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

double precision :: sx, s_x2

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

end subroutine sample_mean_var

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


module ad_types

    use ad_kinds, only: rk
    implicit none
    private

    public :: tree_t, assignment(=)

    !> Linked list node
    type node_t

        real(rk) :: value  !! value of the node
        real(rk) :: grad = 0.0_rk   !! gradient of this node

        type(node_t), pointer :: left => null()
        real(rk), allocatable :: left_grad  !! gradient of the left node

        type(node_t), pointer :: right => null()
        real(rk), allocatable :: right_grad  !! gradient of the right node

    contains

        procedure :: backward => node_t_backward
        procedure :: destructor => node_t_destructor

    end type node_t

    !> Linked tree
    type tree_t
        type(node_t), pointer :: node => null()
    contains
        procedure :: backward => tree_t_backward
        procedure :: get_value => tree_t_get_value
        procedure :: get_grad => tree_t_get_grad
        procedure :: destructor => tree_t_destructor
        final :: final_destructor
    end type tree_t

    interface assignment(=)
        module procedure :: tree_t_assignment
    end interface assignment(=)

    interface tree_t
        module procedure :: tree_t_constructor
    end interface tree_t

contains

    elemental function node_t_constructor(value) result(return_node)
        real(rk), intent(in) :: value
        type(node_t) :: return_node

        return_node%value = value

    end function node_t_constructor

    elemental subroutine tree_t_assignment(self, value)
        type(tree_t), intent(inout) :: self
        real(rk), intent(in) :: value

        allocate (self%node, source=node_t_constructor(value))

    end subroutine tree_t_assignment

    elemental function tree_t_constructor(value) result(return_tree)
        real(rk), intent(in) :: value
        type(tree_t) :: return_tree

        call tree_t_assignment(return_tree, value)

    end function tree_t_constructor

    elemental subroutine tree_t_backward(self)
        class(tree_t), intent(inout) :: self

        associate (node => self%node)

            node%grad = 1.0_rk

            if (associated(node%left)) &
                call node%left%backward(node%left_grad)
            if (associated(node%right)) &
                call node%right%backward(node%right_grad)

        end associate

    end subroutine tree_t_backward

    elemental subroutine node_t_backward(self, out)
        class(node_t), intent(inout) :: self
        real(rk), intent(in) :: out

        self%grad = self%grad + out

        if (associated(self%left)) call self%left%backward(out*self%left_grad)
        if (associated(self%right)) call self%right%backward(out*self%right_grad)

    end subroutine node_t_backward

    elemental function tree_t_get_value(self) result(value)
        class(tree_t), intent(in) :: self
        real(rk) :: value

        value = self%node%value

    end function tree_t_get_value

    elemental function tree_t_get_grad(self) result(grad)
        class(tree_t), intent(in) :: self
        real(rk) :: grad

        grad = self%node%grad

    end function tree_t_get_grad

    elemental subroutine tree_t_destructor(self)
        class(tree_t), intent(inout) :: self

        if (associated(self%node)) then
            call self%node%destructor()
            nullify (self%node)  ! @note: Not sure if this will ocurr memory leak
        end if

    end subroutine tree_t_destructor

    ! - GFortran >= 11.0
    ! - Intel Fortran >= 2019
    ! or report an error: ELEMENTAL attribute conflicts with RECURSIVE attribute.
    elemental recursive subroutine node_t_destructor(self)
        class(node_t), intent(inout) :: self

        if (associated(self%left)) then
            call self%left%destructor()
            nullify (self%left)  ! @note: Not sure if this will ocurr memory leak
        end if

        if (associated(self%right)) then
            call self%right%destructor()
            nullify (self%right) ! @note: Not sure if this will ocurr memory leak
        end if

    end subroutine node_t_destructor

    elemental subroutine final_destructor(self)
        type(tree_t), intent(inout) :: self

        call self%destructor()

    end subroutine final_destructor

end module ad_types


! Program to test the ANY and ALL intrinsics
program anyall
   implicit none
   logical, dimension(3, 3) :: a
   logical, dimension(3) :: b
   character(len=10) line

   a = .false.
   if (any(a)) call abort
   a(1, 1) = .true.
   a(2, 3) = .true.
   if (.not. any(a)) call abort
   b = any(a, 1)
   if (.not. b(1)) call abort
   if (b(2)) call abort
   if (.not. b(3)) call abort
   b = .false.
   write (line, 9000) any(a,1)
   read (line, 9000) b
   if (.not. b(1)) call abort
   if (b(2)) call abort
   if (.not. b(3)) call abort

   a = .true.
   if (.not. all(a)) call abort
   a(1, 1) = .false.
   a(2, 3) = .false.
   if (all(a)) call abort
   b = all(a, 1)
   if (b(1)) call abort
   if (.not. b(2)) call abort
   if (b(3)) call abort
   b = .false.
   write (line, 9000) all(a,1)
   read (line, 9000) b
   if (b(1)) call abort
   if (.not. b(2)) call abort
   if (b(3)) call abort

9000 format (9L1)
end program


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2019 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program frank_matrix
  use rokko
  implicit none
  integer :: dim
  type(rokko_eigen_matrix) :: mat
  double precision, allocatable :: array(:,:)
  double precision :: val
  integer :: i, j

  dim = 10
  print *,"dimension = ", dim
  allocate( array(dim, dim) )

  call rokko_construct(mat, array, rokko_matrix_col_major)

  ! generate frank matrix
  do i = 1, dim
     do j = 1, dim
        val = dble(dim+1 - max(i, j))
        array(i, j) = val
     enddo
  enddo
  call rokko_print(mat)

  call rokko_destruct(mat)

end program frank_matrix


PROGRAM kinds

  !Don't have to USE, INTRINSIC, can just USE but INTRINSIC
  !means that the compiler won't try to use one of your
  !modules
  USE, INTRINSIC :: ISO_FORTRAN_ENV
  IMPLICIT NONE

  INTEGER(INT8) :: i1
  INTEGER(INT16) :: i2
  INTEGER(INT32) :: i3
  INTEGER(INT64) :: i4
  REAL(REAL32) :: r1
  REAL(REAL64) :: r2
  REAL(REAL128) :: r3

  !Print the largest number that can be held in each variable
  PRINT *, HUGE(i1)
  PRINT *, HUGE(i2)
  PRINT *, HUGE(i3)
  PRINT *, HUGE(i4)
  PRINT *, HUGE(r1)
  PRINT *, HUGE(r2)
  PRINT *, HUGE(r3)

END PROGRAM kinds


module module_globals
  implicit none

  integer,parameter :: ndim=2 !< 次元
  real(8),parameter :: pi=acos(-1.d0) !< pi
  real(8),parameter :: tiny=epsilon(1.d0) !< 小さい数

  logical,parameter :: true=.true.
  logical,parameter :: false=.false.

end module module_globals


c***********************************************************************
c> \file norrcolchan.f
c> \brief Solves the Orr-Sommerfeld equation for incompressible
c>        planar channel flow (outmoded version keep for reference)
c> \author S. Scott Collis
      program Orr_col
c***********************************************************************
c
c     Purpose:  This program solves the Orr-Sommerfeld equation using a
c               Chebyshev-collocation method for channel flow.
c
c     Author:   S. Scott Collis
c
c     Date:     2-29-92
c
c     Revision: 9-18-92
c
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real        alphar, alphai
c
c     Setup IMSL workspace
c
      REAL             RWKSP(200000)
      COMMON /WORKSP/  RWKSP
      call IWKIN(200000)
c
c     User input
c
      write (*,10)
  10  format (/,/,10x,'Solve Orr-Sommerfeld (Collocation)')
      write (*,20)
  20  format (/,1x,'Enter the number of modes ==> ',$)
      read (*,*) n
      write (*,30)
  30  format (/,1x,'Enter Reynolds number ==> ',$)
      read (*,*) Re
      write (*,40)
  40  format (/,1x,'Enter alpha (R,I) ==> ',$)
      read (*,*) alphar, alphai

      alpha = cmplx (alphar, alphai)

      call MAKE_DERIVATIVES
      call MAKE_CHANNEL_METRICS

      call INIT_CHANNEL_PROFILE

      call MAKE_MATRIX
      call SOLVE_ORR_SOM

      stop
      end

C***********************************************************************
      subroutine MAKE_DERIVATIVES
C***********************************************************************
C
C     Make the required matrices that take derivatives in Chebyshev
C     space
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      integer  LDD, i, j, k
      real     D1hat(0:idim,0:idim)

      LDD = idim
      call CHEBYD (D1hat, LDD, n)
      call CHEBYD (D1   , LDD, n)
c
c     We enforce the Neumann boundary conditions indirectly by setting
c     v' = 0 at 0 and n.  NOTE THAT D1-D4 SHOULD ONLY BE APPLIED TO THE
c     v FIELD ONLY.
c
      do i = 0, n
        D1(0,i) = 0.0
        D1(N,i) = 0.0
      end do
C
C     To get higher derivatives just do matrix multiplication
C
      do i = 0, n
        do j = 0, n
          D2(i,j) = 0.0
          do k = 0, n
            D2(i,j) = D2(i,j) +  D1hat(i,k)*D1(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D3(i,j) = 0.0
          do k = 0, n
            D3(i,j) = D3(i,j) +  D1hat(i,k)*D2(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D4(i,j) = 0.0
          do k = 0, n
            D4(i,j) = D4(i,j) +  D1hat(i,k)*D3(k,j)
          end do
        end do
      end do

c      CALL WRRRN ('D1', N+1, N+1, D1, LDd+1, 0)
c      CALL WRRRN ('D2', N+1, N+1, D2, LDd+1, 0)
c      CALL WRRRN ('D3', N+1, N+1, D3, LDd+1, 0)
c      CALL WRRRN ('D4', N+1, N+1, D4, LDd+1, 0)

      return
      end

C***********************************************************************
      subroutine MAKE_CHANNEL_METRICS
C***********************************************************************
C
C     Setup the collocation points in the mapped coordinate, eta and in
C     chebyshev space, th.  Also compute the transformation metrics.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real       pi, dth
      integer    i

      pi  = ACOS(-1.0)
      dth = pi/FLOAT(n)
c
c     Make mesh in transformed, eta, and Chebyshev space, th
c
      do i = 0, n
        th(i) = FLOAT(i)*dth
        eta(i) = COS(th(i))
      end do

      return
      end

C***********************************************************************
      subroutine INIT_CHANNEL_PROFILE
C***********************************************************************
C
C     Setup the initial channel profile
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      integer     i, LDD
      real        D1hat(0:idim,0:idim), D2hat(0:idim,0:idim)

      LDD = idim

      do i = 0, n
        u(i) = (1.-eta(i)**2)
      end do
c
c     Compute the collocation derivatives
c
      call CHEBYD (D1hat, LDD, n)
c     CALL WRRRN ('D1hat', N+1, N+1, D1hat, LDd+1, 0)
      do i = 0, n
        do j = 0, n
          D2hat(i,j) = 0.0
          do k = 0, n
            D2hat(i,j) = D2hat(i,j) +  D1hat(i,k)*D1hat(k,j)
          end do
        end do
      end do
      do i = 0, n
        d1u(i) = 0.0
        d2u(i) = 0.0
        do k = 0, n
            d1u(i) = d1u(i) + D1hat(i,k)*u(k)
            d2u(i) = d2u(i) + D2hat(i,k)*u(k)
        end do
c        write (*,10) eta(i), u(i), d1u(i), d2u(i)
c  10    format (1x,4(e12.4,1x))
      end do

      return
      end

C***********************************************************************
      subroutine MAKE_MATRIX
C***********************************************************************
C
C     This routine generates the matrices which are combined to make
C     the generalized eigenvalue problem.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real      identity(0:idim,0:idim)
      complex   work

      do i = 0, n
        do j = 0, n
          A4(i,j) = 0.0
          A3(i,j) = 0.0
          A2(i,j) = 0.0
          A1(i,j) = 0.0
          B2(i,j) = 0.0
          B1(i,j) = 0.0
          B0(i,j) = 0.0
          identity(i,j) = 0.0
        end do
        identity(i,i) = 1.0
      end do

      do i = 0, n
        do j = 0, n
          A4(i,j) = CMPLX( D4(i,j), 0.0 )
        end do
      end do

      do i = 0, n
        work = -2.0 * alpha**2 - cmplx(0.,1.)*alpha*Re*U(i)
        do j = 0, n
          A2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**4 + cmplx(0.,1.)*alpha**3*Re*U(i) +
     .                    cmplx(0.,1.)*alpha*Re*d2u(i)
        do j = 0, n
          A0(i,j) = work*identity(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re
        do j = 0, n
          B2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**2*cmplx(0.,1.)*Re
        do j = 0, n
          B0(i,j) = work*identity(i,j)
        end do
      end do

      return
      end

C***********************************************************************
      subroutine SOLVE_ORR_SOM
C***********************************************************************
C
C     This routine generates the discrete eigenvalue problem in
C     Chebyshev space for the Orr-Sommerfeld equation.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=128)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      complex     A(0:idim,0:idim), B(0:idim,0:idim)
      complex     T1(0:idim,0:idim), T4(0:idim,0:idim)
      complex     evec(0:idim,0:idim), eval(0:idim)
      real        temp1(0:idim), temp2(0:idim), CHECKEIG
      integer     lda, ldb, ldevec, i, j, which
      complex     eigenvalue, eigenvector(0:idim)
      external    CHECKEIG
C***********************************************************************
      lda = idim+1
      ldb = idim+1
      ldevec = idim+1

      do i = 1, n-1
        do j = 1, n-1
          A(i-1,j-1) = A4(i,j)+A3(i,j)+A2(i,j)+A1(i,j)+A0(i,j)
          B(i-1,j-1) = B2(i,j)+B1(i,j)+B0(i,j)
        end do
      end do
c
c     Now enforce the v = 0 @ +_ 1 boundary condition instead of the
c     Orr-Sommerfeld equation at n = 0 and n = N.  The Neumann
c     boundary condition is implicitly enforced.
c
c      do j = 0, n
c        B(0,j) = CMPLX(0.0, 0.0)
c        B(n,j) = CMPLX(0.0, 0.0)
c        A(0,j) = CMPLX(0.0, 0.0)
c        A(n,j) = CMPLX(0.0, 0.0)
c      end do
c      A(0,0) = CMPLX(1.0, 0.0)
c      A(n,n) = CMPLX(1.0, 0.0)
c
c     But the top and bottom rows are trivial so that they can be
c     removed
c
      CALL DLINCG (N-1, B, LDA, T1, LDA)
      CALL DMCRCR (N-1, N-1, T1, LDA, N-1, N-1, A, LDA,
     .            N-1, N-1, T4, LDA)

      CALL DEVCCG (N-1, T4, LDA, eval, evec, ldevec)

      write (*,50) N+1
  50  format (/,1x,'Eigenvalues for N+1 = ',i4,/)
c
c     Print eigenvalues
c
      do i = 0, N-2
        omega(i) = eval(i)
        write (*,35) REAL(omega(i)), AIMAG(omega(i)), i
  35    format (1x,2(e17.10,4x),i5)
      end do

      write (*,40)
      read (*,*) which
      do while (which .ne. -1)

        eigenvalue = eval(which)
        do i = 0, N-2
          eigenvector(i) = evec(i,which)
        end do
        write (*,*) CHECKEIG (N-1,T4,lda,eigenvalue,eigenvector)

        temp1(0) = 0.
        temp2(0) = 0.
        temp1(n) = 0.
        temp2(n) = 0.
        do i = 1, n-1
          temp1(i) = REAL(evec(i-1,which))
          temp2(i) = AIMAG(evec(i-1,which))
        end do

c        call CHEBYSHEV (temp1,n,1)
c        call CHEBYSHEV (temp2,n,1)
c        do i = 0, n
c          write (*,999) i, temp1(i), temp2(i)
c 999      format (1x,i5,2x,2(e12.5,2x))
c        end do

        call CHEBYINT (n, temp1, temp2, 256)
        write (*,40)
        read (*,*) which
      end do
 40   format (/,1x,'Eigenvector for which eigenvalue (-1 quits) ==> ',$)

      return
      end
C***********************************************************************
      function CHECKEIG(N,A,LDA,EVAL,EVEC)
C***********************************************************************
C
C     Check an eigenvalue and eigenvector
C
C***********************************************************************
      PARAMETER (idim=128)

      integer    N
      complex    A(LDA,N), EVAL, EVEC(N)
      complex    X(idim)
      real       CHECKEIG
#ifdef USE_IMSL
      CALL MUCRV (N, N, A, LDA, N, EVEC, 1, N, X)
#else
      CALL ZGEMV ('N', N, N, 1.0, A, LDA, EVEC, 1, 0.0, X, 1)
#endif
      CHECKEIG = 0.0
      DO I = 1, N
        CHECKEIG = CHECKEIG + ABS(X(I)-EVAL*EVEC(I))
      END DO
      CHECKEIG = CHECKEIG/DFLOAT(N)

      RETURN
      END
C***********************************************************************
      SUBROUTINE DCHEBYSHEV(N, Y, DY)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and compute the derivative in Chebyshev space.
C     Then inverse transform and return the derivative in DY in real
C     space.  Note that Y is returned unscathed.
C
C***********************************************************************
      INTEGER N
      REAL Y(0:N), DY(0:N)

      PARAMETER (idim=128)
      REAL WORK(0:IDIM)

      IF (N.GT.IDIM) THEN
        WRITE (*,*) 'ERROR.  N > IDIM in DCHEBYSHEV'
        STOP
      END IF
C
C     SAVE THE INPUT VECTOR
C
      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      DY(N) = 0.0
      DY(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        DY(K) = DY(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      DY(0) = DY(0)/2.
C
C     INVERSE TRANSFORM TO GET BACK TO REAL SPACE
C
      CALL CHEBYSHEV(DY,N,-1)

      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE ICHEBYSHEV(Y,YI,N)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and integrate in Chebyshev space.  The integral is
C     returned in real space in YI and Y is unscathed.
C
C***********************************************************************
      REAL Y(0:N), YI(0:N+1)
      PARAMETER (idim=128)
      REAL WORK(0:IDIM)

      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW INTEGRATE
C     NOTE I AM ASSUMING THAT Y(N) IS SMALL SUCH THAT YI(N+1) = 0.0
C
      YI(N+1) = Y(N)/(2.*(N+1.))
      YI(N) = Y(N-1)/(2.*N)
      YI(1) = 1./2.*(2.*Y(0)-Y(2))
      YI(0) = YI(1)
      DO K = 2, N-1
        YI(K) = 1./(2.*K)*(Y(K-1)-Y(K+1))
        YI(0) = YI(0) + (-1.)**(K-1)*YI(K)
      END DO

      CALL CHEBYSHEV(YI,N,-1)
      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE CHEBYINT(nmode,U,V,NBIG)
C***********************************************************************
C
C     Interpolate two functions to a finer mesh
C
c***********************************************************************
      INTEGER   NBIG, nmode
      REAL      U(0:Nmode), V(0:Nmode)
      REAL      IU, IV, X, PI

      PI = ACOS(-1.0)

      call CHEBYSHEV (U,nmode,1)
      call CHEBYSHEV (V,nmode,1)

      do i = 0, NBIG
        X = I*PI/NBIG
        IU = 0.0
        IV = 0.0
        DO M = 0, Nmode
          IU = IU + U(M)*COS(FLOAT(M)*X)
          IV = IV + V(M)*COS(FLOAT(M)*X)
        END DO
        write (*,10) cos(x),Iu,Iv
      end do
  10  format (1x,3(e16.8,4x))

      RETURN
      END

C***********************************************************************
      subroutine CHEBYSHEV (Y, N, ISIGN)
C***********************************************************************
C
C     Take the Chebyshev transform and normalize
C
C***********************************************************************
      integer  n, isign
      real     y(0:n), t(0:256)

      if (isign .ne. 1) then
        if (isign .ne. -1) then
          write (*,*) 'ERROR:  Invalid Isign in CHEBYSHEV'
          stop
        end if
      end if

      do i = 1, n
        t(i) = y(i)
      end do

      call COSFT3 (y,n,isign)

      return
      end

C**************************************************************************
      SUBROUTINE CHEBYD (D, LDD1, N)
C**************************************************************************
C
C     Calculation the Chebyshev collocation derivative matrix
C
C**************************************************************************
      PARAMETER (IDIM=256)
      REAL      D(0:LDD1,0:N), PI
      REAL      C(0:IDIM)

      IF (N .GT. IDIM) THEN
        WRITE (*,*) 'ERROR:  N > IDIM in CHEBYD'
        STOP
      END IF

      PI = ACOS(-1.0)

      DO I = 1, N-1
        C(I) = 1.0
      END DO
      C(0) = 2.0
      C(N) = 2.0

      DO J = 0, N
        DO K = 0, N
          IF ( J.EQ.0 .AND. K.EQ.0) THEN
            D(J,K) = (2.0*FLOAT(N)**2+1.0)/6.0
          ELSE IF ( J.EQ.N .AND. K.EQ.N) THEN
            D(J,K) = -1.0*(2.*FLOAT(N)**2+1.0)/6.0
          ELSE IF (J.EQ.K) THEN
            D(J,K) =  -1.0*COS(FLOAT(J)*PI/FLOAT(N))/
     .                (2.*(1.-(COS(FLOAT(J)*PI/FLOAT(N)))**2))
          ELSE
            D(J,K) = C(J)*(-1.0)**(J+K)/(C(K)*(COS(FLOAT(J)*PI/
     .               FLOAT(N))-COS(FLOAT(K)*PI/FLOAT(N))))
          END IF
        END DO
      END DO

      RETURN
      END
C*************************************************************************
C
C     These routines are for READ_BL only!
C
C*************************************************************************
      SUBROUTINE DCHEBYSHEVF(Y,YP,N)
C*************************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued data
C     points and compute the derivative in Chebyshev space.  Then inverse
C     transform and return the derivative in YP and the chebyshev
C     coefficients of the derivative in Y.
C
C************************************************************************
      DIMENSION Y(0:N), YP(0:N)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      YP(N) = 0.0
      YP(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        YP(K) = YP(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      YP(0) = YP(0)/2.

c     DO K = 0, N
c       Y(K) = YP(K)
c     END DO

      RETURN
      END

C*************************************************************************
      SUBROUTINE CHEBYINTF(N,INTERP,X,Y)
C*************************************************************************
C
C     Do a Chebyshev interpolation based on the Chebyshev coefficients Y.
C     The interpolated result is given in INTERP.
C
C*************************************************************************
      INTEGER   N
      REAL      Y(0:N)
      REAL      INTERP, X

      INTERP = 0.0
      DO M = 0, N
        INTERP = INTERP + Y(M)*COS(FLOAT(M)*X)
      END DO

      RETURN
      END

C************************************************************************
      SUBROUTINE COSFT3 (YY,N,ISIGN)
C************************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.
C
C************************************************************************
      PARAMETER   (IDIM=256)
      integer     N, ISIGN
      real        YY(0:N), TT(0:IDIM), PI

      PI = ACOS(-1.0E0)
C
C  SAVE A COPY OF THE INPUT IN CASE I NEED IT LATER
C
      DO I = 0, N
        TT(I) = YY(I)
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.E0 + TT(N)*COS(FLOAT(I)*PI)/2.E0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*COS(FLOAT(M)*FLOAT(I)*PI/FLOAT(N))
          END DO
          YY(I) = YY(I)*2./FLOAT(N)
        end do
        YY(0) = YY(0)/2.E0
        YY(N) = YY(N)/2.E0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*COS(FLOAT(M)*FLOAT(I)*PI/FLOAT(N))
          END DO
        END DO
      end if

      RETURN
      END


subroutine shear_prod2D(def2)

use vars
implicit none

real def2(nx,ny,nzm)

real rdx0,rdx,rdx_up,rdx_dn
real rdz,rdzw_up,rdzw_dn
integer i,j,k,ib,ic,kb,kc

rdx0=1./dx
j=1

do k=2,nzm-1

  kb=k-1
  kc=k+1
  rdz = 1./(dz*adz(k))
  rdzw_up = 1./(dz*adzw(kc))
  rdzw_dn = 1./(dz*adzw(k))
  rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
  rdx_up=rdx0 * sqrt(dx*rdzw_up)
  rdx_dn=rdx0 * sqrt(dx*rdzw_dn)

  do i=1,nx
    ib=i-1
    ic=i+1

      def2(i,j,k)=2.* ( &
            ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
            ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
    + 0.5 * ( &
            ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 +  &
            ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 +   &
            ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ &
              (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + &
            ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ &
              (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + &
            ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ &
              (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + &
            ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ &
              (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 + &
            ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up )**2 + &
            ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 )

  end do
end do ! k

k=1
kc=k+1

rdz = 1./(dz*adz(k))
rdzw_up = 1./(dz*adzw(kc))
rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
rdx_up=rdx0 * sqrt(dx*rdzw_up)

do i=1,nx
 ib=i-1
 ic=i+1

      def2(i,j,k)=2.* ( &
           ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
           ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
   + 0.5 * ( &
           ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + &
           ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) &
          +( (v(i,j ,kc)-v0(kc)-v(i,j,k)+v0(k))*rdzw_up )**2 &
   + 0.5 * ( &
           ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ &
             (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + &
           ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ &
             (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 )
end do

k=nzm
kc=k+1
kb=k-1

rdz = 1./(dz*adz(k))
rdzw_dn = 1./(dz*adzw(k))
rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy
rdx_dn=rdx0 * sqrt(dx*rdzw_dn)

do i=1,nx
 ib=i-1
 ic=i+1

      def2(i,j,k)=2.* ( &
           ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ &
           ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) &
   + 0.5 * ( &
           ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 +  &
           ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 )   &
         + ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 &
   + 0.5 * ( &
         ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ &
           (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + &
         ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ &
           (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 )

end do

end


!-----------------------------------------------------------------------
!     Subroutine:    vmec_ohkawa
!     Authors:       S. Lazerson (samuel.lazerson@ipp.mpg.de)
!     Date:          07/31/2012
!     Description:   This subroutine calculates the Ohkawa correction
!                    factor using the Hirshman-Sigmar formulation.
!                    	K.C. Shaing, B.A. Carreras, N. Dominguez,
!                           V.E. Lynch, J.S. Tolliver
!                           "Bootstrap current control in stellarators",
!                           Phys. Fluids B1, 1663 (1989).
!                           aip.scitation.org/doi/10.1063/1.858945
!                    The Total correction is
!                    j_nbcd = j_f * [1 - Z_f/Zeff*(1-l31)]
!                    we return (1-l31)/Zeff
!-----------------------------------------------------------------------
      SUBROUTINE vmec_ohkawa(sflx,zeff,Gfac)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE read_wout_mod, ONLY: ns, mnmax_nyq, bmnc, gmnc, lasym, &
                               bmns, gmns, xm_nyq, xn_nyq, &
                               lwout_opened, nfp
!-----------------------------------------------------------------------
!     Arguments
!          sflx			Normalized Toroidal Flux
!          zeff         Effective plasma charge
!          Gfac         Correction Factor (1-l31)/zeff
!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL(rprec), INTENT(in) :: sflx, zeff
      REAL(rprec), INTENT(out) :: Gfac
!-----------------------------------------------------------------------
!     PARAMETERS
!          nu			Number of poloidal gridpoints
!          nv           Number of toroidal gridpoints
!          nla          Number of lambda gridpoints
!          pi2          2*pi
!-----------------------------------------------------------------------
      INTEGER, PARAMETER :: nu  = 64
      INTEGER, PARAMETER :: nv  = 64
      INTEGER, PARAMETER :: nla = 64
      REAL(rprec), PARAMETER      :: pi2 = 6.283185482025146D+00
!-----------------------------------------------------------------------
!     Variables
!          ns1			Radial index of first grid point
!          ns2          Radial index of second grid point
!          mn           Linear harmonic index
!          m/n          Poloidal/Toroidal Harmonic
!          zt           Linear theta/zeta index
!          hs           Radial grid spacing
!          zt           Linear array of theta/zeta
!          wlo          Interpolation Weights (whi)
!          wlo_odd      Interpolation Weights, odd (whi_odd)
!          bmn          Fourier Harmonics of |B| (cos)
!          gmn          Fourier Haromincs of Jacobian sqrt(g) (cos)
!          bmn2         Fourier Harmonics of |B| (sin)
!          gmn2         Fourier Haromincs of Jacobian sqrt(g) (sin)
!          u/v          Poloidal/Toroidal var [0,1]
!          kernel       Kernel (m*theta-n*zeta)
!          b            Linear array of |B|
!          g            Linear array of Jacobian sqrt(g)
!          lam          Lambda Array (mu*B_max/B<1, passing)
!          sumg         Sum over Jacobian
!          b2avg        <B^2>
!          bmax         B_max
!          avgbobm2     <B^2>/(B_max*B_max)
!          avgbpov      <sqrt(1-lam*B/B_max)>
!          ft           Trapped Particle fraction
!          fp           Passing particle fraction
!          x            ft/fp
!          z2           Zeff*Zeff
!          d            Demoninator in l31 equation
!          a            Numerator in l31 equation
!-----------------------------------------------------------------------
      INTEGER :: ns1, ns2, zt, mn, m, n
      REAL(rprec) :: hs, wlo, whi, wlo_odd, whi_odd, sumg, b2avg, &
                     bmax, fp ,ft, x, z2, d, a, avgbobm2, kernel, u, v
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: bmn, gmn, b, g, lam, &
                                                avgbpov, bmn2, gmn2
      REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: tz
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      ! Intializations
      Gfac = 0
      ns1 = 0; ns2 = 0;
      z2 = zeff*zeff

      ! Checks
      IF (.not.lwout_opened) &
         STOP "ERROR: READ_WOUT not loaded!"
      IF (sflx>1 .or. sflx<0) RETURN

      ! Interpolate or extrapolate
      hs  = 1.0 / (ns - 1)
      ns1  = INT(1.5 + sflx * (ns - 1))
      ns2  = ns1 + 1
      wlo = (hs * (ns2 - 1.5) - sflx) * (ns - 1)
      whi = 1 - wlo
      IF (ns1 == ns) THEN
         ns2 = ns1-1
         wlo = 1+whi
         whi = -whi
      ELSE IF (ns1 == 1) THEN
         ns1 = 2
      END IF
      whi_odd = whi * SQRT(sflx / (hs * (ns2 - 1.5)))
      IF (ns1 /= 1) THEN
         wlo_odd = wlo * SQRT( sflx / (hs * (ns1 - 1.5)))
      ELSE
         wlo_odd = 0
         whi_odd = SQRT(sflx / (hs * (ns2 - 1.5)))
      END IF

      ! Extrapolate Harmonics
      ALLOCATE(bmn(mnmax_nyq),gmn(mnmax_nyq))
      gmn = 0
      bmn = 0
      WHERE (MOD(NINT(xm_nyq(:)),2) == 0)
         bmn = wlo * bmnc(:,ns1) + whi * bmnc(:,ns2)
         gmn = wlo * gmnc(:,ns1) + whi * gmnc(:,ns2)
      ELSEWHERE
         bmn = wlo_odd * bmnc(:,ns1) + whi_odd * bmnc(:,ns2)
         gmn = wlo_odd * gmnc(:,ns1) + whi_odd * gmnc(:,ns2)
      END WHERE

      IF (lasym) THEN
         ALLOCATE(bmn2(mnmax_nyq),gmn2(mnmax_nyq))
         gmn = 0; bmn = 0
         WHERE (MOD(NINT(xm_nyq(:)),2) == 0)
            bmn2 = wlo * bmns(:,ns1) + whi * bmns(:,ns2)
            gmn2 = wlo * gmns(:,ns1) + whi * gmns(:,ns2)
         ELSEWHERE
            bmn2 = wlo_odd * bmns(:,ns1) + whi_odd * bmns(:,ns2)
            gmn2 = wlo_odd * gmns(:,ns1) + whi_odd * gmns(:,ns2)
         END WHERE
      END IF

      ! Setup theta/zeta grid
      ALLOCATE(tz(nu*nv,2))
      tz = 0
      DO zt = 1, nu*nv
         u = MOD(zt-1,nu)/REAL(nu)
         v = FLOOR(zt/REAL(nu+1))/REAL(nv)
         tz(zt,1) = u*pi2
         tz(zt,2) = v*pi2/nfp
      END DO

      ! Transform quantities (linear OK)
      ALLOCATE(b(nu*nv),g(nu*nv))
      b = 0; g = 0;
      DO zt = 1, nu*nv
         DO mn = 1, mnmax_nyq
            m = xm_nyq(mn)
            n = xn_nyq(mn)
            kernel = cos(m*tz(zt,1)-n*tz(zt,2))
            b(zt)  = b(zt) + bmn(mn)*kernel
            g(zt)  = g(zt) + gmn(mn)*kernel
         END DO
      END DO
      DEALLOCATE(bmn,gmn)

      IF (ALLOCATED(bmn2)) THEN
         DO zt = 1, nu*nv
            DO mn = 1, mnmax_nyq
               m = xm_nyq(mn)
               n = xn_nyq(mn)
               kernel = sin(m*tz(zt,1)-n*tz(zt,2))
               b(zt)  = b(zt) + bmn2(mn)*kernel
               g(zt)  = g(zt) + gmn2(mn)*kernel
            END DO
         END DO
         DEALLOCATE(bmn2,gmn2)
      END IF
      DEALLOCATE(tz)

      ! Adjust
      b = ABS(b)
      g = -g ! Jacobain negative in VMEC

      ! Flux surface quantities
      sumg = SUM(g)
      b2avg = SUM(b*b*g)/sumg
      bmax = MAXVAL(b)
      avgbobm2 = b2avg/(bmax*bmax)

      ! Normalize B
      b = b / bmax
      WHERE (b > 1) b = 1;

      ! Setup Integral
      ALLOCATE(lam(nla),avgbpov(nla))
      DO mn = 1, nla
         lam(mn) = REAL(mn-1)/REAL(nla-1)
         avgbpov(mn) = sum(sqrt(abs(1 - lam(mn) * b)) * g)
      END DO

      ! Calculate trapped and passing fractions
      fp = 0.75 * avgbobm2 * sum(lam/avgbpov)*sumg/(nla-1)
      fp = MAX(MIN(fp,1.0),0.0)
      IF (fp == 0) RETURN
      x = (1-fp)/fp

      ! Calculate G~l31
      d = 1.414*zeff +z2 &
         + x * (0.754 + 2.657*zeff + 2 * z2) &
         + x  * x * (0.348 + 1.243*zeff +     z2)
      a = 0.754 + 2.21 * zeff + z2 + x * (0.348 + 1.243 * zeff + z2)
      Gfac = (1 - x*a/d)/zeff

      !STOP

      ! Cleanup
      DEALLOCATE(b,g)
      DEALLOCATE(lam,avgbpov)

      RETURN

!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE vmec_ohkawa


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

      SUBROUTINE prp_xcfft_box(gmaxxc,bmat,kxc1d,kxc2d,kxc3d)
c*********************************************************************
c     Determine the dimensions kxc1d, kxc2d, kxc3d
c     of the dimension of the xc-energy and potential fft-box
c     needed for the fast calculation in interstitial region
c
c     dimensions kxc(i)d for xc-potential/energy FFT in interstitial
c     added.
c        s. bluegel, IFF, Oct. 97
c
c     subroutine boxdim added to subroutine prp_xcfft
c        s.bluegel, IFF, 18.Nov.97
c*********************************************************************

      USE m_constants
      USE m_ifft, ONLY : ifft235
      USE m_boxdim
      IMPLICIT NONE

      INTEGER kxc1d,kxc2d,kxc3d
      REAL bmat(3,3),gmaxxc

      REAL arltv1,arltv2,arltv3
      INTEGER mk1,mk2,mk3,iofile,ksfft
C ..

C ... Intrinsic Functions
      INTRINSIC int
C
C------->          ABBREVIATIONS
C
C   ksfft=(0,1) : KEY OF SELECTING FFT-PRDOGRAM AND RADIX-TYPE
C                      0  PROGRAM, RADIX-2 ONLY
C                      1  PROGRAM, RADIX-2, RADIX-3,RADIX-5
c   iofile      : device number for in and output
c   gmax        : cut-off wavevector for charge density
c   gmaxxc      : cut-off wavevector for xc-potential and energy
c                 in interstitial
c   arltv(i)    : length of reciprical lattice vector along
c                 direction (i)
c
C---> Determine rkmax box of size mk1, mk2, mk3,
c     for which |G(mk1,mk2,mk3) + (k1,k2,k3)| < gmaxxc
C
      CALL boxdim(bmat,arltv1,arltv2,arltv3)

c     (add 1+1 due to integer rounding, strange k_vector in BZ)
      mk1 = int(gmaxxc/arltv1) + 2
      mk2 = int(gmaxxc/arltv2) + 2
      mk3 = int(gmaxxc/arltv3) + 2
c
      kxc1d = 2*mk1
      kxc2d = 2*mk2
      kxc3d = 2*mk3
c
c---> fft's are usually fastest for low primes
c     (restrict kxcid to: kxcid=  (2**P) * (3**Q) * (5**R)
c
      iofile = oUnit
      ksfft = 1
      !WRITE (oUnit,*) 'minimum: kxc1d,kxc2d,kxc3d',kxc1d,kxc2d,kxc3d
      kxc1d = ifft235(ksfft,kxc1d,2.0)
      kxc2d = ifft235(ksfft,kxc2d,2.0)
      kxc3d = ifft235(ksfft,kxc3d,2.0)
      !WRITE (oUnit,*) 'ifft235: kxc1d,kxc2d,kxc3d',kxc1d,kxc2d,kxc3d

      RETURN
      END


!=====================================================|
subroutine sc4rk4
!=====================================================|
  use geometry_def, only: qq,qqm,qqp,dx,dt,nxg,margin,mtype
  use const_def, only: gm,cv,pii4,pii8
  implicit none

  integer :: i,m,mm
  real(KIND(0.d0)) :: ratio
  ! total pressure (gas + magnetic)
  real(KIND(0.d0)), dimension(nxg) :: pt
  real(KIND(0.d0)) :: dro,drx,dry,drz,dbx,dby,dbz,dse
!-----------------------------------------------------|

  ! Runge-Kutta loop
  do mm = 1,4
     if(mm == 1) ratio = 1.d0/4.d0
     if(mm == 2) ratio = 1.d0/3.d0
     if(mm == 3) ratio = 1.d0/2.d0
     if(mm == 4) ratio = 1.d0

     if(mm == 1) then
        do i = 1,nxg
        do m = 1,mtype
           qqp(i,m) = qq(i,m)
        enddo
        enddo
     else
        do i = 1,nxg
        do m = 1,mtype
           qqp(i,m) = qqm(i,m)
        enddo
        enddo
     endif

     do i = 1,nxg
        pt(i) = qqp(i,1)**gm*exp(qqp(i,8)/cv) &
        & + (qqp(i,5)**2 + qqp(i,6)**2 + qqp(i,7)**2)*pii8
     enddo

     do i = 1+margin,nxg-margin
        dro = -( &
             & -      qqp(i+2,1)*qqp(i+2,2) &
             & + 8.d0*qqp(i+1,1)*qqp(i+1,2) &
             & - 8.d0*qqp(i-1,1)*qqp(i-1,2) &
             & +      qqp(i-2,1)*qqp(i-2,2) &
             & )/dx/12.d0*dt

        drx = -( &
             & -      qqp(i+2,1)*qqp(i+2,2)*qqp(i+2,2) &
             & + 8.d0*qqp(i+1,1)*qqp(i+1,2)*qqp(i+1,2) &
             & - 8.d0*qqp(i-1,1)*qqp(i-1,2)*qqp(i-1,2) &
             & +      qqp(i-2,1)*qqp(i-2,2)*qqp(i-2,2) &
             & -      pt(i+2) &
             & + 8.d0*pt(i+1) &
             & - 8.d0*pt(i-1) &
             & +      pt(i-2) &
             & - pii4*( &
             & -      qqp(i+2,5)*qqp(i+2,5) &
             & + 8.d0*qqp(i+1,5)*qqp(i+1,5) &
             & - 8.d0*qqp(i-1,5)*qqp(i-1,5) &
             & +      qqp(i-2,5)*qqp(i-2,5) &
             & ) &
             & )/dx/12.d0*dt

        dry = -( &
             & -      qqp(i+2,1)*qqp(i+2,2)*qqp(i+2,3) &
             & + 8.d0*qqp(i+1,1)*qqp(i+1,2)*qqp(i+1,3) &
             & - 8.d0*qqp(i-1,1)*qqp(i-1,2)*qqp(i-1,3) &
             & +      qqp(i-2,1)*qqp(i-2,2)*qqp(i-2,3) &
             & - pii4*( &
             & -      qqp(i+2,5)*qqp(i+2,6) &
             & + 8.d0*qqp(i+1,5)*qqp(i+1,6) &
             & - 8.d0*qqp(i-1,5)*qqp(i-1,6) &
             & +      qqp(i-2,5)*qqp(i-2,6) &
             & ) &
             & )/dx/12.d0*dt

        drz = -( &
             & -      qqp(i+2,1)*qqp(i+2,2)*qqp(i+2,4) &
             & + 8.d0*qqp(i+1,1)*qqp(i+1,2)*qqp(i+1,4) &
             & - 8.d0*qqp(i-1,1)*qqp(i-1,2)*qqp(i-1,4) &
             & +      qqp(i-2,1)*qqp(i-2,2)*qqp(i-2,4) &
             & - pii4*( &
             & -      qqp(i+2,5)*qqp(i+2,7) &
             & + 8.d0*qqp(i+1,5)*qqp(i+1,7) &
             & - 8.d0*qqp(i-1,5)*qqp(i-1,7) &
             & +      qqp(i-2,5)*qqp(i-2,7) &
             & ) &
             & )/dx/12.d0*dt

        dbx = 0.d0

        dby = + ( &
             & - ( &
             & -      qqp(i+2,2)*qqp(i+2,6) &
             & + 8.d0*qqp(i+1,2)*qqp(i+1,6) &
             & - 8.d0*qqp(i-1,2)*qqp(i-1,6) &
             & +      qqp(i-2,2)*qqp(i-2,6) &
             & ) &
             & + ( &
             & -      qqp(i+2,3)*qqp(i+2,5) &
             & + 8.d0*qqp(i+1,3)*qqp(i+1,5) &
             & - 8.d0*qqp(i-1,3)*qqp(i-1,5) &
             & +      qqp(i-2,3)*qqp(i-2,5) &
             & ) &
             & )/dx/12.d0*dt

        dbz = + ( &
             & - ( &
             & -      qqp(i+2,2)*qqp(i+2,7) &
             & + 8.d0*qqp(i+1,2)*qqp(i+1,7) &
             & - 8.d0*qqp(i-1,2)*qqp(i-1,7) &
             & +      qqp(i-2,2)*qqp(i-2,7) &
             & ) &
             & + ( &
             & -      qqp(i+2,4)*qqp(i+2,5) &
             & + 8.d0*qqp(i+1,4)*qqp(i+1,5) &
             & - 8.d0*qqp(i-1,4)*qqp(i-1,5) &
             & +      qqp(i-2,4)*qqp(i-2,5) &
             & ) &
             & )/dx/12.d0*dt

        dse = -qqp(i,2)*( &
             & -      qqp(i+2,8) &
             & + 8.d0*qqp(i+1,8) &
             & - 8.d0*qqp(i-1,8) &
             & +      qqp(i-2,8) &
             & )/dx/12.d0*dt

        qqm(i,1) = qq(i,1) + ratio*dro
        qqm(i,2) = (qq(i,1)*qq(i,2) + ratio*drx)/qqm(i,1)
        qqm(i,3) = (qq(i,1)*qq(i,3) + ratio*dry)/qqm(i,1)
        qqm(i,4) = (qq(i,1)*qq(i,4) + ratio*drz)/qqm(i,1)
        qqm(i,5) = qq(i,5) + ratio*dbx
        qqm(i,6) = qq(i,6) + ratio*dby
        qqm(i,7) = qq(i,7) + ratio*dbz
        qqm(i,8) = qq(i,8) + ratio*dse
     enddo
     call bc(qqm)
  enddo

  return
end subroutine sc4rk4