  MODULE diff2_module

  implicit none

  private
  public :: diff2u,diff2v,diff2w,diff2s,diff2def

  CONTAINS

      subroutine diff2u(rxh,arh1,arh2,uh,xf,arf1,arf2,uf,vh,vf,mh,mf,  &
                        dum,diffx,diffy,diffz,uten,ust,rho,rr,rf,divx,t11,t12,t13, &
                        doubud,udiag)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie) :: rxh,arh1,arh2,uh
      real, intent(in), dimension(ib:ie+1) :: xf,arf1,arf2,uf
      real, dimension(jb:je) :: vh
      real, dimension(jb:je+1) :: vf
      real, dimension(ib:ie,jb:je,kb:ke) :: mh
      real, dimension(ib:ie,jb:je,kb:ke+1) :: mf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum,diffx,diffy,diffz
      real, intent(inout), dimension(ib:ie+1,jb:je,kb:ke) :: uten
      real, intent(in), dimension(ib:ie,jb:je) :: ust
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: rho,rr,rf,divx,t11,t12,t13
      logical, intent(in) :: doubud
      real, intent(inout) , dimension(ibdv:iedv,jbdv:jedv,kbdv:kedv,nudiag) :: udiag

      integer :: i,j,k,i2

      real, parameter :: twdth = 2.0/3.0

!--------------------------
!
!  2nd order artificial diffusion
!
!-----------------------------------------------------------------------

      IF(terrain_flag)THEN
        if(myid.eq.0) print *,'  cannot use diff2u with terrain (yet) '
        call stopcm1
      ENDIF

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

    IF(axisymm.eq.0)THEN
      ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=1,nk
        !  x-direction
        do j=1,nj
        do i=0,ni+1
          dum(i,j,k)=2.0*t11(i,j,k)-rho(i,j,k)*twdth*divx(i,j,k)
        enddo
        enddo
        do j=1,nj
        do i=1,ni+1
          diffx(i,j,k)=(dum(i,j,k)-dum(i-1,j,k))*rdx*uf(i)
        enddo
        enddo
        !  y-direction
        do j=1,nj
        do i=1,ni+1
          diffy(i,j,k)=(t12(i,j+1,k)-t12(i,j,k))*rdy*vh(j)
        enddo
        enddo
      enddo

    ELSE
      ! axisymmetric grid:

      i2 = ni+1
      IF( ebc.eq.3 .or. ebc.eq.4 ) i2 = ni

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=1,nk
      do j=1,nj
        do i=2,i2
          diffx(i,j,k)=2.0*(arf2(i)*arf2(i)*t11(i,j,k)-arf1(i)*arf1(i)*t11(i-1,j,k))*rdx*uf(i) &
                      -twdth*(rho(i,j,k)*divx(i,j,k)-rho(i-1,j,k)*divx(i-1,j,k))*rdx*uf(i)
        enddo
        IF( ebc.eq.3 .or. ebc.eq.4 ) diffx(ni+1,j,k) = 0.0
      enddo
      enddo

    ENDIF

!-----------------------------------------------------------------------
!  z-direction

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      DO j=1,nj

        do k=1,nk
        do i=1,ni+1
          diffz(i,j,k)=(t13(i,j,k+1)-t13(i,j,k))*rdz*mh(1,1,k)
        enddo
        enddo

        IF( axisymm.eq.1 .and. (ebc.eq.3 .or. ebc.eq.4) )THEN
          do k=1,nk
            diffz(ni+1,j,k)=0.0
          enddo
        ENDIF

      ENDDO

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

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni+1
          uten(i,j,k)=uten(i,j,k)+((diffx(i,j,k)+diffy(i,j,k))+diffz(i,j,k))  &
                                 /(0.5*(rho(i-1,j,k)+rho(i,j,k)))
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=2,ni+1
          uten(i,j,k)=uten(i,j,k)+(diffx(i,j,k)+diffz(i,j,k))  &
                                 /(0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k)))
        enddo
        enddo
        enddo

      ENDIF

!-----------------------------------------------------------------------
!  Diagnostics:

    IF( doubud )THEN

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni+1
          udiag(i,j,k,ud_hediff)=(diffx(i,j,k)+diffy(i,j,k))/(0.5*(rho(i-1,j,k)+rho(i,j,k)))
          udiag(i,j,k,ud_vediff)=diffz(i,j,k)/(0.5*(rho(i-1,j,k)+rho(i,j,k)))
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=2,ni+1
          udiag(i,j,k,ud_hediff)=diffx(i,j,k)/(0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k)))
          udiag(i,j,k,ud_vediff)=diffz(i,j,k)/(0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k)))
        enddo
        enddo
        enddo

      ENDIF

    ENDIF

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

      if(timestats.ge.1) time_diffu=time_diffu+mytime()

      end subroutine diff2u

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine diff2v(xh,arh1,arh2,uh,rxf,arf1,arf2,uf,vh,vf,mh,mf,  &
                        dum,diffx,diffy,diffz,vten,ust,rho,rr,rf,divx,t22,t12,t23, &
                        dovbud,vdiag)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie) :: xh,arh1,arh2,uh
      real, intent(in), dimension(ib:ie+1) :: rxf,arf1,arf2,uf
      real, dimension(jb:je) :: vh
      real, dimension(jb:je+1) :: vf
      real, dimension(ib:ie,jb:je,kb:ke) :: mh
      real, dimension(ib:ie,jb:je,kb:ke+1) :: mf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum,diffx,diffy,diffz
      real, intent(inout), dimension(ib:ie,jb:je+1,kb:ke) :: vten
      real, intent(in), dimension(ib:ie,jb:je) :: ust
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: rho,rr,rf,divx,t22,t12,t23
      logical, intent(in) :: dovbud
      real, intent(inout) , dimension(ibdv:iedv,jbdv:jedv,kbdv:kedv,nvdiag) :: vdiag

      integer :: i,j,k,j1,j2

      real, parameter :: twdth = 2.0/3.0

!--------------------------
!
!  2nd order artificial diffusion
!
!-----------------------------------------------------------------------

      IF(terrain_flag)THEN
        if(myid.eq.0) print *,'  cannot use diff2v with terrain (yet) '
        call stopcm1
      ENDIF

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

    IF(axisymm.eq.0)THEN
      ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=1,nk
        do j=1,nj+1
        do i=1,ni
          diffx(i,j,k)=(t12(i+1,j,k)-t12(i,j,k))*rdx*uh(i)
        enddo
        enddo
        !  y-direction
        do j=0,nj+1
        do i=1,ni
          dum(i,j,k)=2.0*t22(i,j,k)-rho(i,j,k)*twdth*divx(i,j,k)
        enddo
        enddo
        do j=1,nj+1
        do i=1,ni
          diffy(i,j,k)=(dum(i,j,k)-dum(i,j-1,k))*rdy*vf(j)
        enddo
        enddo
      enddo

    ELSE
      ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(j,k)
      do k=1,nk
      do j=1,nj
        do i=1,ni
          diffx(i,j,k)=(arh2(i)*arh2(i)*t12(i+1,j,k)-arh1(i)*arh1(i)*t12(i,j,k))*rdx*uh(i)
        enddo
      enddo
      enddo

    ENDIF

!-----------------------------------------------------------------------
!  z-direction

      j1 = 1
      j2 = nj+1
      IF( axisymm.eq.1 ) j2 = nj

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      DO j=j1,j2

        do k=1,nk
        do i=1,ni
          diffz(i,j,k)=(t23(i,j,k+1)-t23(i,j,k))*rdz*mh(1,1,k)
        enddo
        enddo

      ENDDO

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

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj+1
        do i=1,ni
          vten(i,j,k)=vten(i,j,k)+((diffx(i,j,k)+diffy(i,j,k))+diffz(i,j,k))  &
                                 /(0.5*(rho(i,j-1,k)+rho(i,j,k)))
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          vten(i,j,k)=vten(i,j,k)+(diffx(i,j,k)+diffz(i,j,k))*rr(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

!-----------------------------------------------------------------------
!  Diagnostics:

    IF( dovbud )THEN

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj+1
        do i=1,ni
          vdiag(i,j,k,vd_hediff)=(diffx(i,j,k)+diffy(i,j,k))/(0.5*(rho(i,j-1,k)+rho(i,j,k)))
          vdiag(i,j,k,vd_vediff)=diffz(i,j,k)/(0.5*(rho(i,j-1,k)+rho(i,j,k)))
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          vdiag(i,j,k,vd_hediff)=diffx(i,j,k)*rr(i,j,k)
          vdiag(i,j,k,vd_vediff)=diffz(i,j,k)*rr(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

    ENDIF

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

      if(timestats.ge.1) time_diffu=time_diffu+mytime()

      end subroutine diff2v

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine diff2w(rxh,arh1,arh2,uh,xf,arf1,arf2,uf,vh,vf,mh,mf,  &
                        dum,diffx,diffy,diffz,wten,rho,rr,rf,divx,t33,t13,t23, &
                        dowbud,wdiag)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie) :: rxh,arh1,arh2,uh
      real, intent(in), dimension(ib:ie+1) :: xf,arf1,arf2,uf
      real, dimension(jb:je) :: vh
      real, dimension(jb:je+1) :: vf
      real, dimension(ib:ie,jb:je,kb:ke) :: mh
      real, dimension(ib:ie,jb:je,kb:ke+1) :: mf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum,diffx,diffy,diffz
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke+1) :: wten
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: rho,rr,rf,divx,t33,t13,t23
      logical, intent(in) :: dowbud
      real, intent(inout) , dimension(ibdv:iedv,jbdv:jedv,kbdv:kedv,nwdiag) :: wdiag

      integer :: i,j,k

      real, parameter :: twdth = 2.0/3.0

!--------------------------
!
!  2nd order artificial diffusion
!
!-----------------------------------------------------------------------

      IF(terrain_flag)THEN
        if(myid.eq.0) print *,'  cannot use diff2w with terrain (yet) '
        call stopcm1
      ENDIF

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

    IF(axisymm.eq.0)THEN
      ! Cartesian grid:

      !  x-direction
!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=2,nk
        do j=1,nj
        do i=1,ni
          diffx(i,j,k)=(t13(i+1,j,k)-t13(i,j,k))*rdx*uh(i)
        enddo
        enddo
        do j=1,nj
        do i=1,ni
          diffy(i,j,k)=(t23(i,j+1,k)-t23(i,j,k))*rdy*vh(j)
        enddo
        enddo
      enddo

    ELSE
      ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=2,nk
      do j=1,nj
        do i=1,ni
          diffx(i,j,k)=(arh2(i)*t13(i+1,j,k)-arh1(i)*t13(i,j,k))*rdx*uh(i)
        enddo
      enddo
      enddo

    ENDIF

!-----------------------------------------------------------------------
!  z-direction

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      DO j=1,nj

        do k=1,nk
        do i=1,ni
          dum(i,j,k)=2.0*t33(i,j,k)-rho(i,j,k)*twdth*divx(i,j,k)
        enddo
        enddo

        do k=2,nk
        do i=1,ni
          diffz(i,j,k)=(dum(i,j,k)-dum(i,j,k-1))*rdz*mf(1,1,k)
        enddo
        enddo

      ENDDO

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

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=2,nk
        do j=1,nj
        do i=1,ni
          wten(i,j,k)=wten(i,j,k)+((diffx(i,j,k)+diffy(i,j,k))+diffz(i,j,k))/rf(i,j,k)
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=2,nk
        do j=1,nj
        do i=1,ni
          wten(i,j,k)=wten(i,j,k)+(diffx(i,j,k)+diffz(i,j,k))/rf(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

!-----------------------------------------------------------------------
!  Diagnostics:

    IF( dowbud )THEN

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=2,nk
        do j=1,nj
        do i=1,ni
          wdiag(i,j,k,wd_hediff)=(diffx(i,j,k)+diffy(i,j,k))/rf(i,j,k)
          wdiag(i,j,k,wd_vediff)=diffz(i,j,k)/rf(i,j,k)
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=2,nk
        do j=1,nj
        do i=1,ni
          wdiag(i,j,k,wd_hediff)=diffx(i,j,k)/rf(i,j,k)
          wdiag(i,j,k,wd_vediff)=diffz(i,j,k)/rf(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

    ENDIF

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

      if(timestats.ge.1) time_diffu=time_diffu+mytime()

      end subroutine diff2w

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine diff2s(rxh,arh1,arh2,uh,xf,arf1,arf2,uf,vh,vf,mh,mf,  &
                        dum,diffx,diffy,diffz,s,sten,rho,rr,rf,  &
                        dobud,ibd,ied,jbd,jed,kbd,ked,ndiag,diag,sd_hediff,sd_vediff)
      use input
      use constants
      implicit none

      real, dimension(ib:ie) :: rxh,arh1,arh2,uh
      real, dimension(ib:ie+1) :: xf,arf1,arf2,uf
      real, dimension(jb:je) :: vh
      real, dimension(jb:je+1) :: vf
      real, dimension(ib:ie,jb:je,kb:ke) :: mh
      real, dimension(ib:ie,jb:je,kb:ke+1) :: mf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum,diffx,diffy,diffz
      real, dimension(ib:ie,jb:je,kb:ke) :: s,sten
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: rho,rr,rf
      logical, intent(in) :: dobud
      integer, intent(in) :: ibd,ied,jbd,jed,kbd,ked,ndiag,sd_hediff,sd_vediff
      real, intent(inout) , dimension(ibd:ied,jbd:jed,kbd:ked,ndiag) :: diag

      integer :: i,j,k
      real :: coef

!--------------------------
!
!  2nd order artificial diffusion
!
!-----------------------------------------------------------------------

      IF(terrain_flag)THEN
        if(myid.eq.0) print *,'  cannot use diff2s with terrain (yet) '
        call stopcm1
      ENDIF

      coef = kdiff2

!-----------------------------------------------------------------------
!  x-direction
!  y-direction

    IF(axisymm.eq.0)THEN
      ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=1,nk
        do j=1,nj
        do i=1,ni+1
          dum(i,j,k)=0.5*(rho(i,j,k)+rho(i-1,j,k))*(s(i,j,k)-s(i-1,j,k))*rdx*uf(i)
        enddo
        enddo
        do j=1,nj
        do i=1,ni
          diffx(i,j,k)=coef*(dum(i+1,j,k)-dum(i,j,k))*rdx*uh(i)
        enddo
        enddo
        do j=1,nj+1
        do i=1,ni
          dum(i,j,k)=0.5*(rho(i,j,k)+rho(i,j-1,k))*(s(i,j,k)-s(i,j-1,k))*rdy*vf(j)
        enddo
        enddo
        do j=1,nj
        do i=1,ni
          diffy(i,j,k)=coef*(dum(i,j+1,k)-dum(i,j,k))*rdy*vh(j)
        enddo
        enddo
      enddo

    ELSE
      ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      do k=1,nk
      do j=1,nj
        dum(1,j,k)=0.0
        do i=2,ni+1
          dum(i,j,k)=(s(i,j,k)-s(i-1,j,k))*rdx*uf(i)   &
                *0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k))
        enddo
        !-----
        ! assume zero flux:
        if(wbc.eq.3.or.wbc.eq.4)then
          dum(1,j,k) = 0.0
        endif
        if(ebc.eq.3.or.ebc.eq.4)then
          dum(ni+1,j,k) = 0.0
        endif
        !-----
        do i=1,ni
          diffx(i,j,k)=coef*(arh2(i)*dum(i+1,j,k)-arh1(i)*dum(i,j,k))*rdx*uh(i)
        enddo
      enddo
      enddo

    ENDIF

!-----------------------------------------------------------------------
!  z-direction

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
      DO j=1,nj

        do k=2,nk
        do i=1,ni
          dum(i,j,k)=(s(i,j,k)-s(i,j,k-1))*rdz*mf(1,1,k)
        enddo
        enddo

        ! assume zero flux boundary conditions:
        do i=1,ni
          dum(i,j,1)=0.0
          dum(i,j,nk+1)=0.0
        enddo

        do k=1,nk
        do i=1,ni
          diffz(i,j,k)=coef*(rf(i,j,k+1)*dum(i,j,k+1)-rf(i,j,k)*dum(i,j,k))*rdz*mh(1,1,k)
        enddo
        enddo

      ENDDO

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

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          sten(i,j,k)=sten(i,j,k)+((diffx(i,j,k)+diffy(i,j,k))+diffz(i,j,k))*rr(i,j,k)
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

!$omp parallel do default(shared)   &
!$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          sten(i,j,k)=sten(i,j,k)+(diffx(i,j,k)+diffz(i,j,k))*rr(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

!-----------------------------------------------------------------------
!  Diagnostics:

    IF( dobud )THEN

      IF(axisymm.eq.0)THEN
        ! Cartesian grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          diag(i,j,k,sd_hediff)=(diffx(i,j,k)+diffy(i,j,k))*rr(i,j,k)
          diag(i,j,k,sd_vediff)=diffz(i,j,k)*rr(i,j,k)
        enddo
        enddo
        enddo

      ELSE
        ! axisymmetric grid:

        !$omp parallel do default(shared)   &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          diag(i,j,k,sd_hediff)=diffx(i,j,k)*rr(i,j,k)
          diag(i,j,k,sd_vediff)=diffz(i,j,k)*rr(i,j,k)
        enddo
        enddo
        enddo

      ENDIF

    ENDIF

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

      if(timestats.ge.1) time_diffu=time_diffu+mytime()

      end subroutine diff2s

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine diff2def(uh,arh1,arh2,uf,arf1,arf2,vh,vf,mh,c1,c2,mf,ust,znt,u1,v1,s1,  &
                          divx,rho,rr,rf,t11,t12,t13,t22,t23,t33,ua,va,wa,dissten)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie) :: uh,arh1,arh2
      real, intent(in), dimension(ib:ie+1) :: uf,arf1,arf2
      real, intent(in), dimension(jb:je) :: vh
      real, intent(in), dimension(jb:je+1) :: vf
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: mh,c1,c2
      real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: mf
      real, intent(in), dimension(ib:ie,jb:je) :: ust,znt,u1,v1,s1
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: divx,rho,rr,rf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: t11,t12,t13,t22,t23,t33
      real, intent(in),    dimension(ib:ie+1,jb:je,kb:ke) :: ua
      real, intent(in),    dimension(ib:ie,jb:je+1,kb:ke) :: va
      real, intent(in),    dimension(ib:ie,jb:je,kb:ke+1) :: wa
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke+1) :: dissten

      integer :: i,j,k
      real :: coef,rcoef,tmp11,tmp22,tmp33,tmp12,tmp13,tmp23,tem

      real, parameter :: twodthree  = 2.0/3.0

!--------------------------------------------------------------------
!  NOTE:  diff2 arrays all assume no terrain
!--------------------------------------------------------------------

      coef = kdiff2
      rcoef = 1.0/coef

!-----------------------------------------------------------------------
!  Cartesian grid:

      IF(axisymm.eq.0)THEN

!$omp parallel do default(shared)  &
!$omp private(i,j,k)
        DO k=1,nk

          do j=0,nj+1
          do i=0,ni+1
            divx(i,j,k)=(ua(i+1,j,k)-ua(i,j,k))*rdx*uh(i)        &
                       +(va(i,j+1,k)-va(i,j,k))*rdy*vh(j)        &
                       +(wa(i,j,k+1)-wa(i,j,k))*rdz*mh(1,1,k)
            if(abs(divx(i,j,k)).lt.smeps) divx(i,j,k)=0.0
          enddo
          enddo

          do j=0,nj+1
          do i=0,ni+1
            t11(i,j,k) = coef*rho(i,j,k)*(ua(i+1,j,k)-ua(i,j,k))*rdx*uh(i)
            t22(i,j,k) = coef*rho(i,j,k)*(va(i,j+1,k)-va(i,j,k))*rdy*vh(j)
            t33(i,j,k) = coef*rho(i,j,k)*(wa(i,j,k+1)-wa(i,j,k))*rdz*mh(1,1,k)
            t12(i,j,k) = coef*( (ua(i,j,k)-ua(i,j-1,k))*rdy*vf(j)    &
                               +(va(i,j,k)-va(i-1,j,k))*rdx*uf(i) )  &
                   *0.25*( (rho(i-1,j-1,k)+rho(i,j,k))+(rho(i-1,j,k)+rho(i,j-1,k)) )
          enddo
          enddo

          !-----
          ! lateral boundary conditions:
          if(wbc.eq.3.and.ibw.eq.1)then
            ! free slip b.c.
            do j=1,nj+1
              t12(1,j,k) = t12(2,j,k)
            enddo
          elseif(wbc.eq.4.and.ibw.eq.1)then
            ! no slip b.c.
            i = 1
            do j=1,nj+1
              t12(1,j,k) = coef*2.0*va(1,j,k)*rdx*uf(1)   &
                   *0.25*( (rho(i-1,j-1,k)+rho(i,j,k))+(rho(i-1,j,k)+rho(i,j-1,k)) )
            enddo
          endif
          if(ebc.eq.3.and.ibe.eq.1)then
            ! free slip b.c.
            do j=1,nj+1
              t12(ni+1,j,k) = t12(ni,j,k)
            enddo
          elseif(ebc.eq.4.and.ibe.eq.1)then
            ! no slip b.c.
            i = ni+1
            do j=1,nj+1
              t12(ni+1,j,k) = -coef*2.0*va(ni,j,k)*rdx*uf(ni+1)   &
                   *0.25*( (rho(i-1,j-1,k)+rho(i,j,k))+(rho(i-1,j,k)+rho(i,j-1,k)) )
            enddo
          endif
          !-----
          !-----
          if(sbc.eq.3.and.ibs.eq.1)then
            ! free slip b.c.
            do i=1,ni+1
              t12(i,1,k) = t12(i,2,k)
            enddo
          elseif(sbc.eq.4.and.ibs.eq.1)then
            ! no slip b.c.
            j = 1
            do i=1,ni+1
              t12(i,1,k) = coef*2.0*ua(i,1,k)*rdy*vf(1)   &
                   *0.25*( (rho(i-1,j-1,k)+rho(i,j,k))+(rho(i-1,j,k)+rho(i,j-1,k)) )
            enddo
          endif
          if(nbc.eq.3.and.ibn.eq.1)then
            ! free slip b.c.
            do i=1,ni+1
              t12(i,nj+1,k) = t12(i,nj,k)
            enddo
          elseif(nbc.eq.4.and.ibn.eq.1)then
            ! no slip b.c.
            j = nj+1
            do i=1,ni+1
              t12(i,nj+1,k) = -coef*2.0*ua(i,nj,k)*rdy*vf(nj+1)   &
                   *0.25*( (rho(i-1,j-1,k)+rho(i,j,k))+(rho(i-1,j,k)+rho(i,j-1,k)) )
            enddo
          endif
          !-----

          IF(k.ne.1)THEN
            do j=1,nj+1
            do i=1,ni+1
              t13(i,j,k)=coef*( (ua(i,j,k)-ua(i,j,k-1))*rdz*mf(1,1,k)  &
                               +(wa(i,j,k)-wa(i-1,j,k))*rdx*uf(i) )
              t23(i,j,k)=coef*( (va(i,j,k)-va(i,j,k-1))*rdz*mf(1,1,k)  &
                               +(wa(i,j,k)-wa(i,j-1,k))*rdy*vf(j) )
            enddo
            enddo
            !-----
            ! lateral boundary conditions:
            if(wbc.eq.3.and.ibw.eq.1)then
              ! free slip b.c.
              do j=1,nj
                t13(1,j,k) = t13(2,j,k)
              enddo
            elseif(wbc.eq.4.and.ibw.eq.1)then
              ! no slip b.c.
              do j=1,nj
                t13(1,j,k) = coef*2.0*wa(1,j,k)*rdx*uf(1)
              enddo
            endif
            if(ebc.eq.3.and.ibe.eq.1)then
              ! free slip b.c.
              do j=1,nj
                t13(ni+1,j,k) = t13(ni,j,k)
              enddo
            elseif(ebc.eq.4.and.ibe.eq.1)then
              ! no slip b.c.
              do j=1,nj
                t13(ni+1,j,k) = -coef*2.0*wa(ni,j,k)*rdx*uf(ni+1)
              enddo
            endif
            !-----
            !-----
            if(sbc.eq.3.and.ibs.eq.1)then
              ! free slip b.c.
              do i=1,ni
                t23(i,1,k) = t23(i,2,k)
              enddo
            elseif(sbc.eq.4.and.ibs.eq.1)then
              ! no slip b.c.
              do i=1,ni
                t23(i,1,k) = coef*2.0*wa(i,1,k)*rdy*vf(1)
              enddo
            endif
            if(nbc.eq.3.and.ibn.eq.1)then
              ! free slip b.c.
              do i=1,ni
                t23(i,nj+1,k) = t23(i,nj,k)
              enddo
            elseif(nbc.eq.4.and.ibn.eq.1)then
              ! no slip b.c.
              do i=1,ni
                t23(i,nj+1,k) = -coef*2.0*wa(i,nj,k)*rdy*vf(nj+1)
              enddo
            endif
            !-----
          ENDIF  ! endif for k.ne.1

        ENDDO  ! enddo for k loop

        !---------------------------------
        ! bottom/top boundary conditions:
        !---------------------------------

        if(bbc.eq.1)then
          ! free slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1)=t13(i,j,2)
          enddo
          enddo
          do j=1,nj+1
          do i=1,ni
            t23(i,j,1)=t23(i,j,2)
          enddo
          enddo
        elseif(bbc.eq.2)then
          ! no slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1)=coef*2.0*(ua(i,j,1)+umove)*rdz*mf(1,1,1)
          enddo
          enddo
          do j=1,nj+1
          do i=1,ni
            t23(i,j,1)=coef*2.0*(va(i,j,1)+vmove)*rdz*mf(1,1,1)
          enddo
          enddo
        elseif(bbc.eq.3)then
          ! semi-slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1) = 0.5*( (ust(i-1,j)**2)*(u1(i-1,j)/max(s1(i-1,j),0.01)) &
                              +(ust(i  ,j)**2)*(u1(i  ,j)/max(s1(i  ,j),0.01)) )
          enddo
          enddo
          do j=1,nj+1
          do i=1,ni
            t23(i,j,1) = 0.5*( (ust(i,j-1)**2)*(v1(i,j-1)/max(s1(i,j-1),0.01)) &
                              +(ust(i,j  )**2)*(v1(i,j  )/max(s1(i,j  ),0.01)) )
          enddo
          enddo
        endif

        if(tbc.eq.1)then
          ! free slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,nk+1)=t13(i,j,nk)
          enddo
          enddo
          do j=1,nj+1
          do i=1,ni
            t23(i,j,nk+1)=t23(i,j,nk)
          enddo
          enddo
        elseif(tbc.eq.2)then
          ! no slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,nk+1)=-coef*2.0*ua(i,j,nk)*rdz*mf(1,1,nk+1)
          enddo
          enddo
          do j=1,nj+1
          do i=1,ni
            t23(i,j,nk+1)=-coef*2.0*va(i,j,nk)*rdz*mf(1,1,nk+1)
          enddo
          enddo
        endif

        ! mult t13,t23 by density:
!$omp parallel do default(shared)  &
!$omp private(i,j,k)
        do k=1,nk+1
        do j=1,nj+1
        do i=1,ni+1
          t13(i,j,k)=t13(i,j,k)*0.5*(rf(i-1,j,k)+rf(i,j,k))
          t23(i,j,k)=t23(i,j,k)*0.5*(rf(i,j-1,k)+rf(i,j,k))
        enddo
        enddo
        enddo

        ! get dissipation rate:
        IF(idiss.eq.1.or.output_dissten.eq.1)THEN
!$omp parallel do default(shared)  &
!$omp private(i,j,k,tmp11,tmp22,tmp33,tmp12,tmp13,tmp23,tem)
          do k=2,nk
          do j=1,nj
          do i=1,ni
            tmp11=( c1(i,j,k)*t11(i,j,k-1)**2 + c2(i,j,k)*t11(i,j,k)**2 )
            tmp22=( c1(i,j,k)*t22(i,j,k-1)**2 + c2(i,j,k)*t22(i,j,k)**2 )
            tmp33=( c1(i,j,k)*t33(i,j,k-1)**2 + c2(i,j,k)*t33(i,j,k)**2 )
            tmp12=0.25*( c1(i,j,k)*( ( t12(i,j  ,k-1)**2 + t12(i+1,j+1,k-1)**2 )     &
                                   + ( t12(i,j+1,k-1)**2 + t12(i+1,j  ,k-1)**2 ) )   &
                        +c2(i,j,k)*( ( t12(i,j  ,k  )**2 + t12(i+1,j+1,k  )**2 )     &
                                   + ( t12(i,j+1,k  )**2 + t12(i+1,j  ,k  )**2 ) ) )
            tmp13=0.5*( t13(i,j,k)**2 + t13(i+1,j,k)**2 )
            tmp23=0.5*( t23(i,j,k)**2 + t23(i,j+1,k)**2 )
            dissten(i,j,k)= rcoef*( ( 2.0*( tmp33 ) + ( tmp13 + tmp23 )               &
                                     +2.0*( tmp11 + tmp22 ) + tmp12 )/(rf(i,j,k)**2)  &
                   -twodthree*(divx(i,j,k)**2) )
          enddo
          enddo
          enddo
        ENDIF

!-----------------------------------------------------------------------
!  axisymmetric grid:

      ELSEIF(axisymm.eq.1)THEN

!$omp parallel do default(shared)  &
!$omp private(i,j,k)
        DO k=1,nk

          do j=0,nj+1
          do i=0,ni+1
            divx(i,j,k)=(arh2(i)*ua(i+1,j,k)-arh1(i)*ua(i,j,k))*rdx*uh(i)   &
                       +(wa(i,j,k+1)-wa(i,j,k))*rdz*mh(1,1,k)
            if(abs(divx(i,j,k)).lt.smeps) divx(i,j,k)=0.0
          enddo
          enddo

          do j=1,nj
          do i=0,ni+1
            t11(i,j,k) = coef*rho(i,j,k)*(arf1(i+1)*ua(i+1,j,k)-arf2(i)*ua(i,j,k))*rdx*uh(i)
            t33(i,j,k) = coef*rho(i,j,k)*(wa(i,j,k+1)-wa(i,j,k))*rdz*mh(1,1,k)
            t12(i,j,k) = coef*(arh1(i)*va(i,j,k)-arh2(i-1)*va(i-1,j,k))*rdx*uf(i)  &
                        *0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k))
          enddo
          enddo

          !-----
          ! lateral boundary conditions:
          j = 1
          if(wbc.eq.3)then
            ! free slip b.c.
            t12(1,j,k) = 0.0
          elseif(wbc.eq.4)then
            ! no slip b.c.
            i = 1
            t12(1,j,k) = coef*2.0*va(1,j,k)*rdx*uf(1)   &
                      *0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k))
          endif
          if(ebc.eq.3)then
            ! free slip b.c.
            t12(ni+1,j,k) = t12(ni,j,k)
          elseif(ebc.eq.4)then
            ! no slip b.c.
            i = ni+1
            t12(ni+1,j,k) = -coef*2.0*va(ni,j,k)*rdx*uf(ni+1)   &
                      *0.5*(arf1(i)*rho(i-1,j,k)+arf2(i)*rho(i,j,k))
          endif
          !-----

          IF(k.ne.1)THEN
            do j=1,nj
            do i=1,ni+1
              t13(i,j,k)=coef*( (ua(i,j,k)-ua(i,j,k-1))*rdz*mf(1,1,k)  &
                               +(wa(i,j,k)-wa(i-1,j,k))*rdx*uf(i) )
              t23(i,j,k)=coef*(va(i,j,k)-va(i,j,k-1))*rdz*mf(1,1,k)
            enddo
            enddo
            !-----
            ! lateral boundary conditions:
            j = 1
            if(wbc.eq.3)then
              ! free slip b.c.
              t13(1,j,k) = 0.0
            elseif(wbc.eq.4)then
              ! no slip b.c.
              t13(1,j,k) = coef*2.0*wa(1,j,k)*rdx*uf(1)
            endif
            if(ebc.eq.3)then
              ! free slip b.c.
              t13(ni+1,j,k) = t13(ni,j,k)
            elseif(ebc.eq.4)then
              ! no slip b.c.
              t13(ni+1,j,k) = -coef*2.0*wa(ni,j,k)*rdx*uf(ni+1)
            endif
            !-----
          ENDIF  ! endif for k.ne.1

        ENDDO  ! enddo for k-loop

        !---------------------------------
        ! bottom/top boundary conditions:
        !---------------------------------

        if(bbc.eq.1)then
          ! free slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1)=t13(i,j,2)
          enddo
          enddo
          do j=1,nj
          do i=1,ni
            t23(i,j,1)=t23(i,j,2)
          enddo
          enddo
        elseif(bbc.eq.2)then
          ! no slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1)=coef*2.0*(ua(i,j,1)+umove)*rdz*mf(1,1,1)
          enddo
          enddo
          do j=1,nj
          do i=1,ni
            t23(i,j,1)=coef*2.0*(va(i,j,1)+vmove)*rdz*mf(1,1,1)
          enddo
          enddo
        elseif(bbc.eq.3)then
          ! semi-slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,1) = 0.5*( arf1(i)*(ust(i-1,j)**2)*(u1(i-1,j)/max(s1(i-1,j),0.01)) &
                              +arf2(i)*(ust(i  ,j)**2)*(u1(i  ,j)/max(s1(i  ,j),0.01)) )
          enddo
          enddo
          do j=1,nj
          do i=1,ni
            t23(i,j,1) = (ust(i,j)**2)*(v1(i,j)/max(s1(i,j),0.01))
          enddo
          enddo
        endif

        if(tbc.eq.1)then
          ! free slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,nk+1)=t13(i,j,nk)
          enddo
          enddo
          do j=1,nj
          do i=1,ni
            t23(i,j,nk+1)=t23(i,j,nk)
          enddo
          enddo
        elseif(tbc.eq.2)then
          ! no slip b.c.
          do j=1,nj
          do i=1,ni+1
            t13(i,j,nk+1)=-coef*2.0*ua(i,j,nk)*rdz*mf(1,1,nk+1)
          enddo
          enddo
          do j=1,nj
          do i=1,ni
            t23(i,j,nk+1)=-coef*2.0*va(i,j,nk)*rdz*mf(1,1,nk+1)
          enddo
          enddo
        endif

        ! mult t13,t23 by density:
!$omp parallel do default(shared)  &
!$omp private(i,j,k)
        do k=1,nk+1
        do j=1,nj
        do i=1,ni+1
          t13(i,j,k)=t13(i,j,k)*0.5*(arf1(i)*rf(i-1,j,k)+arf2(i)*rf(i,j,k))
          t23(i,j,k)=t23(i,j,k)*rf(i,j,k)
        enddo
        enddo
        enddo

        ! get dissipation rate:
        IF(idiss.eq.1.or.output_dissten.eq.1)THEN
!$omp parallel do default(shared)  &
!$omp private(i,j,k,tmp11,tmp22,tmp33,tmp12,tmp13,tmp23,tem)
          do k=2,nk
          do j=1,nj
          do i=1,ni
            tmp11=( c1(1,1,k)*t11(i,j,k-1)**2 + c2(1,1,k)*t11(i,j,k)**2 )
            tmp33=( c1(1,1,k)*t33(i,j,k-1)**2 + c2(1,1,k)*t33(i,j,k)**2 )
            tmp12=0.5*( c1(1,1,k)*( t12(i,j  ,k-1)**2 + t12(i+1,j  ,k-1)**2 ) &
                       +c2(1,1,k)*( t12(i,j  ,k  )**2 + t12(i+1,j  ,k  )**2 ) )
            tmp13=0.5*( t13(i,j,k)**2 + t13(i+1,j,k)**2 )
            tmp23=      t23(i,j,k)**2
            dissten(i,j,k)= rcoef*( ( 2.0*( tmp33 ) + ( tmp13 + tmp23 )               &
                                     +2.0*( tmp11 + tmp22 ) + tmp12 )/(rf(i,j,k)**2)  &
                   -twodthree*(divx(i,j,k)**2) )
          enddo
          enddo
          enddo
        ENDIF

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

      ELSE
        stop 333
      ENDIF

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

      if(timestats.ge.1) time_diffu=time_diffu+mytime()

      end subroutine diff2def

  END MODULE diff2_module


SUBROUTINE generate_disc
! Subroutine creates a self-gravitating disc, constrained by M_d and dot(M_d)
! We fix Q=1, and follow a similar procedure to Clarke (2009)

use stardata
use eosdata
use embryodata, only: fg

implicit none

integer :: i
real :: mtry, mdot_try,sigma_old,dT,fine

mtry = 0.0
i=0

! TODO - randomly generate fg, q_disc in some way

fg = 0.01 + ran2(iseed)*0.01
q_disc = 0.5 +ran2(iseed)*0.5

mdisc = q_disc*mstar
mdotvisc = -8.5 + 3.5*ran2(iseed)
mdotvisc = 10.0**(mdotvisc)*umass/yr

print*, 'Generating disc for star ',istar,': ', fg,mstar, q_disc, mdotvisc*yr/umass

sigma_old = 1.0e6

IF(allocated(sigma_d)) deallocate(sigma_d)
IF(allocated(cs_d)) deallocate(cs_d)
IF(allocated(omega_d)) deallocate(omega_d)
IF(allocated(betac_d)) deallocate(betac_d)
IF(allocated(mjeans)) deallocate(mjeans)
IF(allocated(r_d)) deallocate(r_d)
IF(allocated(H_d)) deallocate(H_d)
IF(allocated(alpha_d)) deallocate(alpha_d)
IF(allocated(T_d)) deallocate(T_d)
IF(allocated(kappa_d)) deallocate(kappa_d)
IF(allocated(gamma_d)) deallocate(gamma_d)
IF(allocated(tau_d)) deallocate(tau_d)
IF(allocated(gamma_j)) deallocate(gamma_J)

allocate(sigma_d(nrannuli))
allocate(cs_d(nrannuli))
allocate(omega_d(nrannuli))
allocate(betac_d(nrannuli))
allocate(mjeans(nrannuli))
allocate(gamma_J(nrannuli))
allocate(r_d(nrannuli))
allocate(H_d(nrannuli))
allocate(alpha_d(nrannuli))
allocate(T_d(nrannuli))
allocate(kappa_d(nrannuli))
allocate(gamma_d(nrannuli))
allocate(tau_d(nrannuli))

!print*, i, nrannuli, mtry,mdisc

DO WHILE(mtry < mdisc .and. i<nrannuli)

i = i+1
r_d(i) = rin + (i-1)*dr

omega_d(i) = sqrt(G*mstar/(r_d(i)*r_d(i)*r_d(i)))

! Iterate to find sigma

	sigma_d(i) = sigma_old

	dT = 1.0e30
	ntries = 0
	fine = 0.01
	DO WHILE(ABS(dT)> tolerance)

!	Calculate sound speed assuming fixed Q

	cs_d(i) = pi*G*sigma_d(i)/(omega_d(i))

!	Calculate scale height

	H_d(i) = cs_d(i)/omega_d(i)

	rhomid = sigma_d(i)/(2.0*H_d(i))

!	Use EoS to calculate tau, gamma, betac

	CALL eos_cs(rhomid, cs_d(i))

	gamma_d(i) = gammamuT(1)
	T_d(i) = gammamuT(3)
	kappa_d(i) = gammamuT(4)

	tau_d(i) = sigma_d(i)*kappa_d(i)
	betac_d(i) = (tau_d(i)+1.0/tau_d(i))*cs_d(i)*cs_d(i)*omega_d(i)/&
			(sigma_SB*(T_d(i)**4.0)*gamma_d(i)*(gamma_d(i)-1.0))

!	Calculate alpha from this value --> accretion rate

	alpha_d(i) = 4.0/(9.0*gamma_d(i)*(gamma_d(i)-1.0)*betac_d(i))

!	print*, alpha_d(i), gamma_d(i),betac_d(i),cs_d(i),omega_d(i)
!	Compare with imposed accretion rate

	mdot_try = 3.0*pi*alpha_d(i)*cs_d(i)*cs_d(i)*sigma_d(i)/omega_d(i)

	dT = (mdotvisc-mdot_try)/mdotvisc

	sigma_old = sigma_d(i)
!	sigma_d(i) = sigma_d(i)*(1.0 + dT*0.01)
	sigma_d(i) = sigma_d(i)*(1.0 +dT/(abs(dT))*fine)

!	print*,i, sigma_d(i), sigma_old, dT, mdot_try, mdotvisc
	ntries = ntries + 1

	IF (ntries>500) THEN
	fine = fine/10.0
	ntries = 0
	ENDIF
	ENDDO

!	Check for MRI activation
!	If so, then set alpha=0.01 and readjust sigma to maintain mdotvisc

	IF(T_d(i)>1000.0) THEN
!	print*, 'MRI active ',r/udist, T, alpha, sigma
	alpha_d(i) = 0.01
	sigma_d(i) = mdotvisc*omega_d(i)/(3.0*pi*alpha_d(i)*cs_d(i)*cs_d(i))
!	print*, 'MRI active ', T, alpha, sigma
	ENDIF

 sigma_d(i+1) = sigma_old
 mjeans(i) = 4.0*1.412*pi*pi*pi/(3.0*G)

 mjeans(i) = mjeans(i)*cs_d(i)*cs_d(i)*cs_d(i)/(omega_d(i)*(1.0+1.0/sqrt(betac_d(i))))

 IF(alpha_d(i)<0.1) THEN
      gamma_j(i) = 2.0*(9.0*alpha_d(i)*gamma_d(i)*(gamma_d(i)-1.0)/4.0 - 1/betac_d(i))
   ELSE
      gamma_j(i) = 2.0*(9.0*0.1*gamma_d(i)*(gamma_d(i)-1.0)/4.0 - 1/betac_d(i))
   ENDIF

   gamma_j(i) = 1.0/gamma_j(i)

!	Calculate enclosed Mass and mass ratio

	mtry = mtry + twopi*r_d(i)*sigma_d(i)*dr

IF(i==nrannuli) THEN
print*, 'ERROR: nrannuli insufficient'
print*, 'Either recompile or increase dr in .params file'
STOP
ENDIF
ENDDO

rout = r_d(i)
irout =i

END SUBROUTINE generate_disc


      SUBROUTINE VINTH2P(DATI,DATO,HBCOFA,HBCOFB,P0,PLEVI,PLEVO,INTYP,
     +                   ILEV,PSFC,SPVL,KXTRP,IMAX,NLAT,NLEVI,NLEVIP1,
     +                   NLEVO)
C
C****     THIS ROUTINE INTERPLOATES CCM2/3 HYBRID COORDINATE DATA
C****     TO PRESSURE COORDINATES USING PRESSURE SURFACES AS THE
C****     COORDINATE SURFACE WHERE THE INTERPOLATION IS DONE.  THE
C****     TYPE OF INTERPOLATION IS CURRENTLY A VARIANT OF TRANSFORMED
C****     PRESSURE COORDINATES WITH THE  INTERPOLATION TYPE
C****     SPECIFIED BY INTYP.  ALL HYBRID COORDINATE VALUES ARE
C****     TRANSFORMED TO PRESSURE VALUES. WHERE THE
C****     FORMULA FOR THE PRESSURE OF A HYBRID SURFACE IS;
C****          P(K) = HBCOFA(LEVH,K)*P0 + HBCOFB(LEVH,K)*PSFC
C****     WHERE,
C****          HBCOFA - IS THE "A" OR PRESSURE HYBRID COEF
C****          LEVH   - IS THE LAYER SURFACE (INTERFACE=1 MIDPOINT=2)
C****          P0     - IS THE BASE PRESSURE IN MB
C****          K      - THE LEVEL INDEX (RUNNING FROM TOP TO BOTTOM)
C****          HBCOFB - IS THE "B" OR SIGMA COEFICIENT
C****          P(K)   - IS THE PRESSURE OF A HYBRID SURFACE IN MB.
C****          PSFC   - IS THE SURFACE PRESSURE IN PASCALS
C****                   (MB = .01*PASCALS
C
C****     FOR HYBRID DATA AT LEVEL INTERFACES SINCE THERE IS ONE
C****     MORE VERTICAL LEVEL FOR INTERFACES THAN FOR LEVEL MIDPOINTS
C****     IT IS ASSUNMED THAT THE FIRST INTERFACE LEVEL WITH A DATA
C****     VALUE IS THE SECOND LEVEL FROM THE TOP.
C
C****     ON INPUT-
C****        DATI    - 3 DIMENSIONAL ARRAY (I,J,KI) CONTAINING DATA
C****                  ON HYBRID SURFACES  WHERE I IS LONGTIUDE, J
C****                  IS LATITUDE AND K IS THE VERTICAL HYBRID
C****                  COORDINATE.  THE VERTICAL DATA RUN TOP TO BOTTOM.
C****                  SIGMA DATA WITH THE DATA ORDERED TOP TO BOTTOM.
C****        HBCOFA  - 2 DIMENSIONAL ARRAY CONTAINING "A" OR PRESSURE
C****                  COEFICIENTS FOR COMPUTING PRESSURE AT A LEVEL.
C****                  ARRAY IS 2XNLEVIP1.  THE 1ST INDEX TAKES ON
C****                  THE VALUE OF EITHER
C****                   1 - FOR LEVEL INTERFACES (OR 1/2 LEVELS) OR;
C****                   2 - FOR LEVEL MIDPOINTS  (OR FULL LEVELS WHERE
C****                       VIRTUALLY ALL VARIABLES ARE LOCATED)
C****                  NOTE THAT COEFICIENTS ARE SCALED TO YIELD A
C****                  PRESSURE IN MB.  THEY ARE ORDERED FROM TOP
C****                  OF THE MODEL TO THE BOTTOM.
C****        HBCOFB  - SAME AS HCOFA BUT FOR THE "B" OR SIGMA COEFICIENT
C****        P0      - BASE PRESSURE IN MB FOR COMPUTING PRESSURE
C****                  OF A HYBRID COORDINATE LEVEL
C****        PLEVI -  1 DIMENSIONAL ARRAY TO HOLD PRESSURE VALUES
C****                  OF HYBRID SURFACES FOR A VERTICAL COLUMN
C****                  SLICE
C****        PLEVO   - LIST OF OUTPUT PRESSURE SURFACES IN MB
C****                  LOW TO HIGH PRESSURE
C****        INTYP   - A FLAG INDICATING INTERPOLATION FOR EACH
C****                  FIELD (1 - LINEAR,2 - LOG ,3 - LOG LOG)
C****                  WHERE EACH INTERPOLATION IS DONE IN TRANSFORMED
C****                  PRESSURE COORDINATES.
C****        ILEV    - FLAG TO SHOW WHETHER FIELD IS ON LEVEL INTERFACE
C****                  1/2 LEVEL WHICH HAS A VALUE OF 1 OR A LEVEL
C****                  MIDPOINT A FULL LEVEL (WHERE ALMOST ALL VARIABLES
C****                  ARE LOCATED
C****        PSFC    - MODEL SFC PRESSURE IN PASCALS (WILL BE CONVERTED
C****                  TO MB)
C****        VCOLI   - ARRAY TO STORE A LONGITUDINAL VERTICAL SLICE OF
C****                  INPUT DATA (IMAX BY NLEVI).
C****        VCOLO   - SAME BUT FOR OUTPUT DATA (IMAX BY NLEVO)
C****        IMAX    - LONGITUDINAL DIMENSION OF THE DATA.
C****        NLAT    - LATITUDINAL DIMENSION OF THE DATA.
C****        NLEVI   - NO. OF LEVELS FOR THE HYBRID DATA
C****        NLEVIP1 - NLEVI + 1
C****        NLEVO   - NUMBER OF OUTPUT LEVELS FOR PRESSURE DATA
C****        KXTRP   - FLAG WHICH INDICATES WHETHER OR NOT
C****                  EXTRAPOLATION WILL BE USED WHEN THE OUTPUT
C****                  PRESSURE SURFACE IS BELOW THE LOWEST LEVEL
C****                  OF THE MODEL.
C****                     0 - DON'T EXTRAPOLATE USE SPECIAL VALUE SPVL
C****                     1 - EXTRAPOLATE DATA
C****        SPVL    - SPECIAL VALUE TO USE WHEN DATA IS NOT
C****                  EXTRAPOLATED
C
C****     ON OUTPUT-
C****        DATO  - 3 DIMENSIONAL ARRAY TO HOLD DATA INTERPOLATED
C****                TO PRESSURE SURFACES.
C
      IMPLICIT NONE
      DOUBLE PRECISION SPVL,DATI,DATO,HBCOFA,HBCOFB,PLEVI,PLEVO,PSFC,P0
      DOUBLE PRECISION A2LN,A1
      INTEGER INTYP,ILEV,IMAX,NLAT,NLEVI,NLEVIP1,NLEVO,KXTRP
      INTEGER I,J,K,KP,KPI,IPRINT
C
      DIMENSION DATI(IMAX,NLAT,NLEVI),DATO(IMAX,NLAT,NLEVO),
     +          HBCOFA(NLEVIP1),HBCOFB(NLEVIP1),PLEVI(NLEVIP1),
     +          PLEVO(NLEVO),PSFC(IMAX,NLAT)
C
C
C
C****     STATEMENT FCN. FOR DOUBLE ALOG. INTERP ON PRESSURE SURFACES
C****     PRESUMES PRESSURE IS IN MB
C
      A2LN(A1) = DLOG(DLOG(A1+2.72D0))
C
C****     STATEMENT FCN. FOR DOUBLE ALOG. INTERP ON SIGMA SURFACES.
C****     SETS UP ROUGH UPPER BPOUND SIMILAR TO STATEMENT FCN FOR
C****     PRESSURE. I.E.    FIXED VALUE LN(LN(P) = LN(LN(FIXED VAL)
C****     AT .001 SIGMA OR ABOUT 1 MB
C
C     A2LN(A1)=ALOG(ALOG(A1+1.001))

C
C****
C****
C
      DO 70 J = 1,NLAT
          DO 60 I = 1,IMAX
c ==========================================================
           if (psfc(i,j).eq.spvl) then
               do k=1,nlevo
                  dato(i,j,k) = spvl
               end do
               go to 60
           end if
c ===========================================================

C
C****     GET PRESSURE VALUES FOR HYBRID SURFACES FOR THIS POINT
C****     AND FOR THE TYPE OF MODEL SURFACE THE DATA IS ON.
C****     INTERFACE DATA STARTS AT THE SECOND INTERFACE LEVEL SO
C****     IF THE DATA IS ON THOSE LEVELS START THE
C
              DO K = 1,NLEVI
                  KPI = K
                  PLEVI(K) = (HBCOFA(KPI)*P0) +
     +                       HBCOFB(KPI)* (PSFC(I,J)*.01D0)
              END DO
              IPRINT = 1
C      IF (I.EQ.1.AND.J.EQ.1.AND.IPRINT.EQ.1) THEN
C         PRINT 601
C  601    FORMAT(/,' PRINTOUT FROM VINTHB ')
C         PRINT 602,I,J,NLEVI,NLEVO,IMAX,ILEV
C  602    FORMAT(' I,J,NLEVI,NLEVO,IMAX,ILEV ',6I4)
C         PRINT 603,PSFC(I,J),P0
C  603    FORMAT(' PSFC,P0 ',1P2E12.5)
C         CALL PRNT('HBCOFA',HBCOFA,2,NLEVIP1,1,1)
C         CALL PRNT('HBCOFB',HBCOFB,2,NLEVIP1,1,1)
C         CALL PRNT(' PLEVI',PLEVI,NLEVI,1,1,1)
C         CALL PRNT(' PLEVO',PLEVO,NLEVO,1,1,1)
C      ENDIF
C
C****     CALL P2HBD TO PERFORM VERTICAL INTERP. THEN TRANSFER DATA TO
C****     THE OUTPUT ARRAY
C
              DO 50 K = 1,NLEVO
C
C****     CHECK FOR BRACKETING LEVEL KP WILL BE THE INPUT LEVEL THAT
C****     IS THE UPPER PORTION OF 2 INPUT BRACKETING LEVELS.
C
C****     IF BRANCH FOR MODEL TOP
C
                  IF (PLEVO(K).LE.PLEVI(1)) THEN
                      KP = 1
                      GO TO 30
C
C****     IF BRANCH FOR LEVEL BELOW LOWEST HYBRID LEVEL
C
                  ELSE IF (PLEVO(K).GT.PLEVI(NLEVI)) THEN
                      IF (KXTRP.EQ.0) THEN
                          DATO(I,J,K) = SPVL
                          GO TO 40
                      ELSE
                          KP = NLEVI - 1
                          GO TO 30
                      END IF
C
C****     IF BRANCH FOR TO CHECK IF OUTPOT LEVEL IN BETWEEN
C****     2 LOWEST HYBRID LEVELS
C
                  ELSE IF (PLEVO(K).GE.PLEVI(NLEVI-1)) THEN
                      KP = NLEVI - 1
                      GO TO 30
C
C****     IF BRANCH FOR MODEL INTERIOR
C****     LOOP THROUGH INPUT LEVELS TILL YOU ARE BRACKETING
C****     OUTPUT LEVEL
C
                  ELSE
                      KP = 0
   20                 CONTINUE
                      KP = KP + 1
                      IF (PLEVO(K).LE.PLEVI(KP+1)) GO TO 30
                      IF (KP.GT.NLEVI) THEN
                          WRITE (6,FMT=25) KP,NLEVI
   25                     FORMAT (' KP.GT.KLEVI IN P2HBD.  KP,KLEVI= ',
     +                           2I5)
C            CALL PRNT(' PLEVI',PLEVI,NLEVIP1,1,1,1)
C            CALL PRNT(' PLEVO',PLEVO,NLEVO,1,1,1)
C            CALL ABORT(' KP.GT.NLEVI IN P2HBD')
                      END IF
                      GO TO 20
                  END IF
   30             CONTINUE
C
C****     LEVEL BRACKETED PICK TYPE OF INTERP.
C
C
C****     LINEAR INTERP.
C
                  IF (INTYP.EQ.1) THEN
                      DATO(I,J,K) = DATI(I,J,KP) +
     +                              (DATI(I,J,KP+1)-DATI(I,J,KP))*
     +                              (PLEVO(K)-PLEVI(KP))/
     +                              (PLEVI(KP+1)-PLEVI(KP))
C
C****     LOG INTERPOLATION.
C
                  ELSE IF (INTYP.EQ.2) THEN
                      IPRINT = 1
C      IF (I.EQ.1.AND.IPRINT.EQ.1) THEN
C         PRINT 101,I,J,K,KP,ILEV
C  101    FORMAT('  IN S2HBD I,J,K,KP,ILEV ',5I3)
C         PRINT 102,DATI(I,J,KP),DATI(I,J,KP+1),PLEVO(K),
C     *             PLEVI(KP),PLEVI(KP+1)
C  102    FORMAT(' DATI(KP),DATI(KP+1),PLEVO(K),',
C     *          'PLEVI(KP),PLEVI(KP+1) ',
C     *          /,1X,1P5E12.5)
C      ENDIF
                      DATO(I,J,K) = DATI(I,J,KP) +
     +                              (DATI(I,J,KP+1)-DATI(I,J,KP))*
     +                              DLOG(PLEVO(K)/PLEVI(KP))/
     +                              DLOG(PLEVI(KP+1)/PLEVI(KP))
C
C****     FOR LOG LOG INTERP. NOTE A2LN IS A STATEMENT FCN.
C
                  ELSE IF (INTYP.EQ.3) THEN
                      DATO(I,J,K) = DATI(I,J,KP) +
     +                              (DATI(I,J,KP+1)-DATI(I,J,KP))*
     +                              (A2LN(PLEVO(K))-A2LN(PLEVI(KP)))/
     +                              (A2LN(PLEVI(KP+1))-A2LN(PLEVI(KP)))
                  END IF
   40             CONTINUE
C
   50         CONTINUE
   60     CONTINUE
   70 CONTINUE
      RETURN
      END
      SUBROUTINE PRNT(IFLD,A,IM,JM,IS,JS)
      DOUBLE PRECISION A
      CHARACTER*(*) IFLD
      DIMENSION A(IM,JM)

      PRINT 10,IFLD
   10 FORMAT (1X,/,' FIELD ',A)
      DO 20 J = 1,JM,JS
          PRINT 13,J
   13     FORMAT (' J=',I4)
          PRINT 15, (A(I,J),I=1,IM,IS)
   15     FORMAT (1X,1P,10D12.5)
   20 CONTINUE
      RETURN
      END


(func listLengthHelper (list n)
    (cond (equal list '()) n
        (listLengthHelper (tail list) (plus n 1))
    )
)

(func listLength (list) (listLengthHelper list 0))

(listLength '(1 2 3 4 5 6))


************************************************************************
*
*     Subroutine LADLOAD                            Called by: ESTLOAD
*
*     calculate LAD loads for entire estimation period, user-defined
*     seasons, and individual months
*
*     local vars
*     ----------
*     LOADLAD  mean LAD load (entire period, season, or indiv. month)
*     MONSTR   string denoting month of year
*     NOBS     no. of observations used to estimate the seasonal load
*     OLDMONTH tracking variable used to determine when month ends
*     OLDYEAR  tracking variable used to determine when month ends
*     SXLEST   subset of XLEST for seasonal or monthly loads
*     TSTR     string denoting time period covered by load estimate
*     VARLAD   variance of LOADLAD
*
************************************************************************
      SUBROUTINE LADLOAD(BCLAD,EDATE,LDOPT,LFACTOR,NOBSC,NOBSE,NPAR,
     &                   NSEAS,PARLAD,SBEG,SEOPT,SEND,XLCAL,XLEST,YLCAL,
     &                   PLOADLAD,NOBSCI,LDOUT)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 LDOPT,LDOUT,NOBSC,NOBSCI,NOBSE,NPAR,NSEAS,SEOPT
      DOUBLE PRECISION BCLAD,LFACTOR
      DOUBLE PRECISION PLOADLAD(*),PARLAD(*),YLCAL(*)
      DOUBLE PRECISION XLCAL(NOBSCI,*),XLEST(NOBSE,*)
      CHARACTER*4 SBEG(*),SEND(*)
      CHARACTER*8 EDATE(*)
*
*     local vars
*
      INTEGER*4 I,IMO,IYR,NOBS,OLDMONTH,OLDYEAR
      DOUBLE PRECISION LOADLAD,VARLAD,SXLEST(NOBSE,MAXPARMS)
      CHARACTER*13 TSTR
      CHARACTER*4 MONSTR(12) /'Jan.','Feb.','Mar.','Apr.','May ','June',
     &                        'July','Aug.','Sep.','Oct.','Nov.','Dec.'/
*
*     local var, not used but needed in CALLS
*
      DOUBLE PRECISION PLOAD(NOBSE)
*
*     function declaration
*
      INTEGER*4 GETINT
*
*     format statements
*
 1000 FORMAT(//,T15,'LAD Load Estimates',/,T15,18('-'),//,T26,'Mean',
     &       T33,'Standard',/,T18,'N',T26,'Load',T36,'Error',/,T15,
     &       26('-'))
 2000 FORMAT(//,T15,'LAD Load Estimates',/,T15,18('-'),//,T26,'Mean',/,
     &       T18,'N',T26,'Load',/,T15,15('-'))
 3000 FORMAT('Season',I3,'    ')
 4000 FORMAT(A4,1X,I4)
*
*     output heading for LAD load table
*
      IF (SEOPT .NE. 1) THEN
         WRITE(LDOUT,1000)
      ELSE
         WRITE(LDOUT,2000)
      ENDIF
*
*     estimate LAD loads for the entire estimation period; output mean
*     load and standard error
*
      CALL LADLOAD2(NPAR,NOBSE,XLEST,BCLAD,LOADLAD,PARLAD,PLOADLAD,
     &              NOBSE)
      IF ((SEOPT .EQ. 2) .OR. (SEOPT .EQ. 3))
     &   CALL JKNIFE(NPAR,NOBSC,XLCAL,YLCAL,NOBSE,XLEST,VARLAD,NOBSCI,
     &               NOBSE)
      CALL OUTEST('Est. Period  ',LFACTOR,LOADLAD,NOBSE,SEOPT,VARLAD,
     &            LDOUT)
*
*     develop seasonal LAD load estimates.  Begin by selecting the
*     "observations" of the explanatory variables that fall within the
*     current season (SETXL2), then calculate loads (LADLOAD2) and
*     output results (OUTEST).
*
      DO 10 I=1,NSEAS
         WRITE(TSTR,3000) I
         CALL SETXL2(EDATE,NOBSE,NOBS,NPAR,SBEG(I),SEND(I),XLEST,SXLEST)
         CALL LADLOAD2(NPAR,NOBS,SXLEST,BCLAD,LOADLAD,PARLAD,PLOAD,
     &                 NOBSE)
         IF ((SEOPT .EQ. 2) .OR. (SEOPT .EQ. 3))
     &     CALL JKNIFE(NPAR,NOBSC,XLCAL,YLCAL,NOBS,SXLEST,VARLAD,NOBSCI,
     &                 NOBSE)
         CALL OUTEST(TSTR,LFACTOR,LOADLAD,NOBS,SEOPT,VARLAD,LDOUT)
 10   CONTINUE
*
*     develop monthly LAD load estimates
*
      IF ((LDOPT .EQ. 2) .OR. (LDOPT .EQ. 3)) THEN
         NOBS = 0
         OLDMONTH = GETINT(EDATE(1),5,6)
         OLDYEAR = GETINT(EDATE(1),1,4)
         DO 20 I=1,NOBSE
            IF ((GETINT(EDATE(I),5,6).EQ.OLDMONTH) .AND.
     &          (GETINT(EDATE(I),1,4).EQ.OLDYEAR)) THEN
               CALL SETXL3(NOBS,NPAR,XLEST,SXLEST,NOBSE,I)
            ELSE
               IMO = GETINT(EDATE(I-1),5,6)
               IYR = GETINT(EDATE(I-1),1,4)
               WRITE(TSTR,4000) MONSTR(IMO),IYR
               CALL LADLOAD2(NPAR,NOBS,SXLEST,BCLAD,LOADLAD,PARLAD,
     &                       PLOAD,NOBSE)
               IF ((SEOPT .EQ. 2) .OR. (SEOPT .EQ. 3))
     &           CALL JKNIFE(NPAR,NOBSC,XLCAL,YLCAL,NOBS,SXLEST,VARLAD,
     &                       NOBSCI,NOBSE)
               CALL OUTEST(TSTR,LFACTOR,LOADLAD,NOBS,SEOPT,VARLAD,LDOUT)
               OLDMONTH = GETINT(EDATE(I),5,6)
               OLDYEAR = GETINT(EDATE(I),1,4)
               NOBS = 0
               CALL SETXL3(NOBS,NPAR,XLEST,SXLEST,NOBSE,I)
            ENDIF
 20      CONTINUE
         IMO = GETINT(EDATE(I-1),5,6)
         IYR = GETINT(EDATE(I-1),1,4)
         WRITE(TSTR,4000) MONSTR(IMO),IYR
         CALL LADLOAD2(NPAR,NOBS,SXLEST,BCLAD,LOADLAD,PARLAD,PLOAD,
     &                 NOBSE)
         IF ((SEOPT .EQ. 2) .OR. (SEOPT .EQ. 3))
     &     CALL JKNIFE(NPAR,NOBSC,XLCAL,YLCAL,NOBS,SXLEST,VARLAD,NOBSCI,
     &                 NOBSE)
         CALL OUTEST(TSTR,LFACTOR,LOADLAD,NOBS,SEOPT,VARLAD,LDOUT)
      ENDIF

      RETURN
      END


PROGRAM EXAMPLE
  USE LA_PRECISION, ONLY: WP => SP
  USE f77_LAPACK, ONLY: F77GESV => LA_GESV
  USE f95_LAPACK, ONLY: F95GESV => LA_GESV

  USE f77_LAPACK, ONLY: F77GEEV => LA_GEEV
  USE f95_LAPACK, ONLY: F95GEEV => LA_GEEV

  USE f77_LAPACK, ONLY: F77GESDD => LA_GESDD
  USE f95_LAPACK, ONLY: F95GESDD => LA_GESDD

  USE f77_LAPACK, ONLY: F77GESVD => LA_GESVD
  USE f95_LAPACK, ONLY: F95GESVD => LA_GESVD

  IMPLICIT NONE

  INTEGER :: INFO, J, LDA, LDB, N, NRHS, LWORK, S, I
  INTEGER, ALLOCATABLE :: IPIV(:)
  INTEGER, ALLOCATABLE :: IWORK(:)
  REAL :: T0, T1, T2
  REAL(WP) ::  CPU_MFLP, RTC_MFLP, FLP
  DOUBLE PRECISION RTC, BEFORE, AFTER, RTC_TIME, CPU1_TIME
  REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), AA(:,:), BB(:,:)
  REAL(WP), ALLOCATABLE :: WR(:), WI(:), VL(:,:), VR(:,:)
  REAL(WP), ALLOCATABLE :: WORK(:)

  print *, 'N = '
  read (*,*) N

  NRHS = 1; S=10
  print * ,'====================================================='
  print * ,'        LAPACK95 TIMING routine, Single Real Version '
  print * ,'====================================================='
  print *,'N , NRHS =  ', N, NRHS
  ALLOCATE( A(N,N), B(N,NRHS), IPIV(N), AA(N,N), BB(N,NRHS) )
  ALLOCATE(WR(N), WI(N), VL(N,N), VR(N,N))
  ALLOCATE(IWORK(10*N))

  CALL RANDOM_NUMBER(A)
  DO J = 1, NRHS
    B(:,J) = SUM( A, DIM=2 )*J
  ENDDO
  AA = A; BB = B
  LDA = N; LDB = N
! DGESV
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i =1, s
    before = rtc()
    CALL CPU_TIME(T0); CALL CPU_TIME(T1); T0 = T1-T0
    CALL F77GESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME+ (T2-T1-T0)
    after = rtc()
    RTC_TIME = RTC_TIME + (after - before)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  ENDDO
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  Flp = 0.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L77GESV ',  CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L77GESV ',  RTC_TIME, RTC_MFLP
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i =1, s
    A = AA; B = BB
    CALL CPU_TIME(T1);
    CALL F95GESV( A, B ); CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)

    A = AA; B = BB
    before = rtc()
    CALL F95GESV( A, B ); CALL CPU_TIME(T2)
    after = rtc()
    RTC_TIME = RTC_TIME + (after - before)
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S

  FLP = 0.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L95GESV ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L95GESV ', RTC_TIME, RTC_MFLP

! DGEEV, eigenvalues only
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  PRINT *,' DGEEV, eigenvalues only'
  DO I=1,S
    A = AA; LWORK = 5*N
    ALLOCATE(WORK(LWORK))
    CALL CPU_TIME(T1);
    CALL F77GEEV( 'N', 'N', N, A, LDA, WR, WI, VL, LDA, VR, &
&     LDA, WORK, LWORK, INFO )
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA; LWORK = 5*N
    BEFORE = RTC()
    CALL F77GEEV( 'N', 'N', N, A, LDA, WR, WI, VL, LDA, VR, &
&     LDA, WORK, LWORK, INFO )
    AFTER = RTC()
    RTC_TIME = RTC_TIME + (AFTER - BEFORE)
    DEALLOCATE(WORK)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  ENDDO
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 10.00*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L77GEEV ',  CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L77GEEV ',  RTC_TIME, RTC_MFLP
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  DO I=1,S
    A = AA
    CALL CPU_TIME(T1);
    CALL F95GEEV(A, WR, WI, INFO = INFO)
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA
    BEFORE = RTC()
    CALL F95GEEV(A, WR, WI, INFO = INFO)
    AFTER = RTC()
    RTC_TIME = RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  ENDDO
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 10.00*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L95GEEV ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L95GEEV ', RTC_TIME, RTC_MFLP
! DGEEV, eigenvalues and right eigenvectors
  print *,' DGEEV, eigenvalues and right eigenvectors'
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i=1,s
    A = AA; LWORK = 5*N
    ALLOCATE(WORK(LWORK))
    CALL CPU_TIME(T1);
    CALL F77GEEV( 'N', 'V', N, A, LDA, WR, WI, VL, LDA, VR, &
&     LDA, WORK, LWORK, INFO )
    CALL CPU_TIME(T2)
    DEALLOCATE(WORK)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA; LWORK = 5*N
    ALLOCATE(WORK(LWORK))
    BEFORE = RTC()
    CALL F77GEEV( 'N', 'V', N, A, LDA, WR, WI, VL, LDA, VR, &
&     LDA, WORK, LWORK, INFO )
    AFTER =  RTC()
    DEALLOCATE(WORK)
    RTC_TIME = RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 26.33*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L77GEEV(2) ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L77GEEV(2) ', RTC_TIME, RTC_MFLP
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  DO I=1,S
    A= AA
    CALL CPU_TIME(T1);
    CALL F95GEEV(A, WR, WI, VL, INFO = INFO)
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF

    A= AA
    BEFORE = rtc()
    CALL F95GEEV(A, WR, WI, VL, INFO = INFO)
    AFTER = RTC()
    RTC_TIME = RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  ENDDO
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 26.33*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L95GEEV(2) ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L95GEEV(2) ', RTC_TIME, RTC_MFLP
! DGESDD, singular values only
   print *, ' DGESDD, singular values only'
   CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
   do i = 1, s
     A = AA;  LWORK =10*N*N + 20*N
     ALLOCATE(WORK(LWORK))
     CALL CPU_TIME(T1)
     CALL F77GESDD( 'N', N, N, A, LDA, WR, VL, LDA, VR, LDA, WORK, &
&      LWORK, IWORK, INFO )
     CALL CPU_TIME(T2)
     DEALLOCATE(WORK)
     CPU1_TIME = CPU1_TIME + ( T2-T1-T0 )
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
     A = AA;  LWORK =10*N*N + 20*N
     ALLOCATE(WORK(LWORK))
     BEFORE = RTC()
     CALL F77GESDD( 'N', N, N, A, LDA, WR, VL, LDA, VR, LDA, WORK, &
&      LWORK, IWORK, INFO )
     AFTER = RTC()
     DEALLOCATE(WORK)
     RTC_TIME=RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
   enddo
   CPU1_TIME = CPU1_TIME/S
   RTC_TIME = RTC_TIME/S
   FLP = 2.67*(DBLE(N)*(N*DBLE(N)))
   IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
   ENDIF
   IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
   ENDIF
   WRITE(*,*) 'CPUTIME and MFLOPS of L77GESDD ', CPU1_TIME, CPU_MFLP
   WRITE(*,*) 'RTCTIME and MFLOPS of L77GESDD ', RTC_TIME, RTC_MFLP
   CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
   do i=1,s
     A = AA
     CALL CPU_TIME(T1)
     CALL F95GESDD( A, WR, JOB='N', INFO=INFO)
     CALL CPU_TIME(T2)
     CPU1_TIME = CPU1_TIME + ( T2-T1-T0 )
     IF (INFO .NE. 0) THEN
       PRINT *,'INFO = ', INFO
       EXIT
     ENDIF
     A = AA
     BEFORE = RTC()
     CALL F95GESDD( A, WR, JOB='N', INFO=INFO)
     AFTER = RTC()
     RTC_TIME=RTC_TIME + (AFTER - BEFORE)
     IF (INFO .NE. 0) THEN
       PRINT *,'INFO = ', INFO
       EXIT
     ENDIF
   enddo
   CPU1_TIME = CPU1_TIME/S
   RTC_TIME = RTC_TIME/S
   FLP = 2.67*(DBLE(N)*(N*DBLE(N)))
   IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
   ENDIF
   IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
   ENDIF
   WRITE(*,*) 'CPUTIME and MFLOPS of L95GESDD ', CPU1_TIME, CPU_MFLP
   WRITE(*,*) 'RTCTIME and MFLOPS of L95GESDD ', RTC_TIME, RTC_MFLP

! DGESDD, singular values & left and right singular vectors
   print *,' DGESDD, singular values & left and right singular vectors'
   CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i = 1, s
    A = AA;  LWORK =10*N*N + 20*N
    ALLOCATE(WORK(LWORK))
    CALL CPU_TIME(T1)
    CALL F77GESDD( 'S', N, N, A, LDA, WR, VL, LDA, VR, LDA, WORK, &
&     LWORK, IWORK, INFO )
    CALL CPU_TIME(T2)
    DEALLOCATE(WORK)
    CPU1_TIME = CPU1_TIME + ( T2-T1-T0 )
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA;  LWORK =10*N*N + 20*N
    ALLOCATE(WORK(LWORK))
    BEFORE = RTC()
    CALL F77GESDD( 'S', N, N, A, LDA, WR, VL, LDA, VR, LDA, WORK, &
&     LWORK, IWORK, INFO )
    AFTER = RTC()
    DEALLOCATE(WORK)
    RTC_TIME=RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 6.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L77GESDD(2) ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L77GESDD(2) ', RTC_TIME, RTC_MFLP
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i=1,s
    A = AA
    CALL CPU_TIME(T1)
    CALL F95GESDD( A, WR, VL, VR, JOB='N', INFO=INFO)
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + ( T2-T1-T0 )
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA
    BEFORE = RTC()
    CALL F95GESDD( A, WR, VL, VR, JOB='N', INFO=INFO)
    AFTER = RTC()
    RTC_TIME=RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 6.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L95GESDD(2) ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L95GESDD(2) ', RTC_TIME, RTC_MFLP
! DGESVD, singular values & left and right singular vectors
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  print *,' DGESVD, singular values & left and right singular vectors'
  do i=1,s
    A = AA; LWORK = 3*N*N+1
    ALLOCATE(WORK(LWORK))
    CALL CPU_TIME(T1)
    CALL F77GESVD( 'A', 'A', N, N, A, LDA, WI, VL, LDA, VR, LDA, &
&     WORK, LWORK, INFO )
    CALL CPU_TIME(T2)
    DEALLOCATE(WORK)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA; LWORK = 3*N*N+1
    ALLOCATE(WORK(LWORK))
    BEFORE = RTC()
    CALL F77GESVD( 'A', 'A', N, N, A, LDA, WI, VL, LDA, VR, LDA, &
&     WORK, LWORK, INFO )
    AFTER = RTC()
    DEALLOCATE(WORK)
    RTC_TIME=RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 6.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L77GESVD ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L77GESVD ', RTC_TIME, RTC_MFLP
  CPU1_TIME = 0; RTC_TIME = 0; CPU_MFLP = 0; RTC_MFLP = 0;
  do i = 1, s
    A = AA
    CALL CPU_TIME(T1)
    CALL F95GESVD( A, WI, VL, VR, JOB='N', INFO=INFO)
    CALL CPU_TIME(T2)
    CPU1_TIME = CPU1_TIME + (T2-T1-T0)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
    A = AA
    BEFORE = RTC()
    CALL F95GESVD( A, WI, VL, VR, JOB='N', INFO=INFO)
    AFTER = RTC()
    RTC_TIME=RTC_TIME + (AFTER - BEFORE)
    IF (INFO .NE. 0) THEN
      PRINT *,'INFO = ', INFO
      EXIT
    ENDIF
  enddo
  CPU1_TIME = CPU1_TIME/S
  RTC_TIME = RTC_TIME/S
  FLP = 6.67*(DBLE(N)*(N*DBLE(N)))
  IF (CPU1_TIME .NE.0)THEN; CPU_MFLP = (FLP /CPU1_TIME)/1E6; ELSE; CPU_MFLP = 0
  ENDIF
  IF (RTC_TIME .NE.0)THEN; RTC_MFLP = (FLP /RTC_TIME)/1E6; ELSE; RTC_MFLP = 0
  ENDIF
  WRITE(*,*) 'CPUTIME and MFLOPS of L95GESVD ', CPU1_TIME, CPU_MFLP
  WRITE(*,*) 'RTCTIME and MFLOPS of L95GESVD ', RTC_TIME, RTC_MFLP

  DEALLOCATE( A, B, IPIV, AA, BB )
  DEALLOCATE(WR, WI, VL, VR)
  DEALLOCATE(IWORK)

END PROGRAM EXAMPLE


PROGRAM LinearWaves1D

  USE KindModule, ONLY: &
    DP
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK
  USE SmoothProblemsInitializationModule, ONLY: &
    InitializeLinearWaves1D
  USE SmoothProblemsErrorAnalysisModule, ONLY: &
    InitializeErrorAnalysis, &
    FinalizeErrorAnalysis

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'LinearWaves1D', &
           nX_Option &
             = [ 16, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 1, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 1.0_DP, 1.0_DP, 1.0_DP ], &
           nNodes_Option &
             = 3, &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = 5.0_DP / 3.0_DP, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .FALSE., &
           nStages_SSP_RK_Option &
             = 3 )

  CALL InitializeLinearWaves1D &
         ( 'AcousticWaves', Amplitude_Option = 1.0d-5 )

  CALL InitializeErrorAnalysis

  CALL EvolveFields &
         ( t_begin  = 0.0d-0, &
           t_end    = 1.0d+1, &
           dt_write = 1.0d-1, &
           UpdateFields = SSP_RK )

  CALL FinalizeErrorAnalysis

  CALL FinalizeProgram

END PROGRAM LinearWaves1D


module yacht
  implicit none

  ! | Ones | 1 × number of ones | Any combination	| 1 1 1 4 5 scores 3 |
  ! | Twos | 2 × number of twos | Any combination | 2 2 3 4 5 scores 4 |
  ! | Threes | 3 × number of threes | Any combination | 3 3 3 3 3 scores 15 |
  ! | Fours | 4 × number of fours | Any combination | 1 2 3 3 5 scores 0 |
  ! | Fives | 5 × number of fives| Any combination | 5 1 5 2 5 scores 15 |
  ! | Sixes | 6 × number of sixes | Any combination | 2 3 4 5 6 scores 6 |
  ! | Full House | Total of the dice | Three of one number and two of another | 3 3 3 5 5 scores 19 |
  ! | Four of a Kind | Total of the four dice | At least four dice showing the same face | 4 4 4 4 6 scores 16 |
  ! | Little Straight |  30 points | 1-2-3-4-5 | 1 2 3 4 5 scores 30 |
  ! | Big Straight | 30 points | 2-3-4-5-6 | 2 3 4 5 6 scores 30 |
  ! | Choice | Sum of the dice | Any combination | 2 3 3 4 6 scores 18 |
  ! | Yacht | 50 points | All five dice showing the same face | 4 4 4 4 4 scores 50 |

  integer,parameter :: YACHT_TYPES_LEN=12

  enum, bind(C)
    enumerator :: yacht_types
    enumerator :: ones
    enumerator :: twos
    enumerator :: threes
    enumerator :: fours
    enumerator :: fives
    enumerator :: sixes
    enumerator :: full_house
    enumerator :: four_of_a_kind
    enumerator :: little_straight
    enumerator :: big_straight
    enumerator :: choice
    enumerator :: yacht_
  end enum

  character(len=15), dimension(YACHT_TYPES_LEN), parameter :: yacht_types_str = (/ &
   &  "ones           ", &
   &  "twos           ", &
   &  "threes         ", &
   &  "fours          ", &
   &  "fives          ", &
   &  "sixes          ", &
   &  "full house     ", &
   &  "four of a kind ", &
   &  "little straight", &
   &  "big straight   ", &
   &  "choice         ", &
   &  "yacht          " /)

contains

  integer function score(dice, yacht_type)
    integer, dimension(5), intent(in) :: dice
    character(len=*), intent(in) :: yacht_type

    integer :: yatch_type_in

    score=0

    yatch_type_in = get_yacht_type(yacht_type)
    select case (yatch_type_in)
    case (choice)
      score = sum(dice)
    case (yacht_)
      if (is_yacht(dice)) then
        score = 50
      end if
    case (ones, twos, threes, fours, fives, sixes)
      score = score_num(dice,yatch_type_in)
    case (full_house)
      if (is_full_house(dice)) then
        score = sum(dice)
      endif
    case (four_of_a_kind)
      if (is_four_of_a_kind(dice)) then
        score = score_four_of_a_kind(dice)
      end if
    case (little_straight)
      if (is_little_straight(dice))then
        score = 30
      end if
    case (big_straight)
      if (is_big_straight(dice))then
        score = 30
      end if
    case default
      write(*,*) 'ERROR: Unknown type: ',  yacht_type, dice
    end select

  end function

  integer function get_yacht_type(yacht_type)
    character(len=*), intent(in) :: yacht_type
    integer :: i
    get_yacht_type = yacht_types

    do i=1,YACHT_TYPES_LEN
      if ( trim(yacht_type) == trim(yacht_types_str(i))) then
        get_yacht_type = i
      end if
    end do
    if (get_yacht_type == yacht_types) then
      write(*,*) 'ERROR: Wrong yacht type'
    end if
  end function

  integer function occurences(dice, to_find)
    integer, dimension(5), intent(in) :: dice
    integer to_find
    integer i
    occurences = 0
    do i=1,5
      if ( dice(i)==to_find ) then
        occurences = occurences +1
      end if
    enddo
  end function

  logical function is_yacht(dice)
    integer, dimension(5), intent(in) :: dice
    is_yacht = occurences(dice, dice(1)) == 5
  end function

  logical function is_four_of_a_kind(dice)
    integer, dimension(5), intent(in) :: dice
    ! either four same to first dice, or four of the same of second dice, or yacht
    is_four_of_a_kind= occurences(dice, dice(1)) >= 4 .or.  occurences(dice, dice(2)) >= 4
  end function

  logical function is_little_straight(dice)
    integer, dimension(5), intent(in) :: dice
    is_little_straight = occurences(dice, 1) == 1  &
      & .and.  occurences(dice, 2) == 1 &
      & .and.  occurences(dice, 3) == 1 &
      & .and.  occurences(dice, 4) == 1 &
      & .and.  occurences(dice, 5) == 1
  end function

  logical function is_big_straight(dice)
    integer, dimension(5), intent(in) :: dice
    is_big_straight = occurences(dice, 2) == 1  &
      & .and.  occurences(dice, 3) == 1 &
      & .and.  occurences(dice, 4) == 1 &
      & .and.  occurences(dice, 5) == 1 &
      & .and.  occurences(dice, 6) == 1
  end function

  integer function score_four_of_a_kind(dice)
    integer, dimension(5), intent(in) :: dice
    integer i, j

    score_four_of_a_kind=0
    do j=1,2
      if ( occurences(dice, dice(j)) >= 4) then
        do i=1,5
          if ( dice(j)==dice(i) ) then
            score_four_of_a_kind=score_four_of_a_kind+dice(i)
          end if
        end do
        ! fix yacht, remove one dice from score
        if (occurences(dice, dice(j)) == 5) then
          score_four_of_a_kind=score_four_of_a_kind-dice(j)
        endif
        return
      end if
    enddo
  end function

  logical function is_full_house(dice)
    integer, dimension(5), intent(in) :: dice
    integer i
    integer second
    integer num_first
    integer num_second
    is_full_house = .true.
    second = 0
    ! find second dice
    do i=2,5
      if ( dice(1)/=dice(i) ) then
        second = dice(i)
        exit
      end if
    enddo

    ! count
    num_first = occurences(dice, dice(1))
    num_second = occurences(dice, second)
    if (num_second==2 .and. num_first==3 &
      &  .or.num_second==3 .and. num_first==2 ) then
        is_full_house = .true.
      else
        is_full_house = .false.
    endif
  end function

  integer function score_num(dice, num)
    integer, dimension(5), intent(in) :: dice
    integer, intent(in) :: num
    integer i
    score_num = 0
    do i=1,5
      if (dice(i)==num)then
        score_num=score_num+dice(i)
      endif
    enddo
  end function

end module


! Get the code from [Bremer 2016] and run the following commands:
! make
! gfortran -O3 -c laguerre_quad_Adj.f90
! gfortran -O3 -o comparison explExpa.f90 utils.o chebyshev.o odesolve.o kummer.o laguerre_quad_Adj.o
! To run the timings into Timings.out: ./comparison
! To run the memory tests into the other *.out: ./comparison asdf
program explExpa
    use kummer_laguerre_routines
    double precision, parameter :: pi = acos(-1.d0)
    double precision, allocatable :: x(:), w(:), xt(:), wt(:)
    double precision :: alpha = 0.0
    integer :: n = 100, mode = 1, ni
    character(len=80) :: tmp

    mode = command_argument_count()
    if (mode == 0) then
	! kummer only seems correct for alpha = 0
	call testAll(0.0d0);
	return
    elseif (mode == 1) then
	open(7, file='Ns.out')
	call SYSTEM('echo " " > NbAlloc.out')
	call SYSTEM('echo " " > BytesAlloc.out')
	call SYSTEM('echo " " > MrssTime.out')
	do ni = 1, 15
	    n = nint(exp( log(100*1.0)*(15 -ni)/(15 -1.0) + (ni-1.0)*log(10**9*1.0)/(15-1.0) ) )
	    do mode = 1,4
		write (tmp, '(a, i10, a, i1, a)'), 'valgrind ./comparison ', n, ' 0.0 ', mode, ' 2> valg'
		call SYSTEM(tmp)
		call SYSTEM('grep -o -P  "(?<=heap usage:).*(?=allocs,)" valg | tr -d ''\n'' | tr -d '','' >> NbAlloc.out')
		call SYSTEM('grep -o -P  "(?<=frees,).*(?=bytes al)" valg | tr -d ''\n'' | tr -d '','' >> BytesAlloc.out')
		write (tmp, '(a, i10, a, i1, a)'), '/usr/bin/time -v ./comparison ', n, ' 0.0 ', mode, ' 2> ubtime'
		call SYSTEM(tmp)
		call SYSTEM('grep -Po  "(?<=Maximum resident set size \(kbytes\):).*(?=)" ubtime | tr -d ''\n'' >> MrssTime.out')
	    enddo
	    call SYSTEM('echo " " >> NbAlloc.out')
	    call SYSTEM('echo " " >> BytesAlloc.out')
	    call SYSTEM('echo " " >> MrssTime.out')
	    write(7,*) n
	enddo
	close(7)
	return
    endif

    call get_command_argument(1,tmp)
    read(tmp, '(i10)' ) n
    call get_command_argument(2,tmp)
    read(tmp, '(f15.10)' ) alpha
    call get_command_argument(3,tmp)
    read(tmp, '(i10)' ) mode

    if (mode == 1) then ! Compressed representation with bes(zer)
	call laguerreExp(n, alpha, x, w, .true., .true., .true.)
    else
	allocate(x(n), w(n))
    endif

    if (mode == 2) then ! Uncompressed representation without bes(zer)
	call laguerreExp(n, alpha, x, w, .false., .false., .false.)
    elseif (mode == 3) then ! Uncompressed representation with bes(zer)
	call laguerreExp(n, alpha, x, w, .true., .true., .false.)
    elseif (mode == 4) then ! Nonoscillatory phase
	call kummer_laguerre(n, alpha, x, w)
    endif
    ! Use the result such that the compiler does not optimize out the computation
    if (abs(sum(w)/GAMMA(alpha+1) -1) > 1e-8) then
	print *, sum(w), "error", GAMMA(alpha+1), w(1:10)
    endif
    deallocate(x,w)
contains

subroutine testAll(alpha)
    use kummer_laguerre_routines
    implicit none
    integer, parameter :: minN = 100, maxN = 10**9, nbRep = 5, lN = 15
    integer :: ni, n, nTest, t1, t2, clm, dNt(8), rate, ns(lN), mode, row, whTim
    double precision, allocatable :: xn(:), wn(:), xe(:), we(:), xcpr(:), wcpr(:)
    double precision :: alpha, ers(lN,12)
    real :: ts, tm, te, td, tarr(2), elTimes(lN,nbRep,4,4), start, prevToc = 0.0
    elTimes = -1.d0
    ers = -1.d0
    ns = (/ (nint(exp( log(minN*1.0d0)*((lN -ni)/(lN -1.0d0)) + &
log(maxN*1.0d0)*((ni-1.0d0)/(lN-1.0d0)) ) ), ni=1,lN) /)
    do ni =1,lN
	n = ns(ni)
	allocate(xn(n), wn(n), xe(n), we(n))
	do mode = 1, 4
          do nTest = 1, nbRep
	    call etime(tarr, ts)
	    call cpu_time(td)
	    call date_and_time(values=dNt)
	    start = 0.001d0*dNt(8) + dNt(7) + 60*(dNt(6) + 60*(dNt(5) + 24*dNt(3) ))
	    call system_clock(t1, rate, clm)

	    if (mode == 1) then ! Compressed representation with bes(zer)
		call laguerreExp(n, alpha, xcpr, wcpr, .true., .true., .true.)
		deallocate(xcpr, wcpr)
	    end if
	    if (mode == 2) then ! Uncompressed representation without bes(zer)
		call laguerreExp(n, alpha, xe, we, .false., .false., .false.)
	    elseif (mode == 3) then ! Uncompressed representation with bes(zer)
		call laguerreExp(n, alpha, xe, we, .true., .true., .false.)
	    elseif (mode == 4) then ! Nonoscillatory phase
		call kummer_laguerre(n, alpha, xn, wn)
	    endif

	    call etime(tarr, tm)
	    elTimes(ni,nTest,1, mode) = tm-ts
	    call date_and_time(values=dNt)
	    elTimes(ni,nTest,2, mode) = 0.001d0*dNt(8) + dNt(7) + 60*(dNt(6) + 60*(dNt(5) + 24*dNt(3) )) - start
	    call cpu_time(te)
	    elTimes(ni,nTest,3, mode) = te-td
	    call system_clock(t2, rate, clm)
	    elTimes(ni,nTest,4, mode) = (t2 -t1 +0.0)/rate
	    if (tm - prevToc > 3.0) then ! print progress info every three seconds
		print '(i2,a,i1,a, i2, a, es12.3, a, es12.3, a)', ni, "=ni, mode=", mode, ", nTest=", nTest, ", etime=", tm, &
", ", tm*(sum(ns)*4.0*nbRep/( sum(ns(1:ni-1))*4.0*nbRep +n*(mode-1.0)*nbRep +n*nTest) -1.0)/3600.0, " hr left."
		prevToc = tm
	    endif
	  enddo
	enddo
	! xe and we are now the last simulations (ntest=nbRep) with the uncompressed representation with computation of Bessel function and zeros (mode = 3)
	nTest = floor(0.9*n)-1
	ers(ni,1) = norm2(xn -xe)/norm2(xn)
	ers(ni,2) = norm2(wn -we)/norm2(wn)
	ers(ni,3) = norm2((xn -xe)/xn)
	ers(ni,4) = norm2((wn -we)/wn)
	ers(ni,5) = norm2(xn -xe)
	ers(ni,6) = norm2(wn -we)
	ers(ni,7) = norm2(xn(1:nTest) -xe(1:nTest))/norm2(xn(1:nTest))
	ers(ni,8) = norm2(wn(1:nTest) -we(1:nTest))/norm2(wn(1:nTest))
	ers(ni,9) = norm2((xn(1:nTest) -xe(1:nTest))/xn(1:nTest))
	ers(ni,10) = norm2((wn(1:nTest) -we(1:nTest))/wn(1:nTest))
	ers(ni,11) = norm2(xn(1:nTest) -xe(1:nTest))
	ers(ni,12) = norm2(wn(1:nTest) -we(1:nTest))
	deallocate(xn, wn, xe, we)
	open(8, file="Timings.out")
	write(8, *), ns, "=ns, elTimes = "
	do mode =1,size(elTimes,4)
	    do whTim =1,size(elTimes,3)
		write(8,*), "Mode", mode, " time nr ", whTim, " = "
		do row = 1,size(elTimes,1)
		    write (8,*), elTimes(row,:,whTim,mode)
		enddo
	    enddo
	enddo
	write (8, *), ", ers = "
	do row = 1,size(ers,1)
	    write (8,*), ers(row,:)
	enddo
	close(8)
    end do
end subroutine

subroutine laguerreExp(n, alpha, x, w, compZer, compBes, compRepr)
    implicit none
    integer :: n, T, ibes, iair, it, k, mn, mxb
    double precision :: alpha, d, pt, term, co, so, cf, zeta, prev, jta
    double precision, parameter :: ak(11)  = (/ -13.69148903521072d0, &
 -12.828776752865757d0, -11.93601556323626d0,  -11.00852430373326d0, &
 -10.04017434155809d0,  -9.02265085340981d0, -7.944133587120853d0, &
  -6.786708090071759d0, -5.520559828095551d0, -4.08794944413097d0, &
  -2.338107410459767d0 /) ! First 11 roots of the Airy function in reverse order
    double precision, parameter :: dak(10)  = (/  &
 -1.0677938592d0, 1.0487206486d0,  -1.0277386888d0, &
 1.0043701227d0,  -0.9779228086d0, 0.9473357094d0, &
  -0.9108507370d0, 0.8652040259d0, -0.8031113697d0, &
  0.7012108227d0 /) ! Derivatives at first 11 roots of the Airy function in reverse order [DLMF tab 9.9.1]
    double precision, allocatable :: x(:), w(:)
    logical compZer, compBes, compRepr

    double precision mu, b, a1, a3, a5, a7, a9, a11, a13, TT(30)
    double precision, parameter :: tab(20) = (/ 2.4048255576957728d0, &
 5.5200781102863106d0,  8.6537279129110122d0,   11.791534439014281d0, &
 14.930917708487785d0,  18.071063967910922d0,   21.211636629879258d0, &
 24.352471530749302d0,  27.493479132040254d0,   30.634606468431975d0, &
 33.775820213573568d0,  36.917098353664044d0,   40.058425764628239d0, &
 43.199791713176730d0,  46.341188371661814d0,   49.482609897397817d0, &
 52.624051841114996d0,  55.765510755019979d0,   58.906983926080942d0, &
 62.048469190227170d0  /)  ! First 20 roots of J0(x) are precomputed (using Wolfram Alpha)
    double precision, parameter :: C(6,30) = reshape( &
(/2.883975316228d0,  8.263194332307d0, 11.493871452173d0, 14.689036505931d0, &
 17.866882871378d0, 21.034784308088d0, &
  0.767665211539d0,  4.209200330779d0,  4.317988625384d0,  4.387437455306d0, &
  4.435717974422d0,  4.471319438161d0, &
 -0.086538804759d0, -0.164644722483d0,  -0.130667664397d0, -0.109469595763d0, &
 -0.094492317231d0, -0.083234240394d0, &
  0.020433979038d0,  0.039764618826d0,  0.023009510531d0,  0.015359574754d0, &
  0.011070071951d0,  0.008388073020d0, &
 -0.006103761347d0, -0.011799527177d0, -0.004987164201d0, -0.002655024938d0, &
 -0.001598668225d0, -0.001042443435d0, &
  0.002046841322d0,  0.003893555229d0,  0.001204453026d0,  0.000511852711d0, &
  0.000257620149d0,  0.000144611721d0, &
 -0.000734476579d0, -0.001369989689d0, -0.000310786051d0, -0.000105522473d0, &
 -0.000044416219d0, -0.000021469973d0, &
  0.000275336751d0,  0.000503054700d0,  0.000083834770d0,  0.000022761626d0, &
  0.000008016197d0,  0.000003337753d0, &
 -0.000106375704d0, -0.000190381770d0, -0.000023343325d0, -0.000005071979d0, &
 -0.000001495224d0, -0.000000536428d0, &
  0.000042003336d0,  0.000073681222d0,  0.000006655551d0,  0.000001158094d0, &
  0.000000285903d0,  0.000000088402d0, &
 -0.000016858623d0, -0.000029010830d0, -0.000001932603d0, -0.000000269480d0, &
 -0.000000055734d0, -0.000000014856d0, &
  0.000006852440d0,  0.000011579131d0,  0.000000569367d0,  0.000000063657d0, &
  0.000000011033d0,  0.000000002536d0, &
 -0.000002813300d0, -0.000004672877d0, -0.000000169722d0, -0.000000015222d0, &
 -0.000000002212d0, -0.000000000438d0, &
  0.000001164419d0,  0.000001903082d0,  0.000000051084d0,  0.000000003677d0, &
  0.000000000448d0,  0.000000000077d0, &
 -0.000000485189d0, -0.000000781030d0, -0.000000015501d0, -0.000000000896d0, &
 -0.000000000092d0, -0.000000000014d0, &
  0.000000203309d0,  0.000000322648d0,  0.000000004736d0,  0.000000000220d0, &
  0.000000000019d0,  0.000000000002d0, &
 -0.000000085602d0, -0.000000134047d0, -0.000000001456d0, -0.000000000054d0, &
 -0.000000000004d0,             0.d0, &
  0.000000036192d0,  0.000000055969d0,  0.000000000450d0,  0.000000000013d0, &
  0.d0, 0.d0, &
 -0.000000015357d0, -0.000000023472d0, -0.000000000140d0, -0.000000000003d0, &
  0.d0, 0.d0, &
  0.000000006537d0,  0.000000009882d0,  0.000000000043d0,  0.000000000001d0, &
  0.d0, 0.d0, &
 -0.000000002791d0, -0.000000004175d0, -0.000000000014d0, 0.d0, 0.d0, 0.d0, &
  0.000000001194d0,  0.000000001770d0,  0.000000000004d0, 0.d0, 0.d0, 0.d0, &
 -0.000000000512d0, -0.000000000752d0, 0.d0, 0.d0, 0.d0, 0.d0, &
  0.000000000220d0,  0.000000000321d0, 0.d0, 0.d0, 0.d0, 0.d0, &
 -0.000000000095d0, -0.000000000137d0, 0.d0, 0.d0, 0.d0, 0.d0, &
  0.000000000041d0,  0.000000000059d0, 0.d0, 0.d0, 0.d0, 0.d0, &
 -0.000000000018d0, -0.000000000025d0, 0.d0, 0.d0, 0.d0, 0.d0, &
  0.000000000008d0,  0.000000000011d0, 0.d0, 0.d0, 0.d0, 0.d0, &
 -0.000000000003d0, -0.000000000005d0, 0.d0, 0.d0, 0.d0, 0.d0, &
  0.000000000001d0,  0.000000000002d0, 0.d0, 0.d0, 0.d0, 0.d0 /), &
  (/ 6, 30 /) )

! McMahon's expansion. This expansion gives very accurate approximation
! for the k-th zero (k >= 7) for extreme nu, and moderate approximation
! in other cases for low k or medium-sized Bessel parameters.
    mu = 4*alpha**2
    a1 = 1.d0/8
    a3 = (7*mu-31)/384
    a5 = 4*(3779 +mu*(-982 +83*mu))/61440
    a7 = 6*(-6277237 +mu*(1585743 +mu*(-153855 +6949*mu)))/20643840;
    a9 = 144*(2092163573 +mu*(-512062548 +mu*(48010494 +mu*(-2479316 + &
70197*mu)) )) / 11890851840.d0
    a11 = 720.d0*(-8249725736393.d0 +mu*(1982611456181.d0 +mu*(-179289628602.d0 &
+mu*(8903961290.d0 +mu*(-287149133.d0 +5592657.d0*mu) ) ) ) ) / 10463949619200.d0
    a13 = (576.d0*(423748443625564327.d0 + mu*(-100847472093088506.d0 &
+mu*(8929489333108377.d0 + mu*(-426353946885548.d0 +mu*(13172003634537.d0 &
+mu*(-291245357370.d0 + mu*4148944183.d0))) ))) / 13059009124761600.d0)

    if (compRepr) then
	mn = min(nint(17*sqrt(n*1.0d0)), n)
	allocate(x(mn), w(mn))
    else
	mn = n
    endif

    ! This is a heuristic for the number of terms in the expansions that follow.
    T = ceiling(34/log(n+0.0) )
    d = 1/(4*n+2*alpha+2)

    ibes = max(ceiling(sqrt(n*1.0) ), 7)
    ! Heuristics to switch between Bessel, bulk and Airy initial.
    iair = floor(0.9*n)
    mxb = min(mn, iair-1)
!print *, ibes, iair, "=iair, mxb=", mxb
    if (compBes) then
	b = (alpha-2)/3
	TT(1) = 1.d0
	TT(2) = b
	do k = 2,29
	        TT(k+1) = 2*b*TT(k) - TT(k-1)
	enddo
    endif
    jta = 1.0d0
    x = 0.d0
    w = 0.d0
    do k=1,ibes !Bessel region
	! Roots of the function J_v(x) from chebfun by L. L. Peixoto, 2015, later modified by A. Townsend to work in Julia
	if ((compBes) .and. (alpha .eq. 0.d0) .and. (k < 21)) then
	   jta = tab(k)
	elseif ((compBes) .and. (alpha < 5) .and. (k < 7)) then
	   ! Piessens's Chebyshev series approximations (1984). Calculates the 6 first
	   ! zeros to at least 12 decimal figures in region -1 <= V <= 5:

	   jta = dot_product(C(k,:),TT)
	   if (k == 1) then
		jta = jta*sqrt(alpha+1) ! Scale the first root.
	   endif
	elseif (compBes) then
	   b = 0.25d0*(2*alpha+4*k-1)*pi
	   ! Evaluate using Horner's scheme: Possibly inaccurate results
	   jta = (((a13/b**2 + a11)/b**2 + a9)/b**2 + a7)/b**2 + a5
	   jta = b - (mu-1)*( ((jta/b**2 + a3)/b**2 + a1)/b)
	endif

	!Computed j_{alpha,k}, now add higher order terms
        if (T >= 7) then
        ! These higher order terms in the left and bulk region are derived in [Huybrechs and Opsomer 2018, in preparation]
	   x(k) = x(k) + (657*jta**6 +36*jta**4*( &
73*alpha**2-181) +2*jta**2*(2459*alpha**4 -10750*alpha**2 &
 +14051) + 4*(1493*alpha**6 -9303*alpha**4 +19887*alpha**2 - 12077))*d**6/2835
	   w(k) = w(k) + (11944*alpha**6 + 5256*jta**6 &
- (5061*alpha**5 + 5085*alpha**4 + 4830*alpha**3 -22724*alpha**2 -22932*alpha &
+ 39164)*jta**4 - 74424*alpha**4 + 8*(2459*alpha**4 -10750*alpha**2 &
+ 14051)*jta**2 + 159096*alpha**2 - 96616)/2835/2*d**6
       endif
       if (T >= 5) then
	   x(k) = x(k) + (11*jta**4 +3*jta**2*( &
11*alpha**2-19) +46*alpha**4 -140*alpha**2 +94)*d**4/45
	   w(k) = w(k) + (46*alpha**4 + 33*jta**4 &
+6*jta**2*(11*alpha**2 -19) -140*alpha**2 +94)/45*d**4
       endif
       if (T >= 3) then
	   x(k) = x(k) + (jta**2 + 2*alpha**2 - 2)*d**2/3
	   w(k) = w(k) + (alpha**2 + jta**2 -1)*2/3*d**2
       endif
       x(k) = jta**2*d*(1 + x(k))
       if ((compBes) .and. (k < 6+10*alpha**2/pi)) then
	    ! j_{alpha,k} \sim k*pi + O(k^0) with j_{alpha,k} > (alpha+1)^2
            pt = 1/GAMMA(alpha+2)
	    term = pt
	    prev = pt*jta**2/(alpha+2)
            do it = 1, 100
		term = -term*jta**2/4/it/(alpha+it+1)
		if (abs(term)  < abs(pt)*10.d0**(-12) ) then
		    ! Stop when no significant increase any more
		    exit
		endif
		pt = term + pt
		prev = term
	    enddo
	    ! Computed J_{alpha+1}(j_{alpha,k}) but = -J_{alpha-1} and square
w(k)=4*d*x(k)**alpha*exp(-x(k))/(pt*(jta/2)**(alpha+1))**2*(1+w(k))
	elseif (compBes) then
	    ! Approximate J_{\alpha-1}(j_{\alpha,k}) for large arguments
	    pt = 0.d0
	    co = cos(jta -(alpha-1)*pi/2 -pi/4)
	    so = sin(jta -(alpha-1)*pi/2 -pi/4)
            cf = 1.d0
	    prev = 2.0d0
            do it = 0, 50
		term = co*(-1)**it*cf
		cf = cf*(4*(alpha-1)**2 -(4*it +1)**2)/(2*it +1)/8/jta
		term = term - so*(-1)**it*cf
		if ((abs(term) + abs(prev) < abs(pt)*10.d0**(-12) ) .or. &
(abs(term) > abs(prev))) then
		    ! Stop when no significant increase any more taking into account [1; 0; 0.5; 0; 0.25 ...], or when the series starts diverging
		    exit
		endif
		pt = term + pt
		prev = term
		cf = cf*(4*(alpha-1)**2 -(4*it +3)**2)/(2*it+2)/8/jta
	    enddo
	    w(k) = 2*d*x(k)**alpha*exp(-x(k))/pt**2*jta*pi*(1+w(k))
	else
	    w(k) = 4*d*x(k)**alpha*exp(-x(k))*(1+w(k))
	endif
    enddo ! End loop bessel region

    do k=ibes+1,mxb !Loop lens
	if (compBes) then
	    pt = (4*n -4*k +3)*d
	    jta = pi**2/16*(pt -1)**2 ! This t is not a very good initial approximation of the inverse function of f(y) = (4*n -4*k +3)*d*pi +2*sqrt(y)*sqrt(1-y) -acos(2*y-1); but better approximations are much more time-consuming
	    do it = 1,6
jta = jta - (pt*pi +2*sqrt(jta -jta**2) -acos(2*jta -1) )*sqrt(jta/(1-jta))/2
	    end do
	endif
        if (T >= 7) then
        ! These higher order terms in the left and bulk region are derived in [Huybrechs and Opsomer 2018, in preparation]
	   x(k) = x(k) -d**5/181440*(9216*(21*alpha**6 &
- 105*alpha**4 + 147*alpha**2 - 31)*jta**10 &
-69120*(21*alpha**6 - 105*alpha**4 + 147*alpha**2 - 31)*jta**9 &
+384*(12285*alpha**6 -61320*alpha**4 +85785*alpha**2 &
-18086)*jta**8 - 64*(136080*alpha**6 - 675675*alpha**4 &
+943110*alpha**2 - 198743)*jta**7 &
+ 144*(70560*alpha**6 - 345765*alpha**4 +479850*alpha**2 &
- 101293)*jta**6 + 72576*alpha**6 - (8128512*alpha**6 &
- 38656800*alpha**4+ 52928064*alpha**2 - 13067711)*jta**5 &
+ 5*(1016064*alpha**6 - 4581360*alpha**4 +6114528*alpha**2 &
+ 113401)*jta**4 - 317520*alpha**4 - 10*(290304*alpha**6 &
-1245888*alpha**4 + 1620864*alpha**2 - 528065)*jta**3 &
+ 5*(290304*alpha**6 -1234800*alpha**4 + 1598688*alpha**2 &
- 327031)*jta**2 + 417312*alpha**2 -5*(96768*alpha**6 &
- 417312*alpha**4 + 544320*alpha**2 - 111509)*jta &
-85616)/(jta-1)**8/jta**2
	   w(k) = w(k) + d**6/362880*(9216*(21*alpha**6 &
- 105*alpha**4 + 147*alpha**2 - 31)*jta**10 &
-1536*(945*alpha**6-4830*alpha**4 +6825*alpha**2 -1444)*jta**9 &
+ 384*(11340*alpha**6 -60165*alpha**4 + 86310*alpha**2 &
- 18289)*jta**8 - 2*(2903040*alpha**6 - 17055360*alpha**4 &
+ 25401600*alpha**2 - 5*alpha - 5252997)*jta**7 &
- (11753280*alpha**4 - 23506560*alpha**2+ 67*alpha &
- 13987519)*jta**6 - 290304*alpha**6 + 12*(1016064*alpha**6 &
-3578400*alpha**4 +4108608*alpha**2 +16*alpha +7100871)*jta**5 &
 - 5*(4064256*alpha**6 -16559424*alpha**4 + 20926080*alpha**2 + 61*alpha &
- 15239393)*jta**4 + 1270080*alpha**4 +10*(1741824*alpha**6 &
-7386624*alpha**4 +9547776*alpha**2 +29*alpha -1560107)*jta**3 &
- 15*(580608*alpha**6 - 2503872*alpha**4 + 3265920*alpha**2 + 11*alpha &
- 669051)*jta**2- 1669248*alpha**2 + 4*(604800*alpha**6 &
- 2630880*alpha**4 + 3447360*alpha**2 + 13*alpha- 706850)*jta &
- 7*alpha + 342463)/(jta -1)**9/jta**3
	endif
	if (T >= 5) then
	   x(k) = x(k) - d**3/720*(32*(15*alpha**4 &
- 30*alpha**2 + 7)*jta**6 -144*(15*alpha**4 - 30*alpha**2 &
+ 7)*jta**5 + 16*(225*alpha**4 - 450*alpha**2 &
+104)*jta**4 - 240*alpha**4 - 480*(5*alpha**4 - 10*alpha**2 &
+ 1)*jta**3 + 480*alpha**2 +45*(16*alpha**4 - 32*alpha**2 &
+ 7)*jta +990*jta**2 -105)/(jta &
-1)**5/jta
	   w(k) = w(k) + d**4/720*(16*(15*alpha**4 &
- 30*alpha**2 + 7)*jta**6 - 32*(45*alpha**4 - 90*alpha**2 &
+22)*jta**5 + 48*(75*alpha**4 - 150*alpha**2 + &
74)*jta**4 + 240*alpha**4 - 600*(8*alpha**4- 16*alpha**2 &
- 5)*jta**3 + 45*(80*alpha**4 - 160*alpha**2 + &
57)*jta**2 - 480*alpha**2 -90*(16*alpha**4 - 32*alpha**2 &
+ 7)*jta + 105)/(jta -1)**6/jta**2
	endif
	if (T >= 3) then
	   x(k) = x(k) - d/12*(4*(3*alpha**2 &
-1)*jta**2 +12*alpha**2 -12*(2*alpha**2 -1)*jta - 3)/(jta-1)**2
	   w(k) = w(k)  + d**2/6*(2*jta + 3)/(jta-1)**3
	endif
	x(k) = x(k) + jta/d;
	w(k) = x(k)**alpha*exp(-x(k) )*2*pi*sqrt(jta/(1-jta))*(1 +w(k))
    enddo !Loop lens

    do k =iair,mn !Loop Airy
	if ((compBes) .and. (k < n - 10)) then
	    pt = 3*pi/2*( n -k +0.75d0) ! [DLMF (9.9.6)]
	    jta = -pt**(2.d0/3)*(1 + 5/48.d0/pt**2 - 5/36.d0/pt**4 + &
77125/82944.d0/pt**6 -10856875/6967296.d0/pt**8)
	elseif (compBes) then
	    jta = ak(k -n +11)
	endif
	! For the Airy region, only O(n**{-4}) relative error for x and O(n**{-2/3}) for w as the latter are extremely small or even underflow
	if (T >= 5) then
	   x(k) = x(k) -(15152.d0/3031875*jta**5 &
+1088.d0/121275*jta**2)*2**(1.d0/3)*d**(7.0d0/3) ! [Gatteshi 2002 (4.9)], Gives an O(n**{-4}) relative error
	endif
	if (T >= 3) then
	   x(k) = x(k) + jta**2*(d*16)**(1.d0/3)/5 &
+ (11.d0/35 -alpha**2 -12.d0/175*jta**3)*d + (16.d0/1575*jta &
+ 92.d0/7875*jta**4)*2**(2.d0/3)*d**(5.0d0/3)
	endif
	x(k) = x(k) + 1/d +jta*(d/4)**(-1.d0/3)
	if ((compBes) .and. (k <= n-10)) then
	    zeta = -2*jta*sqrt(-jta)/3 ! = zeta in [DLMF 9.7.10]
	    co = cos(zeta -pi/4)
	    so = sin(zeta -pi/4)
! Asymptotic expansion of Airy(z) = exp(-zeta)/2/sqrt(pi)/z^(1/4) sum_{n=0}^\infty (-1)^n Gamma(n+5/6) Gamma(n+1/6) (3/4)^n /2/pi/ n!/z^(3n/2) but for pos z and
! (6*k+1)/(1-6*k)/216^k/factorial(k)*product  (2*j+1) for j in range(k,3*k-1)  = -(2^(-5 k) 27^(-k) (6 k + 1) Γ(6 k - 1))/(Γ(2 k) Γ(k + 1))
	    pt = 0.d0
	    cf = 1.d0 ! = GAMMA(5.d0/6)*GAMMA(7.d0/6)*3/pi
	    prev = 2.0d0
	    do it = 0, 50
		term = so*cf/(1-12*it)*(-1)**it
		cf = cf*(2*it +5.d0/6)*(2*it+7.d0/6)/2/(2*it+1)/zeta
		term = term - co*cf/(1-6*(2*it+1))*(-1)**it
		cf = cf*(2*it +11.d0/6)*(2*it+13.d0/6)/2/(2*it+2)/zeta
		if ((abs(term) + abs(prev) < abs(pt)*10.d0**(-12) ) .or. (abs(term) > abs(prev))) then
		    ! Stop when no significant increase any more taking into account [1; 0; 0.5; 0; 0.25 ...], or when the series starts diverging
		    exit
		 endif
		pt = pt + term
		prev = term
	    enddo
w(k) = 4**(1.d0/3)*x(k)**(alpha +1.d0/3)*exp(-x(k) )/( pt**2*sqrt(-jta)/pi )
	elseif (compBes) then
	    ! Could also use a series expansion of the Airy function as Ai"(z)=z Ai(z)
	    w(k) = 4**(1.d0/3)*x(k)**(alpha+1.d0/3)*exp(-x(k))/(dak(k-n+10))**2
	else
	    w(k) = 4**(1.d0/3)*x(k)**(alpha+1.d0/3)*exp(-x(k))
	endif
    enddo !Loop Airy

    if (((minval(x) < 0.d0) .or. (maxval(x) > 4*n +2*alpha +2) .or. &
(minval(w) < 0.d0)) .and. compBes) then
	print *, "Wrong node or weight."
    endif
end subroutine

end program