!      INTEGER N, iters
!      REAL check

!      N = 112
!      iters = 210
!      CALL acoustic3d_f77(N,iters,check)
!      PRINT *, check
!      END

      SUBROUTINE acoustic3d_f77(N, niters, check)
      INTEGER N, niters, iter
      REAL check
      REAL P1(N,N,N), P2(N,N,N), P3(N,N,N), C(N,N,N)
      INTEGER i, j, k

      CALL acoust3d_f77_setup(P1, P2, P3, C, N)

      DO iter=1, niters
        DO k=2,N-1
          DO j=2,N-1
            DO i=2,N-1
              P3(i,j,k) = (2-6*C(i,j,k))*P2(i,j,k) + C(i,j,k)
     .          * (P2(i,j-1,k) + P2(i,j+1,k) + P2(i-1,j,k)
     .           + P2(i+1,j,k) + P2(i,j,k-1) + P2(i,j,k+1))
     .           - P1(i,j,k)
            END DO
          END DO
        END DO

        DO k=1,N
          DO j=1,N
            DO i=1,N
              P1(i,j,k) = P2(i,j,k)
              P2(i,j,k) = P3(i,j,k)
            END DO
          END DO
        END DO
      END DO

      check = P1(N/2,N/2,N/2)

      RETURN
      END

      SUBROUTINE acoust3d_f77_setup(P1, P2, P3, c, N)
      INTEGER N
      REAL P1(N,N,N), P2(N,N,N), P3(N,N,N), c(N,N,N)
      INTEGER i, j, k
      INTEGER cavityLeft, cavityRight, cavityFront, cavityBack,
     .        cavityTop, cavityBottom, cavityTop2, cavityBottom2
      REAL ci, cj, ck, s2

!     Set up velocity field

      DO k=1,N
        DO j=1,N
          DO i=1,N/2
            c(i,j,k) = 0.05
          END DO
          DO i=N/2+1,N
            c(i,j,k) = 0.3
          END DO
        END DO
      END DO

!     Cavities

      cavityLeft = 3 * N / 7.0
      cavityRight = 4 * N / 7.0
      cavityFront = 3 * N / 7.0
      cavityBack = 4 * N / 7.0
      cavityTop = 5 * N / 7.0
      cavityBottom = 6 * N / 7.0
      cavityTop2 = 1 * N / 7.0
      cavityBottom2 = 2 * N / 7.0

      DO k=cavityFront, cavityBack
        DO j=cavityLeft, cavityRight
          DO i=cavityTop, cavityBottom
            c(i,j,k) = 0.02
          END DO
          DO i=cavityTop2, cavityBottom2
            c(i,j,k) = 0.001
          END DO
        END DO
      END DO

!     Initial pressure distribution

      ci = N/2.0
      cj = N/2.0
      ck = N/2.0
      s2 = 64.0 * 9.0 / ((N/2.0) ** 2)

      DO k=1,N
        DO j=1,N
          DO i=1,N
            P1(i,j,k) = 0.0
            P2(i,j,k) = exp(- ((i-ci)**2+(j-cj)**2+(k-ck)**2) * s2)
            P3(i,j,k) = 0.0
          END DO
        END DO
      END DO

      CALL acoust3d_f77_setup_check(P2, N)
      CALL acoust3d_f77_setup_check(c, N)

      RETURN
      END

      SUBROUTINE acoust3d_f77_setup_check(A, N)
      INTEGER N
      REAL A(N,N,N)
      INTEGER i, j, k
      REAL check

      check = 0.0
      DO k=1,N
        DO j=1,N
          DO i=1,N
            check = check + A(i,j,k) * (i+N*j+N*N*k)
          END DO
        END DO
      END DO

      PRINT *, 'Array check: ', check

      RETURN
      END


function linterp(data,grid,ndata,coord)
! For a set value of gridpoints GRID on the x-axis, and known function values
! f(x) stored in DATA, find the linear interpolation of the value f(coord).
implicit none
integer :: ndata
double precision :: linterp,data(ndata),grid(ndata),coord
integer :: iihi,iilo,iimid,ii

if (coord.lt.grid(1).or.coord.gt.grid(ndata)) then
  write(6,*) 'input coordinate out of range in function linterp'
  stop
endif
iihi=ndata
iilo=1
do
  if (iihi-iilo.gt.1) then
    iimid=(iihi+iilo)/2
    if (grid(ndata).ge.grid(1)) then
      if (coord.ge.grid(iimid)) then
        iilo=iimid
      else
        iihi=iimid
      endif
    else
      if (coord.le.grid(iimid)) then
        iilo=iimid
      else
        iihi=iimid
      endif
    endif
  else
    exit
  endif
enddo
if (coord.eq.grid(1)) then
  ii=iilo
elseif (coord.eq.grid(ndata)) then
  ii=iihi-1
else
  ii=iimid
endif
linterp=data(ii)+(data(ii+1)-data(ii))*(coord-grid(ii))/(grid(ii+1)-grid(ii))

return
end function linterp


module priors_module
    use utils_module, only: dp
    implicit none

    integer, parameter :: unknown_type        = 0
    integer, parameter :: uniform_type        = 1
    integer, parameter :: gaussian_type       = 2
    integer, parameter :: log_uniform_type    = 3
    integer, parameter :: sorted_uniform_type = 4

    type prior
        integer :: npars = 0
        integer :: prior_type = unknown_type
        integer, dimension(:), allocatable :: hypercube_indices
        integer, dimension(:), allocatable :: physical_indices

        real(dp), dimension(:), allocatable :: parameters

    end type prior

    contains

    !============= Uniform (Separable) ================================================

    function uniform_htp(hypercube_coords,parameters) result(physical_coords)
        implicit none
        !> The hypercube coordinates to be transformed
        real(dp), intent(in), dimension(:) :: hypercube_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(hypercube_coords)) :: physical_coords

        ! This is a fairly simple transformation, each parameter is transformed as
        ! hypercube_coord -> min + hypercube_coord * (max-min)
        ! odd indices of the parameters array are the minimums
        ! even indices of the parameters array are the maximums

        physical_coords = parameters(1::2) + (parameters(2::2) - parameters(1::2) ) * hypercube_coords

    end function uniform_htp

    function uniform_pth(physical_coords,parameters) result(hypercube_coords)
        implicit none
        !> The physical coordinates to be transformed
        real(dp), intent(in), dimension(:) :: physical_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(physical_coords)) :: hypercube_coords

        hypercube_coords = (physical_coords - parameters(1::2)) / (parameters(2::2) - parameters(1::2) )

    end function uniform_pth

    !============= Gaussian (Separable) ===============================================

    function gaussian_htp(hypercube_coords,parameters) result(physical_coords)
        use utils_module, only: inv_normal_cdf
        implicit none
        !> The hypercube coordinates to be transformed
        real(dp), intent(in), dimension(:) :: hypercube_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(hypercube_coords)) :: physical_coords

        ! Transform via the inverse normal cumulative distribution function
        physical_coords = inv_normal_cdf(hypercube_coords)

        ! Scale by the standard deviation and shift by the mean
        physical_coords = parameters(1::2) + parameters(2::2) * physical_coords

    end function gaussian_htp

    function gaussian_pth(physical_coords,parameters) result(hypercube_coords)
        use utils_module, only: normal_cdf
        implicit none
        !> The physical coordinates to be transformed
        real(dp), intent(in), dimension(:) :: physical_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(physical_coords)) :: hypercube_coords

        integer :: npars

        npars=size(physical_coords)

        ! Scale by the standard deviation and shift by the mean
        ! odd indices of the parameters array are the means
        ! even indices of the parameters array are the stdevs

        hypercube_coords = ( physical_coords - parameters(1::2) )/parameters(2::2)

        ! Transform via the normal cumulative distribution function
        hypercube_coords = normal_cdf(hypercube_coords)

    end function gaussian_pth

    !============= Log-Uniform (Separable) ============================================
    function log_uniform_htp(hypercube_coords,parameters) result(physical_coords)
        implicit none
        !> The hypercube coordinates to be transformed
        real(dp), intent(in), dimension(:) :: hypercube_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(hypercube_coords)) :: physical_coords

        ! hypercube_coord -> min * (max/min)**hypercube_coord
        ! Lower half of the parameters array are the minimums
        ! Upper half of the parameters array are the maximums
        physical_coords = parameters(1::2) * (parameters(2::2)/parameters(1::2)) ** hypercube_coords

    end function log_uniform_htp

    function log_uniform_pth(physical_coords,parameters) result(hypercube_coords)
        implicit none
        !> The physical coordinates to be transformed
        real(dp), intent(in), dimension(:) :: physical_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(physical_coords)) :: hypercube_coords

        ! hypercube_coord -> min * (max/min)**hypercube_coord
        ! Lower half of the parameters array are the minimums
        ! Upper half of the parameters array are the maximums
        hypercube_coords = log(physical_coords/parameters(1::2)) / log(parameters(2::2)/parameters(1::2))

    end function log_uniform_pth

    !============= Sorted Uniform =====================================================

    !> This transforms the unit hypercube to a "forced identifiablity" prior.
    !! This means that the \f$(\theta_1,\theta_2,\ldots,\theta_n)\f$ variables are uniformly distributed in the
    !! physical prior space between \f$\theta_\mathrm{min}\f$ and \f$\theta_\mathrm{max}\f$, but have been sorted so
    !! that \f$(\theta_1<\theta_2<\ldots<\theta_n)\f$. This amounts to choosing a non-separable prior such that:
    !!
    !! \f[ \pi_n(\theta_n)
    !!     =  n  \frac{(\theta_n-\theta_\mathrm{min})^{n-1}}{(\theta_\mathrm{max}-\theta_\mathrm{min})^n}
    !!     \qquad  \theta_\mathrm{min}<\theta_n<\theta_\mathrm{max} \f]
    !! \f[ \pi_{n-1}(\theta_{n-1}|\theta_n)
    !!     =(n-1)\frac{(\theta_{n-1}-\theta_\mathrm{min})^{n-2}}{(\theta_\mathrm{max}-\theta_\mathrm{min})^{n-1}}
    !!     \qquad  \theta_\mathrm{min}<\theta_{n-1}<\theta_n \f]
    !! \f[ \pi_{n-2}(\theta_{n-2}|\theta_n,\theta{n-1})
    !!     =(n-2)\frac{(\theta_{n-2}-\theta_\mathrm{min})^{n-3}}{(\theta_\mathrm{max}-\theta_\mathrm{min})^{n-2}}
    !!     \qquad  \theta_\mathrm{min}<\theta_{n-2}<\theta_{n-1} \f]
    !! \f[...\f]
    !! \f[ \pi_1(\theta_1|\theta_n,\ldots,\theta_2)
    !!     =\frac{1}{(\theta_\mathrm{max}-\theta_\mathrm{min})}
    !!     \qquad  \theta_\mathrm{min}<\theta_1<\theta_2 \f]
    !!
    !! The first of these is the probability density for the largest of n points
    !! in \f$[\theta_\mathrm{min},\theta_\mathrm{max}]\f$.
    !!
    !! For the next highest point it is the smallest of \f$n-1\f$ points in the
    !! range \f$[\theta_\mathrm{min},\theta_n]\f$.
    !!
    !! To perform this transformation, it is cleanest to do this in two
    !! steps. First perform the above transformations using the inverse of the cumulative
    !! distribution function:
    !! \f[ CDF^{-1}(x) = x^{1/n} \f]
    !!
    !! Then transform the unit hypercube into the physical space with a linear
    !! rescaling

    function sorted_uniform_htp(hypercube_coords,parameters) result(physical_coords)
        implicit none

        !> The hypercube coordinates to be transformed
        real(dp), intent(in), dimension(:) :: hypercube_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(hypercube_coords)) :: physical_coords

        integer n_prior ! the dimension

        ! Get the size of the array
        n_prior = size(hypercube_coords)

        ! Transform the largest index to the largest of n_prior variables in [0,1]
        physical_coords(n_prior) = hypercube_coords(n_prior)**(1d0/n_prior)

        ! Then for the remaining variables, transform them to the largest of the
        ! remaining variables, and rescale so that the variable one larger is
        ! the maximum
        do n_prior=n_prior-1,1,-1
            physical_coords(n_prior) = hypercube_coords(n_prior)**(1d0/n_prior)*physical_coords(n_prior+1)
        end do

        ! Rescale using the parameters
        physical_coords = parameters(1) + physical_coords*(parameters(2)-parameters(1))

    end function sorted_uniform_htp

    function sorted_uniform_pth(physical_coords,parameters) result(hypercube_coords)
        implicit none

        !> The physical coordinates to be transformed
        real(dp), intent(in), dimension(:) :: physical_coords

        !> The parameters of the transformation
        real(dp), intent(in), dimension(:) :: parameters

        !> The transformed coordinates
        real(dp), dimension(size(physical_coords)) :: hypercube_coords

        integer n_prior ! the dimension
        integer i_prior ! the dimension

        ! Get the size of the array
        n_prior = size(physical_coords)

        ! Rescale back to [0,1]
        hypercube_coords =  (physical_coords - parameters(1)) / (parameters(2)-parameters(1))

        ! Undo the trasformation piece by piece
        do i_prior = 1,n_prior-1
            hypercube_coords(i_prior) = ( hypercube_coords(i_prior)/hypercube_coords(i_prior+1) )**i_prior
        end do
        hypercube_coords(n_prior) = hypercube_coords(n_prior)**n_prior

    end function sorted_uniform_pth

    ! =============================== Wrapper functions =====================================

    ! prior transformations
    function hypercube_to_physical(hypercube_coords,priors) result(physical_coords)
        implicit none
        type(prior), dimension(:), intent(in) :: priors
        real(dp), intent(in), dimension(:) :: hypercube_coords

        real(dp), dimension(size(hypercube_coords)) :: physical_coords

        integer :: i

        physical_coords=0d0

        do i=1,size(priors)
            select case(priors(i)%prior_type)
            case(uniform_type)
                physical_coords(priors(i)%physical_indices)= uniform_htp&
                    (hypercube_coords(priors(i)%hypercube_indices),priors(i)%parameters)
            case(gaussian_type)
                physical_coords(priors(i)%physical_indices)= gaussian_htp&
                    (hypercube_coords(priors(i)%hypercube_indices),priors(i)%parameters)
            case(log_uniform_type)
                physical_coords(priors(i)%physical_indices)= log_uniform_htp&
                    (hypercube_coords(priors(i)%hypercube_indices),priors(i)%parameters)
            case(sorted_uniform_type)
                physical_coords(priors(i)%physical_indices)= sorted_uniform_htp&
                    (hypercube_coords(priors(i)%hypercube_indices),priors(i)%parameters)
            end select
        end do

    end function hypercube_to_physical

    function physical_to_hypercube(physical_coords,priors) result(hypercube_coords)
        implicit none
        type(prior), dimension(:), intent(in) :: priors
        real(dp), intent(in), dimension(:) :: physical_coords

        real(dp), dimension(size(physical_coords)) :: hypercube_coords

        integer :: i

        hypercube_coords=0d0

        do i=1,size(priors)
            select case(priors(i)%prior_type)
            case(uniform_type)
                hypercube_coords(priors(i)%hypercube_indices)= uniform_pth&
                    (physical_coords(priors(i)%physical_indices),priors(i)%parameters)
            case(gaussian_type)
                hypercube_coords(priors(i)%hypercube_indices)= gaussian_pth&
                    (physical_coords(priors(i)%physical_indices),priors(i)%parameters)
            case(log_uniform_type)
                hypercube_coords(priors(i)%hypercube_indices)= log_uniform_pth&
                    (physical_coords(priors(i)%physical_indices),priors(i)%parameters)
            case(sorted_uniform_type)
                hypercube_coords(priors(i)%hypercube_indices)= sorted_uniform_pth&
                    (physical_coords(priors(i)%physical_indices),priors(i)%parameters)
            end select
        end do

    end function physical_to_hypercube

    function prior_log_volume(priors) result(log_volume)
        use utils_module, only: logTwoPi
        implicit none
        type(prior), dimension(:), intent(in) :: priors

        real(dp) :: log_volume
        integer :: i

        log_volume = 0

        do i=1,size(priors)
            select case(priors(i)%prior_type)
            case(uniform_type)
                log_volume = log_volume + sum( log(priors(i)%parameters(2::2)- priors(i)%parameters(1::2) ))
            case(gaussian_type)
                log_volume = log_volume + sum( 0.5d0*logTwoPi + log(priors(i)%parameters(2::2)) )
            case(log_uniform_type)
                log_volume = log_volume + sum( log(log( priors(i)%parameters(2::2)/priors(i)%parameters(1::2) )) )
            case(sorted_uniform_type)
                log_volume = log_volume + log(priors(i)%parameters(2)- priors(i)%parameters(1) ) - log(gamma(1d0+priors(i)%npars))
            end select
        end do

    end function prior_log_volume

    !> This function converts from strings to integer prior types
    function prior_type_from_string(string) result(prior_type)
        use utils_module, only: STR_LENGTH
        implicit none
        character(len=*),intent(in) :: string
        integer :: prior_type

        character(len=STR_LENGTH) :: string_buf

        write(string_buf,'(A)') string

        select case(trim(string_buf))

        case('uniform')
            prior_type=uniform_type
        case('gaussian')
            prior_type=gaussian_type
        case('log_uniform')
            prior_type=log_uniform_type
        case('sorted_uniform')
            prior_type=sorted_uniform_type
        case default
            prior_type=unknown_type
        end select

    end function prior_type_from_string

    !> This function converts an array of parameters into a set of prior blocks
    subroutine create_priors(priors,params,settings)
        use settings_module,   only: program_settings
        use params_module, only: param_type
        use utils_module,  only: relabel
        implicit none
        type(prior), dimension(:), allocatable,intent(out)   :: priors  !> The array of priors to be returned
        type(param_type),dimension(:),allocatable,intent(in) :: params  !> Parameter array
        type(program_settings), intent(inout) :: settings !> Program settings

        integer, dimension(size(params)) :: prior_blocks
        integer :: num_blocks

        integer :: num_params
        integer :: i_params

        integer, dimension(size(params)) :: speeds_old
        integer, dimension(size(params)) :: speeds
        integer :: i_speed
        integer, parameter :: max_speed = huge(1)

        integer, dimension(size(params)) :: hypercube_indices
        integer :: i_hypercube

        num_params = size(params)

        ! First determine how many prior blocks there are
        do i_params=1,num_params
            prior_blocks(i_params) = params(i_params)%prior_block
        end do
        ! re-organise these labels
        prior_blocks = relabel(prior_blocks,num_blocks)

        ! Allocate the priors array
        if(allocated(priors)) deallocate(priors)
        allocate(priors(num_blocks))

        ! Next determine the hypercube indices via the grades

        ! Find the various speeds:
        do i_params=1,num_params
            speeds_old(i_params) = params(i_params)%speed
        end do

        ! Relabel them with the numbers 1,2,3...
        i_speed = 0
        do while(any(speeds_old/=max_speed))
            i_speed=i_speed+1
            where(speeds_old==minval(speeds_old))
                speeds=i_speed
                speeds_old=max_speed
            end where
        end do

        if(allocated(settings%grade_dims)) deallocate(settings%grade_dims)
        allocate(settings%grade_dims(maxval(speeds)))

        ! Now assign hypercube indices
        i_hypercube = 0
        do i_speed=1,maxval(speeds)
            do i_params=1,num_params
                if(speeds(i_params)==i_speed) then
                    i_hypercube=i_hypercube+1
                    hypercube_indices(i_params) = i_hypercube
                end if
            end do
            settings%grade_dims(i_speed) = count(speeds==i_speed)
        end do

        allocate(settings%sub_clustering_dimensions(count([ (params(i_params)%sub_cluster, i_params=1,num_params) ])))
        settings%sub_clustering_dimensions = pack(hypercube_indices, [ (params(i_params)%sub_cluster, i_params=1,num_params) ] )

        ! Finally, add each of the parameters to the prior blocks, coupled with the hypercube information
        do i_params=1,num_params
            call add_param_to_prior(priors(prior_blocks(i_params)),params(i_params),i_params,hypercube_indices(i_params))
        end do

    end subroutine create_priors

    subroutine add_param_to_prior(priori,param,physical_index,hypercube_index)
        use params_module, only: param_type
        use array_module,  only: reallocate
        use abort_module,  only: halt_program
        implicit none
        type(prior), intent(inout)   :: priori          !> The prior to be added to
        type(param_type),intent(in)  :: param           !> The params to add
        integer, intent(in)          :: physical_index  !> The position in the likelihood call
        integer, intent(in)          :: hypercube_index !> The position in the unit hypercube

        ! Allocate physical indices if it is unallocated
        if(.not.allocated(priori%physical_indices))  allocate(priori%physical_indices(0))
        if(.not.allocated(priori%hypercube_indices)) allocate(priori%hypercube_indices(0))

        priori%npars=priori%npars+1                               ! Increment the number of parameters

        call reallocate(priori%physical_indices,priori%npars) ! reallocate the physical index array
        priori%physical_indices(priori%npars) = physical_index    ! give it the physical index of this point

        call reallocate(priori%hypercube_indices,priori%npars) ! reallocate the physical index array
        priori%hypercube_indices(priori%npars) = hypercube_index   ! give it the physical index of this point

        if(priori%prior_type==unknown_type) then
            priori%prior_type = param%prior_type
        else if(priori%prior_type/= param%prior_type) then
            call halt_program('create_priors error: parameter '//trim(param%paramname)// ' must have the same prior type as others within its block')
        end if

        ! Allocate the prior parameters if its unallocated
        if (.not. allocated(priori%parameters) ) allocate(priori%parameters(0))
        ! expand the parameters array by size prior_params
        call reallocate(priori%parameters,size(priori%parameters)+size(param%prior_params))
        ! add these to the end
        priori%parameters(size(priori%parameters)-size(param%prior_params)+1:size(priori%parameters)) =param%prior_params

    end subroutine add_param_to_prior

end module priors_module


    Program dsbevd_example

!     DSBEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dsbevd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, kd, ldab, ldz, liwork, lwork, n
      Character (1) :: job, uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ab(:, :), w(:), work(:), z(:, :)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'DSBEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd
      ldab = kd + 1
      ldz = n
      liwork = 5*n + 3
      lwork = 2*n*n + 5*n + 1
      Allocate (ab(ldab,n), w(n), work(lwork), z(ldz,n), iwork(liwork))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of A
      Call dsbevd(job, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, &
        liwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)
        Write (nout, *)
        Flush (nout)

!       Standardize the eigenvectors so that first elements are non-negative.
        Do i = 1, n
          If (z(1,i)<0.0_dp) Then
            z(1:n, i) = -z(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, (8F8.4))
    End Program


!-*- f90 -*- - file contains F90 code in free format

subroutine trafoso(L,cf)
  implicit none
  integer, intent(in)  :: L
  real*8,  intent(out) :: cf(2*(2*L+1),2*(2*L+1))
  ! locals
  integer :: m1, m2, k1, k2, ms, ml, mj
  real*8  :: ams, amj, d
! trafoso provides transformation matrices from
! |L,1/2,mL,mS> (L=0,1,2,3, mS=-1/2,1/2) basis to
! basis |J,L,S,mJ>, J=L-1/2, L+1/2
! H. Watanabe 'Operator Methods in Ligand Field Theory'
! Prentice Hall, 1966, Table 1.8-1.
! ordering because of the convention used in WIEN is:
!                    mS=1/2        mS=-1/2
!                  -L .......L  -L ...... L     (2*(2L+1) columns)
!         -(L-1/2)
!            .
! J=L-1/2    .
!            .
!          (L-1/2)
!          -L-1/2
!            .
! J=L+1/2    .
!            .
!           L+1/2
!
  cf=0
  if(L.eq.0)then
     cf(1,2)=1.
     cf(2,1)=1.
  else
     k1=0
     do ms=-1,1,2
        ams=-ms/2.
        do ml=-L,L
           k1=k1+1
           k2=0
           do mj=-2*L+1,2*L-1,2   ! L-1/2 states
              amj=mj/2.
              k2=k2+1
              d=amj-mL-ams
              if(abs(d).lt.0.0001)then
                 if(ms.eq.1)then
                    cf(k2,k1)=-sqrt((L+0.5+amj)/(2*L+1))
                 else
                    cf(k2,k1)= sqrt((L+0.5-amj)/(2*l+1))
                 endif
              endif                ! L-1/2 states end
           enddo
           do mj=-2*L-1,2*L+1,2   ! L+1/2 states
              amj=mj/2.
              k2=k2+1
              d=amj-mL-ams
              if(abs(d).lt.0.0001)then
                 if(ms.eq.1)then
                    cf(k2,k1)= sqrt((L+0.5-amj)/(2*L+1))
                 else
                    cf(k2,k1)= sqrt((L+0.5+amj)/(2*l+1))
                 endif
              endif                ! L+1/2 states end
           enddo
        enddo
     enddo
  endif
  return
end subroutine trafoso


      subroutine compute_athth(Axx,A,B,Nx,Athth)
         implicit none
         integer Nx
         real*8 Axx(Nx)
         real*8 A(Nx)
         real*8 B(Nx)
         real*8 Athth(Nx)
         integer i
         ! Axx/A + 2*Athth/B = 0
         do i=1,Nx,1
           Athth(i) = -B(i)*Axx(i)/(2.0D0*A(i))
         end do
         END


program exercise_3_4

!сумма элементов массива с индексами с меняющимся шагом = 3, начиная от 5го элемента
   implicit none

   character(*), parameter     :: input_file = "../data/input.txt", output_file = "output.txt"
   integer                     ::In = 0, Out = 0, N=0
   real(4)                     :: SumA=0
   real(4), allocatable        ::  A (:)

open (file=input_file, newunit=In)
   read (In, *) N  ! число -  размерность массива
   allocate (A(N))
   read (In, *) A  !читаем N  следующиx элементов из файла
close (In)

   SumA = Sum(A(5:N:3)) !Правильно - экономия памяти. в кеш памяти хранится только каждый 3й элемент. перебор от 5го элемента до  элемента N c шагом 3

   open (file=output_file, newunit=Out)
      write (Out, '(F0.2)') A  !оставить 2 знака после запятой
      write (Out, *) SumA
   close (Out)

end program exercise_3_4


      SUBROUTINE stoerm(y,d2y,nv,xs,htot,nstep,yout,derivs)
      INTEGER nstep,nv,NMAX
      REAL htot,xs,d2y(nv),y(nv),yout(nv)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
CU    USES derivs
      INTEGER i,n,neqns,nn
      REAL h,h2,halfh,x,ytemp(NMAX)
      h=htot/nstep
      halfh=0.5*h
      neqns=nv/2
      do 11 i=1,neqns
        n=neqns+i
        ytemp(n)=h*(y(n)+halfh*d2y(i))
        ytemp(i)=y(i)+ytemp(n)
11    continue
      x=xs+h
      call derivs(x,ytemp,yout)
      h2=h*h
      do 13 nn=2,nstep
        do 12 i=1,neqns
          n=neqns+i
          ytemp(n)=ytemp(n)+h2*yout(i)
          ytemp(i)=ytemp(i)+ytemp(n)
12      continue
        x=x+h
        call derivs(x,ytemp,yout)
13    continue
      do 14 i=1,neqns
        n=neqns+i
        yout(n)=ytemp(n)/h+halfh*yout(i)
        yout(i)=ytemp(i)
14    continue
      return
      END

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


program prime_test
    use :: primes_mod, only : is_prime
    implicit none
    integer, parameter :: max_value = 100
    integer :: n

    do n = 0, max_value
        if (is_prime(n)) print '(I4)', n
    end do
end program prime_test


F(N) = ((1 + SQRT(5))**N - (1 - SQRT(5))**N)/(SQRT(5)*2**N)


FUNCTION CSEDVIS(SED)

  ! CHANGE RECORD
  !
  !
  ! **  CALCULATES KINEMATIC VISCOSITY OF HIGH CONCENTRATION COHESIVE
  ! **  SEDIMENT-WATER MIXTURE BASED ON
  ! **
  ! **  MEHTA, A. J., AND F.JIANG, 1990: SOME OBSERVATIONS ON BOTTOM
  ! **  MUD MOTION DUE TO WAVES. COASTAL AND OCEANOGRAPHIC ENGINEERING
  ! **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661

  IMPLICIT NONE
  REAL :: CSEDVIS,SED,WTL,WTH,VISL,VISH,VISR

  IF( SED <= 25667.) VISR=0.116883D-3*SED
  IF( SED >= 36667.) VISR=1.52646D-6*SED+3.125
  IF( SED > 25667.0 .AND. SED < 36667.0 )THEN
    WTL=(36667.-SED)/11000.
    WTH=(SED-25667.)/11000.
    VISL=0.116883D-3*25667
    VISH=1.52646D-6*36667.+3.125
    VISR=WTL*VISL+WTH*VISH
  ENDIF
  CSEDVIS=1.D-6*(10.**VISR)

END FUNCTION


      SUBROUTINE ALTSIZ (EXPDC, MINSIZ,MAXSIZ, MAXALT, NUMALT,ALT)

C  ALTSIZ finds nearby alternate sizes, to the expected size, and
C  returns them to the caller.  The alternates fulfill all these
C  conditions: 1) each differs from all the others by at least 25%
C  (relative) and by MINSIZ (absolute), and 2) each is no less than
C  MINSIZ, and no greater than MAXSIZ.

C  Input parameters:
C    EXPDC  : Expected size; always the first entry in ALT
C    MINSIZ : Minimum size for an entry and for difference between entries
C    MAXSIZ : Maximum size for an entry
C    MAXALT : Maximum number of alternatives to be returned (including EXPDC)
C  Output parameters:
C    NUMALT : Actual number of alternatives returned
C    ALT    : List of alternative sizes

      INTEGER   MAXALT, NUMALT, IX

      REAL      NXL1,NXL2,NXS1,NXS2
      REAL      EXPDC, MINSIZ,MAXSIZ, ALT(MAXALT)

      NUMALT = 1
      ALT(NUMALT) = EXPDC
      NXL1 = EXPDC
      NXS1 = EXPDC

C  generate alternative sizes - must differ by at least 25% *and* MINSIZ
      DO 100 IX = 1,MAXALT
C  generate larger choices
         NXL2 = 1.25 * NXL1
         IF (NXL2-NXL1 .LT. MINSIZ) THEN
            NXL2 = NXL1 + MINSIZ
         ENDIF
         IF (NXL2 .LE. MAXSIZ) THEN
            NUMALT = NUMALT+1
            ALT(NUMALT) = NXL2
            IF (NUMALT .GE. MAXALT) RETURN
            NXL1 = NXL2
         ENDIF
C  generate smaller choices
         NXS2 = NXS1/1.25
         IF (NXS1-NXS2 .LT. MINSIZ) THEN
            NXS2 = NXS1 - MINSIZ
         ENDIF
         IF (NXS2 .GE. MINSIZ) THEN
            NUMALT = NUMALT+1
            ALT(NUMALT) = NXS2
            IF (NUMALT .GE. MAXALT) RETURN
            NXS1 = NXS2
         ENDIF
100   CONTINUE

      END


      program DRSCHI
c>> 2001-05-25 DRSCDCHI Krogh Minor change for making .f90 version.
c>> 1996-06-17 DRSCDCHI Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRSCDCHI Krogh  Changed Fortran 90 code.
c>> 1994-10-19 DRSCDCHI Krogh  Changes to use M77CON
c>> 1994-07-06 DRSCDCHI WVS set up for chgtyp
c
c     Evaluate the Probability Integral Q(chi-square,nu) of the Chi-
c     Square distribution by using SCDCHI.
c
c--S replaces "?": DR?CHI, DR?CDCHI, ?cdchi
      real             CHISQ, NU, P, Q(4)
      integer IERR, J
c
10    format ('     Probability Integral Q(chi**2 | nu)'/
     1 '    CHI**2        NU = 1',13x,'2',13x,'3',13x,'4')
20    format (1p,5g14.7)
      chisq = 0.5e0
      print 10
30    if (chisq .le. 6) then
         do 40 j = 1, 4
            nu = j
            call scdchi (chisq, nu, p, q(j), ierr)
40       continue
         print 20, chisq, q
         chisq = chisq + 0.5e0
         go to 30
      end if
      stop
      end


      SUBROUTINE ssmied
!
!                          PROCESS SSMIGR
!                          ------- ------
!
!  Document date:
!
!                        Split-Step Migration
!
!    Reference: Stoffa et al., Split-step Fourier Migration,
!                              Geophysics,55,p.410-421,1990.
!
!  This process performs a "split-step" Fourier migration on
!  stacked seismic data.  The method is designed to provide a
!  fast f-k approach to migration in laterally varying velocity
!  media.  The approach is straightforward.  The data are migrated
!  in small depth increments of dz.  For each dz a loop over a
!  frequency range fmin to fmax is performed in which the data are:
!
!  1) trasformed from f-x to f-k;
!  2) phase shifted by exp(i*dz*Kz) [Kz=csqrt(w^2*u0^2-Kx^2)]
!     using a reference slowness u0;
!  3) transformed from f-k to f-x;
!  4) phase shifted by exp(i*w*(u(x,z)-u0))
!
!  Imaging is then done at depth Zj by a sum over frequencies
!  from fmin to fmax.
!
!  Notes:
!
!  The complex square root calculation of Kz results in an exponentially
!  damped response to inhomogeneous interface waves, a difficulty in
!  other implementations of this type of phase-shift-plus-correction
!  method.
!
!  Extreme lateral velocity variations, such as seen at some
!  continental margins, may be handled by breaking the migration
!  into several overlapping panels which are later spliced together.
!
!  Big step, ZBIG:
!    You may migrate in one big step through an upper constant
!    slowness region such as the water column.  No imaging is done
!    for this region.  If there is a deep water delay in your data,
!    you may want to remove delay to negate temporal wrap-around.
!    This is most easily done through start-end-time pair in process
!    DISKIN (i.e. set 0.0 8.0)
!
!  Migration bandwidth, FMIN, FMAX:
!    Runtime increases in direct proportion to migration bandwidth.
!    It is worthwhile doing a couple of small tests to see what
!    frequencies are actually useful and adjusting the parameters
!    FMIN and FMAX accordingly.
!
!  Depth step, DELTAZ:
!    The migration depth step dz need not be tiny, but in general small
!    enough to provide unaliased sampling of the smallest vertical
!    wavenumber of interest.
!
!  Data tapers, BPAD, EPAD:
!    The user is given the option of padding either side of the data
!    panel being migrated. The padded region is filled with copies of
!    the end traces which are tapered down within the pad region. This
!    is highly recommended as it reduces Gibbs phenomena and Nyquist
!    noise.  It should be kept in mind, however, that a power of 2 FFT
!    is used and that the length of the FFT is determined as the next
!    power of 2 abover (data panel lenght)+BPAD+EPAD.  So if you are
!    migrating 1900 traces and you pad with 100 on each side, you will
!    be using a 4096 FFT for each depth step. If you had padded with 50
!    on each you would be using a 2048 FFT, much faster.
!
!  Migration taper, MTAP:
!    In addition to the tapered padding of the first and last trace, an
!    exponential taper can be applied to the ends of the spatial window
!    at each migration step.  This inhibits "wraparound" of migration
!    smiles from the data panel ends sides.  An exponental taper on the
!    order of MTAP=25 traces is recommended.  The example below should
!    clarify the issue.  It is important to note that the FFT length is
!    not based on the length of the exponential taper, only on the
!    (data panel lenght)+BPAD+EPAD, so that if care is not taken data
!    may be affected by the exponental taper.
!
!    MTAP=5
!    |<5>|                                      |<5>|
!    eeeee11111111111111111111111111111111111111eeeee  <-*1
!    tttttttdddddddddddddddddddddddddddttttttt0000000
!    |< 7 >||                         ||< 7 >|      |
!    |BPAD=7|                         |EPAD=7       |
!    |      |                         |             |
!    |      |<- data panel = 27 ----->|             |
!    |                                              |
!    |<-------- 2^n based on 27+(2*7) = 48 -------->|
!
!
!    *1) this vector is applied to each frequency at each depth
!        step.  In f-k jargon this type of taper is called a sponge.
!
!  EXAMPLE MIGRATION:
!  Shallow Sediments near ODP HOLE 504B
!  diskin
!      ipath 504B.dmo.stack.224.624 set 0.0 8.0 end
!  end
!  ssmigr
!      deltax 12.5 deltaz 10 vskip 1500 zskip 3000 ez 10000
!      bpad 50 epad 50 mtap 25 twinlen 0.25
!      ref 0 nvsmth 3 vpath v.scratch
!      fmin 5 fmax 40 path ps.scratch sgypath vmodel.segy
!      fno  224 lno  224 vdp 1500.0 3480.0 1850.0 3490.0 1850.0 3721.3 end
!      fno  424 lno  424 vdp 1500.0 3442.5 1850.0 3452.5 1850.0 3785.5 end
!      fno  524 lno  524 vdp 1500.0 3397.5 1850.0 3407.5 1850.0 3694.3 end
!      fno  624 lno  624 vdp 1500.0 3390.0 1850.0 3400.0 1850.0 3686.8 end
!  end
!
!  PARAMETER DICTIONARY
!  --------- ----------
!  EZ     - End Depth, in meters.  The number of samples output will be
!           EDEPTH  / DELTAZ + 1.  The first output sample is ALWAYS 0.
!         - Required.  e.g.  ez 6000
!  DELTAX - The distance between traces, in meters.
!           Required.
!  DELTAZ - The output sample interval in meters per sample.  DELTAZ may
!           not exceed 32 since it is carried in the SEGY header in
!           millimeters and as a 16 bit integer (thus 32767 millimeters
!           is the maximum).  This is analogous to the sample interval
!           in time which the SEG-Y format carries as nanoseconds
!           (milliseconds / 1000).
!           Required.
C TWINLEN - Time WINdow LENgth of temporal taper at end of trace. This
C           taper is exponential in nature and is given in seconds. The
C           time taper should reduce energy migrating from truncation
C           of time trace.
C           Preset = 0.25
!  MTAP   - Migration TAPer.  The exponential spatial taper discussed above.
C           preset = 25
!  FMIN   - Minimum frequency of interest.
!           Preset = 0
!  FMAX   - Maximum frequency of interest
!         - preset = nyquist / 2  or   (4/si)
!  VDP    - The rms velocity to use in migration, given as a list of
!           Velocity Depth Pairs.  The velocity should be in units of
!           meters per second and the depth should be in units of
!           meters.
!           Required.    velocity range 350 to 32000
!  NVSMTH - This parameter specifies the number of Velocity SMooTHing
!           operations desired before constructing velocity file.
!           The VSMTH parameter is useful for smoothing across velocity
!           contrasts which otherwise can cause distortion in depth
!           migration. This is a 3 point convolutional operator.
!           Preset = 3
!  FNO    - The first shot/rp number the parameter list applies to.
!           Preset = the first shot/rp received.    e.g.   fno 101
!  LNO    - The last shot/rp number the parameter list applies to.
!           Preset = the last shot/rp received.    e.g.   lno 101
!  BPAD   - The number of zero amplitude traces to insert prior to the
!           first trace.
!           Preset = 1   range 1 to 500      e.g. bpad 10
!  EPAD   - The number of zero amplitude traces to append after the last
!           trace.
!           Preset = 1   range 1 to 500      e.g. epad 10
!  ZSKIP  - The first depth to compute.  The first output sample is
!           ALWAYS 0.  This saves computer time!  The first velocity of
!           VDP of the first FNO/LNO list is used as the velocity for
!           time to depth conversion unless parameter VSKIP is given.
!           Preset = 0.
!  VSKIP  - Velocity used in extrapolation for parameter ZSKIP, usually
!           the water velocity in marine work. If using ZSKIP, then VSKIP
!           is required.
!  REF    - Reference slowness, u0, from a given depth.  The minimum
!           slowness may provide a better reference than the average
!           slowness for imaging features such as a rough basement
!           surface beneath low velocity sediments.
!         =0, minimum slowness.
!         =1, average slowness.
!         =2, maximum slowness.
!           Preset = 1
!  PATH   - The pathname (filename) of a scratch file SSMIGR should use
!           for the intermediate transposed data.  The purpose of this
!           parameter is to allow the user to specify the exact disk
!           partition to use in case the "current" partition does not
!           have enough space.
!           preset = a scratch file in the current directory
!           e.g.    path /user/scratch/moreroom
!  VPATH  - The pathname (filename) of a scratch file SSMIGR should use
!           for the transposed velocity slices.  The purpose of this
!           parameter is to allow the user to specify the exact disk
!           partition to use in case the "current" partition does not
!           have enough space.
!           preset = a scratch file in the current directory
!           e.g.    vpath /user/scratch/vmoreroomc
!  SGYPATH - The pathname (filename) of an additional SEGY compatible
!           velocity file to be output for external purposes. Includes
!           the smoothing operators.
!           preset = none
!           e.g.    sgypath /user/scratch/vmoreroomc.segy
!
!  Copyright (C) 1995 by:
!  Woods Hole Oceanographic Institution and
!  The Regents of The University of California, 1995
!
!  Written by Dan Lizarralde, WHOI, and adapted by Paul Henkart, SIO
!  Modifications by Graham Kent & Dan Lizarralde, WHOI
!  ALL RIGHTS RESERVED.
!
!  Present limitations include 8192 traces, 5000 depth steps & 800 frequencies.
!  If the number of depths * number of traces exceed 500,000 use sioseis.BIG
!  which allows a product of nz*nx = 3,500,000, also remember padding when
!  estimating your nx.
!
      PARAMETER ( npars = 21 )                                          ! the number of user parameters
      PARAMETER ( maxvel = 55 )                                         ! the maximum number of velocity-depth pairs
      CHARACTER*80 token
      CHARACTER*7 names(npars)
      CHARACTER*1 types(npars)                                          ! the type of parameter
      REAL vals(npars)                                                  ! holds the REAL parameter values
      DIMENSION lvals(npars)                                            ! holds the INTEGER parameter values
      EQUIVALENCE (vals(1),lvals(1))                                    ! must be the same so that wrdisc scr works!
      DIMENSION vels(maxvel*2)
!
      COMMON /edits/ ierror, iwarn, irun, now, icompt
      COMMON /ssmigr/ junit, nlists, nwrds
!
      INTEGER fno, bpad, epad, ref, vdp, vintpl
      INTEGER nvsmth, mtap
!
      EQUIVALENCE ( lprint, lvals(1) ),
     2            ( fno, lvals(2) ),
     3            ( lno, lvals(3) ),
     4            ( nvels, lvals(4) ),
     5            ( bpad, lvals(5) ),
     6            ( epad, lvals(6) ),
     7            ( zskip, vals(7) ),
     8            ( fmin, vals(8) ),
     9            ( fmax, vals(9) ),
     *            ( deltax, vals(10) ),
     1            ( deltaz, vals(11) ),
     2            ( ez, vals(12) ),                                     ! I couldn't resist
     3            ( lunscr, lvals(13) ),
     4            ( lunvel, lvals(14) ),
     5            ( vskip, vals(15) ),
     6            ( ref, lvals(16) ),
     7            ( vintpl, lvals(17) ),
     8            ( nvsmth, lvals(18) ),
     9            ( twinlen, vals(19) )
      EQUIVALENCE ( mtap, lvals(20) ),
     1            ( lunsegy, lvals(21) )

      DATA names /'LPRINT ', 'FNO    ', 'LNO    ', 'VDP    ', 'BPAD   ',
     1            'EPAD   ', 'ZSKIP  ', 'FMIN   ', 'FMAX   ', 'DELTAX ',
     2            'DELTAZ ', 'EZ     ', 'PATH   ', 'VPATH  ', 'VSKIP  ',
     3            'REF    ', 'VINTPL ', 'NVSMTH ', 'TWINLEN', 'MTAP   ',
     4            'SGYPATH'/
      DATA types / 6*'L',6*'F',2*'A','F',2*'L','L','F','L','A'/
!****
!****    Set the parameter presets and various variable presets
!****
      lprint = 0
      fno  = 0
      lno = 0
      nvels = 0
      bpad = 0
      epad = 0
      zskip = 0.
      fmin = 0.
      fmax = 0.
      deltax = 0.
      deltaz = 0.
      ez = 0.
      lunscr = 0
      lunvel = 0
      lunsegy = 0
      nz = 0
      vskip = 0.
      ref = 1
      vdp = 0
      vintpl = 1
      vsmth = 3
      twinlen = .25
      mtap = 25
      CALL getfil( 1, junit, token, istat )                             ! get a file for the DISK parameters
!****
!****     get the user's parameters
!****
      ntokes = 0                                                        ! count the tokens
  100 CONTINUE
      CALL getoke( token, nchars )                                      ! get a token and it's length
      CALL upcase( token, nchars )                                      ! convert parameter names to upper case
      IF( nchars .EQ. 0 ) THEN                                          ! anything there?
          CALL rdline                                                   ! nope, get another line
          ntokes = 0
          GOTO 100
      ENDIF
      ntokes = ntokes + 1
  110 DO 120 i = 1, npars
         nparam = i
         IF( token(1:nchars) .EQ. names(nparam) ) GOTO 150
  120 CONTINUE
      IF( token(1:nchars) .EQ. 'END' ) GOTO 200
      IF( vdp .EQ. 1 ) GOTO 160
      PRINT *,' ***  ERROR  ***  No such parameter as ',token(1:nchars)
      ierror = ierror + 1
      GOTO 100
  150 CONTINUE
      vdp = 0
      lparam = nparam
!****
!****   Got the parameter name, now get the value
!****
      CALL getoke( token, nchars )                                      ! get the value
      ntokes = ntokes + 1
      IF( nchars .EQ. 0 ) THEN
          CALL rdline
          ntokes = 0
          GOTO 150
      ENDIF
      IF( types(nparam) .EQ. 'A' ) THEN
          IF( names(nparam) .EQ. 'PATH' ) THEN
              CALL getfil( 3, lunscr, token(1:nchars), istat )
              IF( istat .NE. 0 ) THEN
                  PRINT *,' ***  ERROR  ***   Can not open file ',
     &                  token(1:nchars)
                  ierror = ierror + 1
              ENDIF
          ENDIF
          IF( names(nparam) .EQ. 'VPATH' ) THEN
              CALL getfil( 3, lunvel,  token(1:nchars), istat )         ! create the velocity file
                  IF( istat .NE. 0 ) THEN
                    PRINT *,' ***  ERROR  ***   Can not open file ',
     &                  token(1:nchars)
                    ierror = ierror + 1
                  ENDIF
          ENDIF
           IF( names(nparam) .EQ. 'SGYPATH' ) THEN
               CALL getfil( 3, lunsegy,  token(1:nchars), istat )        ! create segy velocity file
                  IF( istat .NE. 0 ) THEN
                    PRINT *,' ***  ERROR  ***   Can not open file ',
     &                  token(1:nchars)
                    ierror = ierror + 1
                  ENDIF
          ENDIF
          GOTO 100
      ENDIF
  160 CALL dcode( token, nchars, areal, istat )                         ! convert the alpha number to an internal machine number
      IF( istat .NE. 2 ) ierror = ierror + 1                            ! was the an error decoding it?
      IF( names(lparam) .EQ. 'VDP' ) THEN
          nvels = nvels + 1
          vels(nvels) = areal
          vdp = 1
          GOTO 100
      ENDIF
      IF( types(lparam) .EQ. 'L' ) THEN
          lvals(lparam) = areal                                         ! convert the real to INTEGER*4
      ELSE
          vals(lparam) = areal                                          ! move the real to the parameter
      ENDIF
      GOTO 100
!****
!****    Do the parameter validity checks
!****
  200 CONTINUE
      IF( fno .LT. 0 ) THEN
          PRINT *,' ***  ERROR  ***  FNO must be positive.'
          ierror = ierror + 1
      ENDIF
      IF( lno .LT. 0 ) THEN
          PRINT *,' ***  ERROR  ***  LNO must be positive.'
          ierror = ierror + 1
      ENDIF
      IF( deltax .LT. 1. .OR. deltax .GT. 500. ) THEN
          PRINT *,' ***  ERROR  ***  DELTAX must be between 1 and 500.'
          ierror = ierror + 1
      ENDIF
      IF( nvels .EQ. 0 ) THEN
          PRINT *,' ***  ERROR  ***  A velocity function must be given.'
          ierror = ierror + 1
      ENDIF
      IF( ref .LT. 0 .OR. ref .GT. 2 ) THEN
          PRINT *,' ***  ERROR  ***  REF must be 0, 1, or 2'
          ierror = ierror + 1
      ENDIF
      IF( nvels/2*2 .NE. nvels ) THEN
          PRINT *,' ***  ERROR  ***  Velocities must be in pairs.'
          ierror = ierror + 1
      ENDIF
      DO 1234 i = 1, nvels, 2
         IF( vels(i) .LT. 350. .OR. vels(i) .GT. 32000. ) THEN
             PRINT *,' ***  ERROR  ***  Velocities must be between',
     *          ' 350 and 32000.'
             ierror = ierror + 1
         ENDIF
         IF( i .NE. 1 .AND. vels(i+1) .LE. vels(i-1) ) THEN
             PRINT *,' ***  ERROR  ***  The depths within the velocity',
     *          ' depth pair must increase.'
             ierror = ierror + 1
         ENDIF
 1234 CONTINUE
      IF( bpad .LT. 0 .OR. bpad .GT. 500 ) THEN
          PRINT *,' ***  ERROR  ***  BPAD must be between 1 and 500.'
          ierror = ierror + 1
      ENDIF
      IF( epad .LT. 0 .OR. epad .GT. 500 ) THEN
          PRINT *,' ***  ERROR  ***  EPAD must be between 1 and 500.'
          ierror = ierror + 1
      ENDIF
      IF( deltaz .LT. 1. .OR. deltaz .GT. 32. ) THEN
          PRINT *,' ***  WARNING  *** DELTAZ must be between 1. and 32.'
          iwarn = iwarn + 1
      ENDIF
      IF( ez .LT. 100 .OR. ez .GT. 30000 ) THEN
          PRINT *,' ***  ERROR  *** EZ must be between 100 & 30000'
          ierror = ierror + 1
      ENDIF
!****
!****    Write the parameters to a disc file  and get another list!
!****
      IF( lno .EQ. 0 ) lno = fno
      nwrds = npars
      CALL wrdisc( junit, lvals, nwrds )
      IF( nvels .GT. 0 ) CALL wrdisc( junit, vels, nvels )
      nlists = nlists + 1
!
      IF( IAND(lprint,1) .NE. 0 ) THEN
          PRINT *,(lvals(i),i=1,6)
          PRINT *,(vals(i),i=7,12)
          PRINT *,(lvals(i), i=13,npars)
          IF( nvels .NE. 0 ) PRINT *,' vels:',(vels(i),i=1,nvels)
      ENDIF
!****
!****    finish up the parameter reading
!****
 2000 CONTINUE
      CALL getoke( token, nchars )                                       ! get the next token
      CALL upcase( token, nchars )
      ntokes = ntokes + 1
      IF( nchars .LE. 0 ) THEN
          IF( now .EQ. 1 ) PRINT *,' <  ENTER PARAMETERS  >'
          CALL rdline                                                   ! get a new line of parameters
          ntokes = 0
          GOTO 2000
      ENDIF
      lno = 0
      nvels = 0
      IF( token(1:nchars) .NE. 'END' .OR. nchars .NE. 3 ) GOTO 110

      RETURN
      END


!>  Gauss-Legendre quadrature rule.
!!
!!  Procedures:
!!  ------------------------------
!!  quadrature_nodes        ! general rule, needs (nterms, level, (1,2,3)-dim)
!!  quadrature_weights      ! general rule, needs (nterms, level, (1,2,3)-dim)
!!
!!  gl_nodes                ! 1D rule, only needs nnodes
!!  gl_weights              ! 1D rule, only needs nnodes
!!
!!  @author Nathan A. Wukie
!!
!---------------------------------------------------------------------------------------------
module mod_gauss_legendre
#include <messenger.h>
    use mod_kinds,          only: rk,ik
    use mod_constants,      only: PI, ONE, TWO, THREE, FOUR, EIGHT, ZERO
    use mod_legendre,       only: legendre_val1D, dlegendre_val1D
    implicit none

contains

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/28/2017
    !!
    !------------------------------------------------------------------------
    function quadrature_nodes(nterms,level,dim) result(nodes_)
        integer(ik),    intent(in)  :: nterms
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        ! Level for quadrature nodes corresponds to the number of nodes
        ! in the 1D tensor construction of the node set.
        real(rk),   allocatable, dimension(:)   :: xi_nodes, eta_nodes, zeta_nodes
        integer(ik)                             :: ixi, ieta, izeta, inode, nnodes, ierr, nterms1d, nnodes1d
        integer(ik)                             :: nnodes_xi, nnodes_eta, nnodes_zeta
        real(rk),   allocatable, dimension(:)   :: nodes_(:,:)

        !
        ! Compute number of terms in 1D polynomial expansion
        !
        nterms1d = 0
        do while (nterms1d*nterms1d*nterms1d < nterms)
            nterms1d = nterms1d + 1
        end do

        !
        ! Compute number of nodes in quadrature set
        !
        select case (level)
            case(1)
                nnodes1d = nterms1d         ! Collocation quadrature
            case(2)
                nnodes1d = ceiling(3._rk*real(nterms1d,rk)/2._rk)
            case(3)
                nnodes1d = 2*nterms1d + 1
            case(4)
                nnodes1d = 3*nterms1d + 1
            case(5)
                nnodes1d = 5*nterms1d + 1
            case default
                call chidg_signal(FATAL, "compute_nnodes_integration: Value for gq_rule, specifying the rule for selecting number of quadrature points was not valid. Recognized values are gq_rule = (1, 2, 3)")
        end select

        !
        ! Allocate 1d arrays
        !
        allocate(xi_nodes(nnodes1d), eta_nodes(nnodes1d), zeta_nodes(nnodes1d), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Get 1D nodes
        !
        select case(dim)
            case(1)
                nnodes_xi   = nnodes1d
                nnodes_eta  = 1
                nnodes_zeta = 1
                xi_nodes = gl_nodes(nnodes1d)
                eta_nodes  = ZERO
                zeta_nodes = ZERO
            case(2)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = 1
                xi_nodes  = gl_nodes(nnodes1d)
                eta_nodes = gl_nodes(nnodes1d)
                zeta_nodes = ZERO
            case(3)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = nnodes1d
                xi_nodes   = gl_nodes(nnodes1d)
                eta_nodes  = gl_nodes(nnodes1d)
                zeta_nodes = gl_nodes(nnodes1d)
            case default
                call chidg_signal_one(FATAL,"quadrature_nodes: invalid dimension.",dim)
        end select

        !
        ! Allocate nodes_
        !
        nnodes = nnodes_xi*nnodes_eta*nnodes_zeta
        allocate(nodes_(nnodes,3), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nnodes_zeta
            do ieta = 1,nnodes_eta
                do ixi = 1,nnodes_xi
                    nodes_(inode,1) = xi_nodes(ixi)
                    nodes_(inode,2) = eta_nodes(ieta)
                    nodes_(inode,3) = zeta_nodes(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function quadrature_nodes
    !************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/28/2017
    !!
    !------------------------------------------------------------------------
    function quadrature_weights(nterms,level,dim) result(weights)
        integer(ik),    intent(in)  :: nterms
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        ! Level for quadrature weights corresponds to the number of weights
        ! in the 1D tensor construction of the node set.
        real(rk),   allocatable, dimension(:)   :: xi_weights, eta_weights, zeta_weights, weights
        integer(ik)                             :: ixi, ieta, izeta, inode, nweights, ierr, nnodes1d, nterms1d
        integer(ik)                             :: nweights_xi, nweights_eta, nweights_zeta

        !
        ! Compute number of terms in 1D polynomial expansion
        !
        nterms1d = 0
        do while (nterms1d*nterms1d*nterms1d < nterms)
            nterms1d = nterms1d + 1
        end do

        !
        ! Compute number of nodes in quadrature set
        !
        select case (level)
            case(1)
                nnodes1d = nterms1d         ! Collocation quadrature
            case(2)
                nnodes1d = ceiling(3._rk*real(nterms1d,rk)/2._rk)
            case(3)
                nnodes1d = 2*nterms1d + 1
            case(4)
                nnodes1d = 3*nterms1d + 1
            case(5)
                nnodes1d = 5*nterms1d + 1
            case default
                call chidg_signal(FATAL, "compute_nnodes_integration: Value for gq_rule, specifying the rule for selecting number of quadrature points was not valid. Recognized values are gq_rule = (1, 2, 3)")
        end select

        !
        ! Get 1D weights
        !
        allocate(xi_weights(nnodes1d), eta_weights(nnodes1d), zeta_weights(nnodes1d), stat=ierr)
        if (ierr /= 0) call AllocationError

        select case(dim)
            case(1)
                nweights_xi   = nnodes1d
                nweights_eta  = 1
                nweights_zeta = 1
                xi_weights = gl_weights(nnodes1d)
                eta_weights  = ONE
                zeta_weights = ONE
            case(2)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = 1
                xi_weights   = gl_weights(nnodes1d)
                eta_weights  = gl_weights(nnodes1d)
                zeta_weights = ONE
            case(3)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = nnodes1d
                xi_weights   = gl_weights(nnodes1d)
                eta_weights  = gl_weights(nnodes1d)
                zeta_weights = gl_weights(nnodes1d)
            case default
                call chidg_signal_one(FATAL,"quadrature_weights: invalid dimension.",dim)
        end select

        !
        ! Allocate weights_
        !
        nweights = nweights_xi*nweights_eta*nweights_zeta
        allocate(weights(nweights), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nweights_zeta
            do ieta = 1,nweights_eta
                do ixi = 1,nweights_xi
                    weights(inode) = xi_weights(ixi)*eta_weights(ieta)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function quadrature_weights
    !************************************************************************

    !>   Compute the roots of a given Legendre polynomial. The roots are used
    !!   for the function evaluation nodes for Gauss-Legendre quadrature.
    !!
    !!   @author  Nathan A. Wukie
    !!
    !!   @param[in]  nnodes   number of Gauss-Legendre quadrature nodes requested
    !!   @param[out] nodes    Gauss-Legendre quadrature node locations
    !!
    !----------------------------------------------------------------------------------------
    function gl_nodes(nnodes) result(nodes)
        integer(ik),    intent(in)      :: nnodes

        real(rk)    :: nodes(nnodes)
        integer(ik) :: i,j,polyterm
        real(rk)    :: resid,tol,x,xnew,theta,n

        !
        ! Tolerance tested up to 10th order
        !
        !tol = 1.2e-16_rk
        tol = 1.1_rk * epsilon(1._rk)

        !
        ! compute Legendre term used to generate the correct number of nodes
        !
        polyterm = nnodes+1

        !
        ! Loop through roots so they are ordered from lowest to highest
        !
        j=1
        do i=nnodes,1,-1

            !
            ! force the condition into the loop
            !
            resid = tol + ONE

            !
            ! Use Newtons method with Chebyshev root as initial guess
            !x = cos(pi*(2._rk*real(i,rk) - 1._rk)/(2._rk*real(nnodes,rk)))
            !
            ! new initial guess, based on Lether
            ! J. Comput. Appl. Math. 4, 47 (1978)
            !
            n = real(nnodes,rk)
            theta = PI*(FOUR*real(i,rk) - ONE)/(FOUR*n + TWO)
            x = (ONE  + (n-ONE)/(EIGHT*n*n*n) - (ONE/(384._rk*n*n*n*n))*( &
                39._rk - 28._rk/(sin(theta)**(TWO))))*cos(theta)

            !
            ! Newton iteration to desired tolerance
            !
            do while (resid > tol)
                xnew = x - legendre_val1D(polyterm,x)/dlegendre_val1D(polyterm,x)
                resid = abs(xnew-x)
                x = xnew
            end do
            nodes(j) = x
            j=j+1 ! storage location for correct ordering

        end do

    end function gl_nodes
    !*****************************************************************************************

    !>  Compute the weights for Gauss-Legendre quadrature rules.
    !!
    !!  @author  Nathan A. Wukie
    !!
    !!  @param[in] nweights     number of Gauss-Legendre quadrature weights requested
    !!  @param[out] weights     quadrature weights associated with Gauss-Legendre nodes
    !!
    !-----------------------------------------------------------------------------------------
    function gl_weights(nweights) result(weights)
        integer(ik),    intent(in)    :: nweights

        real(rk)        :: nodes(nweights), weights(nweights)
        integer(ik)     :: i,polyterm
        real(rk)        :: xi,DPoly

        !
        ! Get quadrature nodes
        !
        nodes = gl_nodes(nweights)

        !
        ! compute legendre term used to generate the correct number of roots
        !
        polyterm = nweights+1

        do i=1,nweights

            ! Get quadrature node and polynomial derivative
            xi = nodes(i)
            DPoly = dlegendre_val1D(polyterm,xi)

            ! Compute weight
            weights(i) = TWO/((ONE - xi*xi)*(DPoly*DPoly))

        end do

    end function gl_weights
    !******************************************************************************************

end module mod_gauss_legendre


! ==============================================================================
! Riemann solver for the acoustics equations in 2d.
!
! waves: 3
! equations: 3
!
! Conserved quantities:
!       1 pressure
!       2 x_velocity
!       3 y_velocity
!
! Note that although there are 3 eigenvectors, the second eigenvalue
! is always zero and so we only need to compute 2 waves.
!
! solve Riemann problems along one slice of data.

! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q
!
! ==============================================================================

subroutine rpn2_ptwise(ixy, num_eqn, num_aux, num_waves, q_l, q_r,            &
                       aux_l, aux_r, wave, s, amdq, apdq)

    implicit none

    ! Input
    integer, intent(in) :: num_eqn, num_aux, num_waves, ixy
    real(kind=8), intent(in) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in) :: aux_l(num_aux), aux_r(num_aux)

    ! Output
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Locals
    integer :: normal_index, transverse_index
    real(kind=8) :: delta(3), a(2)

    ! Common block
    real(kind=8) :: rho, bulk, cc, zz
    common /cparam/ rho, bulk, cc, zz

    if (ixy == 1) then
        normal_index = 2
        transverse_index = 3
    else
        normal_index = 3
        transverse_index = 2
    end if

    ! note that notation for u and v reflects assumption that the
    ! Riemann problems are in the x-direction with u in the normal
    ! direciton and v in the orthogonal direcion, but with the above
    ! definitions of mu and mv the routine also works with ixy=2
    ! in which case waves come from the
    ! Riemann problems u_t + g(u)_y = 0 in the y-direction.

    ! Split the jump in q at each interface into waves
    delta = q_r - q_l
    ! Find coefficients for the 2 eigenvectors:
    a(1) = (-delta(1) + zz * delta(normal_index)) / (2.d0 * zz)
    a(2) = ( delta(1) + zz * delta(normal_index)) / (2.d0 * zz)

    ! Compute waves
    wave(1, 1) = -a(1) * zz
    wave(normal_index, 1) = a(1)
    wave(transverse_index, 1) = 0.d0
    s(1) = -cc

    wave(1, 2) = a(2) * zz
    wave(normal_index, 2) = a(2)
    wave(transverse_index, 2) = 0.d0
    s(2) = cc

    ! Compute the leftgoing and rightgoing flux differences:
    ! Note s(1) < 0   and   s(2) > 0.
    amdq = s(1) * wave(:, 1)
    apdq = s(2) * wave(:, 2)

end subroutine rpn2_ptwise


!
! Teukolsky field solver
!
module mod_teuk
!=============================================================================
   use mod_prec
   use mod_field, only: field, set_level
   use mod_params, only: &
      dt, nx, ny, max_l, &
      min_m, max_m, &
      spin=>psi_spin, &
      cl=>compactification_length, &
      bhm=>black_hole_mass, &
      bhs=>black_hole_spin, &
      constraint_damping, &
      constrained_evo

   use mod_cheb, only: R=>Rarr, compute_DR
   use mod_swal, only: cy=>cyarr, sy=>syarr, compute_swal_laplacian

   use mod_scd_order_source, only: scd_order_source
!=============================================================================
   implicit none
   private
   public :: teuk_init, teuk_time_step, compute_res_q

   interface teuk_time_step
      module procedure teuk_lin_time_step, teuk_scd_time_step
   end interface
!=============================================================================
   real(rp), allocatable :: &
      A_pp(:,:,:), A_pq(:,:,:)

   complex(rp), allocatable :: &
      B_pp(:,:,:), B_pq(:,:,:), B_pf(:,:,:)

   real(rp), allocatable :: prefactor_p(:,:)

   complex(rp), parameter :: ZI = (0.0_rp, 1.0_rp)
!=============================================================================
contains
!=============================================================================
   subroutine teuk_init()
      integer(ip) :: m_ang

      allocate(A_pp(nx,ny,min_m:max_m))
      allocate(A_pq(nx,ny,min_m:max_m))

      allocate(B_pp(nx,ny,min_m:max_m))
      allocate(B_pq(nx,ny,min_m:max_m))
      allocate(B_pf(nx,ny,min_m:max_m))

      allocate(prefactor_p(nx,ny))
      !----------------------------
      m_loop: do m_ang=min_m,max_m
      !----------------------------
         A_pp(:,:,m_ang) = (2.0_rp / (cl**4)) * ( &
            (cl**6) &
         +  (cl**2)*(bhs**2 - 8*(bhm**2))*(R**2) &
         +  4*(bhs**2)*bhm*(R**3) &
         )

         A_pq(:,:,m_ang) = ((R**2) / (cl**4)) * ( &
            (cl**4) &
         -  2*(cl**2)*bhm*R &
         +  (bhs**2)*(R**2) &
         )
      !----------------------------
         B_pp(:,:,m_ang) = - ( &
            2*ZI*bhs*m_ang*((cl**2) + 4*bhm*R) / (cl**2) &
         -  2*(bhs**2)*(cl**2 + 6*bhm*R)*R / (cl**4)   &
         -  4*bhm*spin &
         +  8*(bhm**2)*(2 + spin)*R / (cl**2) &
         +  2*ZI*bhs*spin*cy &
         )

         B_pq(:,:,m_ang) = (2.0_rp * R / (cl**4)) * ( &
            2*(bhs**2)*(R**2) &
         +  (1 + spin)*(cl**4)  &
         -  (ZI*bhs*m_ang + (3 + spin)*bhm) * ((cl**2) * R) &
         )

         B_pf(:,:,m_ang) = - (2.0_rp * R / (cl**4)) * ( &
            ZI*bhs*(cl**2)*m_ang &
         -  (bhs**2)*R &
         +  (cl**2)*bhm*(1 + spin) &
         )
      end do m_loop
      !------------------------------------------------------------------
      prefactor_p = 1.0_rp / ( &
         8*bhm*(2*(cl**2)*bhm - (bhs**2)*R)*((cl**2) + 2*bhm*R) / (cl**4) &
      -  (bhs*sy)**2 &
      )

      do m_ang=min_m,max_m
         A_pp(:,:,m_ang) = A_pp(:,:,m_ang) * prefactor_p
         A_pq(:,:,m_ang) = A_pq(:,:,m_ang) * prefactor_p

         B_pp(:,:,m_ang) = B_pp(:,:,m_ang) * prefactor_p
         B_pq(:,:,m_ang) = B_pq(:,:,m_ang) * prefactor_p
         B_pf(:,:,m_ang) = B_pf(:,:,m_ang) * prefactor_p
      end do
      !------------------------------------------------------------------
   end subroutine teuk_init
!=============================================================================
   subroutine set_k(step, m_ang, &
         p, q, f, &
         kp, kq, kf)

      integer(ip), intent(in) :: step, m_ang
      type(field), intent(inout) :: p, q, f
      complex(rp), dimension(nx,ny,min_m:max_m), intent(inout) :: kp, kq, kf

      call set_level(step, m_ang, p)
      call set_level(step, m_ang, q)
      call set_level(step, m_ang, f)

      call compute_DR(step, m_ang, p)
      call compute_DR(step, m_ang, q)
      call compute_DR(step, m_ang, f)

      call compute_swal_laplacian(step, m_ang, f)

      !-------------------------------------
      kp(:,:,m_ang) = &
         A_pp(:,:,m_ang) * p%DR(:,:,m_ang) &
      +  A_pq(:,:,m_ang) * q%DR(:,:,m_ang) &

      +  B_pp(:,:,m_ang) * p%level(:,:,m_ang) &
      +  B_pq(:,:,m_ang) * q%level(:,:,m_ang) &
      +  B_pf(:,:,m_ang) * f%level(:,:,m_ang) &

      +  prefactor_p     * f%swal_lap(:,:,m_ang)
      !-------------------------------------
      if (.not. constrained_evo) then
         kq(:,:,m_ang) = &
            p%DR(:,:,m_ang) &
         -  constraint_damping * (q%level(:,:,m_ang) - f%DR(:,:,m_ang))
      end if
      !-------------------------------------
      kf(:,:,m_ang) = &
         p%level(:,:,m_ang)

   end subroutine set_k
!=============================================================================
! RK4 time integrator: linear teukolsky wave
!=============================================================================
   subroutine teuk_lin_time_step(m_ang, p, q, f)
      integer(ip), intent(in)    :: m_ang
      type(field), intent(inout) :: p, q, f
   !--------------------------------------------------------
   ! if first time then k1 has not been set from k5
   !--------------------------------------------------------
      if (f%first_time) then
         call set_k(1_ip, m_ang, p, q, f, p%k1, q%k1, f%k1)

         p%first_time = .false.
         q%first_time = .false.
         f%first_time = .false.

         if (constrained_evo) then
            call compute_DR(1_ip, m_ang, f)
            q%n(:,:,m_ang) = f%DR(:,:,m_ang)
         end if
      end if

      p%l2(:,:,m_ang)= p%n(:,:,m_ang)+0.5_rp*dt*p%k1(:,:,m_ang)
      f%l2(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k1(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(2_ip, m_ang, f)
         q%l2(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l2(:,:,m_ang)= q%n(:,:,m_ang)+0.5_rp*dt*q%k1(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(2_ip, m_ang, p, q, f, p%k2, q%k2, f%k2)

      p%l3(:,:,m_ang)= p%n(:,:,m_ang)+0.5_rp*dt*p%k2(:,:,m_ang)
      f%l3(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k2(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(3_ip, m_ang, f)
         q%l3(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l3(:,:,m_ang)= q%n(:,:,m_ang)+0.5_rp*dt*q%k2(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(3_ip, m_ang, p, q, f, p%k3, q%k3, f%k3)

      p%l4(:,:,m_ang)= p%n(:,:,m_ang)+dt*p%k3(:,:,m_ang)
      f%l4(:,:,m_ang)= f%n(:,:,m_ang)+dt*f%k3(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(4_ip, m_ang, f)
         q%l4(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l4(:,:,m_ang)= q%n(:,:,m_ang)+dt*q%k3(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(4_ip, m_ang, p, q, f, p%k4, q%k4, f%k4)

      p%np1(:,:,m_ang)= p%n(:,:,m_ang) &
      +  (dt/6.0_rp)*(p%k1(:,:,m_ang)+2.0_rp*p%k2(:,:,m_ang)+2.0_rp*p%k3(:,:,m_ang)+p%k4(:,:,m_ang))

      f%np1(:,:,m_ang)= f%n(:,:,m_ang) &
      +  (dt/6.0_rp)*(f%k1(:,:,m_ang)+2.0_rp*f%k2(:,:,m_ang)+2.0_rp*f%k3(:,:,m_ang)+f%k4(:,:,m_ang))

      if (constrained_evo) then
         call compute_DR(5_ip, m_ang, f)
         q%np1(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%np1(:,:,m_ang)= q%n(:,:,m_ang) &
         +  (dt/6.0_rp)*(q%k1(:,:,m_ang)+2.0_rp*q%k2(:,:,m_ang)+2.0_rp*q%k3(:,:,m_ang)+q%k4(:,:,m_ang))
      end if
   !------------------------------------------------------------
   ! want k5 for computing source term and independent residuals
   !------------------------------------------------------------
      call set_k(5_ip, m_ang, p, q, f, p%k5, q%k5, f%k5)
   end subroutine teuk_lin_time_step
!=============================================================================
! RK4 time integrator: linear teukolsky wave with second order source term
!=============================================================================
   subroutine teuk_scd_time_step(m_ang, src, p, q, f)
      integer(ip),            intent(in)    :: m_ang
      type(scd_order_source), intent(in)    :: src
      type(field),            intent(inout) :: p, q, f
   !--------------------------------------------------------
   ! if first time then k1 has not been set from k5
   !--------------------------------------------------------
      if (f%first_time) then
         call set_k(1_ip, m_ang, p, q, f, p%k1, q%k1, f%k1)

         p%k1(:,:,m_ang) = p%k1(:,:,m_ang) + src%n(:,:,m_ang)

         p%first_time = .false.
         q%first_time = .false.
         f%first_time = .false.

         if (constrained_evo) then
            call compute_DR(1_ip, m_ang, f)
            q%n(:,:,m_ang) = f%DR(:,:,m_ang)
         end if
      end if

      p%l2(:,:,m_ang)= p%n(:,:,m_ang)+0.5_rp*dt*p%k1(:,:,m_ang)
      f%l2(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k1(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(2_ip, m_ang, f)
         q%l2(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l2(:,:,m_ang)= q%n(:,:,m_ang)+0.5_rp*dt*q%k1(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(2_ip, m_ang, p, q, f, p%k2, q%k2, f%k2)

      p%k2(:,:,m_ang) = p%k2(:,:,m_ang) + src%n1h(:,:,m_ang)

      p%l3(:,:,m_ang)= p%n(:,:,m_ang)+0.5_rp*dt*p%k2(:,:,m_ang)
      f%l3(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k2(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(3_ip, m_ang, f)
         q%l3(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l3(:,:,m_ang)= q%n(:,:,m_ang)+0.5_rp*dt*q%k2(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(3_ip, m_ang, p, q, f, p%k3, q%k3, f%k3)

      p%k3(:,:,m_ang) = p%k3(:,:,m_ang) + src%n1h(:,:,m_ang)

      p%l4(:,:,m_ang)= p%n(:,:,m_ang)+dt*p%k3(:,:,m_ang)
      f%l4(:,:,m_ang)= f%n(:,:,m_ang)+dt*f%k3(:,:,m_ang)

      if (constrained_evo) then
         call compute_DR(4_ip, m_ang, f)
         q%l4(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%l4(:,:,m_ang)= q%n(:,:,m_ang)+dt*q%k3(:,:,m_ang)
      end if
   !--------------------------------------------------------
      call set_k(4_ip, m_ang, p, q, f, p%k4, q%k4, f%k4)

      p%k4(:,:,m_ang) = p%k4(:,:,m_ang) + src%np1(:,:,m_ang)

      p%np1(:,:,m_ang)= p%n(:,:,m_ang) &
      +  (dt/6.0_rp)*(p%k1(:,:,m_ang)+2.0_rp*p%k2(:,:,m_ang)+2.0_rp*p%k3(:,:,m_ang)+p%k4(:,:,m_ang))

      f%np1(:,:,m_ang)= f%n(:,:,m_ang) &
      +  (dt/6.0_rp)*(f%k1(:,:,m_ang)+2.0_rp*f%k2(:,:,m_ang)+2.0_rp*f%k3(:,:,m_ang)+f%k4(:,:,m_ang))

      if (constrained_evo) then
         call compute_DR(5_ip, m_ang, f)
         q%np1(:,:,m_ang) = f%DR(:,:,m_ang)
      else
         q%np1(:,:,m_ang)= q%n(:,:,m_ang) &
         +  (dt/6.0_rp)*(q%k1(:,:,m_ang)+2.0_rp*q%k2(:,:,m_ang)+2.0_rp*q%k3(:,:,m_ang)+q%k4(:,:,m_ang))
      end if
   !------------------------------------------------------------
   ! want k5 for computing source term and independent residuals
   !------------------------------------------------------------
      call set_k(5_ip, m_ang, p, q, f, p%k5, q%k5, f%k5)

      p%k5(:,:,m_ang) = p%k5(:,:,m_ang) + src%np1(:,:,m_ang)

   end subroutine teuk_scd_time_step
!=============================================================================
! independent residula: q - \partial_R f
!=============================================================================
   subroutine compute_res_q(m_ang, q, f, res)
      integer(ip), intent(in)    :: m_ang
      type(field), intent(in)    :: q
      type(field), intent(inout) :: f
      type(field), intent(inout) :: res

      integer(ip), parameter :: step = 5_ip

      call compute_DR(step, m_ang, f)

      res%np1(:,:,m_ang) = f%DR(:,:,m_ang) - q%np1(:,:,m_ang)

   end subroutine compute_res_q
!=============================================================================
end module mod_teuk


!Calculates the time step to assure model stability
subroutine timestep
use Declarations
real(dp) :: dt1, &      ! Dummy time step [s]
        &   dt2, &      ! Dummy time step [s]
        &   dt3, &      ! Dummy time step [s]
        &   D_south, &  ! Diffusivity coefficient for water flow in y-direction (down) [m2/s]
        &   D_east, &   ! Diffusivity coefficient for water flow in x-direction [m2/s]
        &   D_north, &  ! Diffusivity coefficient for water flow in y-direction (up) [m2/s]
        &   uu, &       ! Convective velocity in water flow equation [m/s]
        &   C, &        ! Parameter in Richards equation
        &   thermal_diffusivity_south, & ! Diffusivity coefficient for heat equation in y-direction (down)
        &   thermal_diffusivity_north, & ! Diffusivity coefficient for heat equation in y-direction (up)
        &   thermal_diffusivity_east     ! Diffusivity coefficien
real(dp) :: Co                           ! Courant number, should be lower than 1

Dt2 = Dt_ini
dt3 = Dt_ini

if (beta .le. 0.0001) then !  flat snowpack
      do j = 1,M-1
         do i = 1,N-1
            Co = 0.01_dp

            !===================== CFL heat transfer ==================================
            thermal_diffusivity_south = k_eff_south(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            thermal_diffusivity_north = k_eff_north(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            thermal_diffusivity_east = k_eff_east(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            if (j .ne. 1 .and. i .ne. N-1  .and. j .ne. M-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) , &
                  & thermal_diffusivity_east * Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) ))
            elseif (j .eq. 1  .and. i .ne. N-1 ) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)  , &
                  & thermal_diffusivity_east * Sx_east(i,j)/ dabs(xv(i+1,j)-xv(i,j)), &
                  & thermal_diffusivity_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) ))
            elseif (j .eq. M-1  .and. i.ne. N-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_north * Sy_north(i,j)/ (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                  & thermal_diffusivity_east * Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)), &
                  & thermal_diffusivity_south * Sy_south(i,j)/ dabs(yv(i,j)-yv(i,j-1))))
            elseif (j .ne. 1 .and. i .eq. N-1  .and. j .ne. M-1) then
               dt3 = Co * Vol(i,j) *0.5_dp / (thermal_diffusivity_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)))
            elseif (j .eq. 1  .and. i.eq. N-1 ) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp), &
                 & thermal_diffusivity_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) ))
            elseif (j .eq. M-1  .and. i .eq. N-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_north * Sy_north(i,j)/ (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                 & thermal_diffusivity_south * Sy_south(i,j)/ dabs(yv(i,j)-yv(i,j-1))) )
            endif

            !======================= CFL water flow ========================================

           if (S(i,j) .gt. 0.) then
               uu = (2.0_dp * Ks(i,j) * ((1.0_dp-S(i,j)**(1.0_dp/mm(i,j)))**mm(i,j) - 1.0_dp) * (1.0_dp-S(i,j)** &
                  & (1.0_dp/mm(i,j)))**(mm(i,j)-1.0_dp) * S(i,j)**0.5_dp * S(i,j)**(1.0_dp/mm(i,j)-1.0_dp)) / &
                  & (irreducible-porosity(i,j)) - (Ks(i,j) * ((1.0_dp-S(i,j)**(1.0_dp/mm(i,j)))**mm(i,j) - 1.0_dp)**2.0_dp) / &
                  & (2.0_dp*(irreducible-porosity(i,j)) * S(i,j)**0.5_dp)
            else
               uu = 0._dp
            endif

            if (wrc(i,j) .eq. 1 .or. wrc(i,j) .eq. 4 ) then
               C = (porosity(i,j)-irreducible) * alpha_wetting(i,j)**nn(i,j) * nn(i,j) * mm(i,j) * dabs(P(i,j))** &
                  &   (nn(i,j)-1.0_dp) * (1.0_dp + dabs(alpha_wetting(i,j)*P(i,j))**nn(i,j))**(-mm(i,j) - 1.0_dp)
            else
               C = (porosity(i,j)-irreducible) * alpha(i,j)**nn(i,j) * nn(i,j) * mm(i,j) * dabs(P(i,j))** &
                  & (nn(i,j)-1.0_dp) * (1.0_dp + dabs(alpha(i,j)*P(i,j))**nn(i,j))**(-mm(i,j) - 1.0_dp)
            endif

            D_south = K_south(i,j) / C ! grid Fourier number El-Kadi and Ling, 1993
            D_east =  K_east(i,j) / C ! grid Fourier number El-Kadi and Ling, 1993
            D_north = K_north(i,j) / C ! grid Fourier number El-Kabi and Ling, 1993

            if (j .ne. 1 .and. j .ne. M-1) then
               if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) , &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)) , &
                     & uu * Sy_south(i,j) *0.5_dp ))
               else
                  dt1 = Co * Vol(i,j) *0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) , &
                     & uu * Sy_south(i,j) * 0.5_dp))
               endif
            elseif (j .eq. 1) then
               if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)) , &
                     & uu * Sy_south(i,j) * 0.5_dp, D_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) ))
               else
                  dt1 = Co * Vol(i,j) *0.5_dp / (max(D_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                     & uu * Sy_south(i,j) * 0.5_dp , D_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j))))
               endif
            elseif (j .eq. M-1) then
              if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) , &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)) , &
                     & uu * Sy_south(i,j) * 0.5_dp, D_north * Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)))
              else
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_north * Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                     & uu * Sy_south(i,j) * 0.5_dp, D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1))))
              endif
            endif
              Dt2 = min(+Dt2,+dt1,+dt3)

          enddo
      enddo

else ! ==================== BETA .gt. 0 =======================================

      do j = 1,M-1
         do i = 1,N-1

             Co = 0.9_dp

            !===================== CFL heat transfer ==================================
            thermal_diffusivity_south = k_eff_south(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            thermal_diffusivity_north = k_eff_north(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            thermal_diffusivity_east = k_eff_east(i,j) / (rho_i*Cpi*(1.0_dp-porosity(i,j)) + &
               & water_content(i,j,1)*rho_w*Cpw + &
               & rho_a*Cpa*(porosity(i,j)-water_content(i,j,1)))

            if (j .ne. 1 .and. i .ne. N-1  .and. j .ne. M-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) , &
                  & thermal_diffusivity_east * Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) ))
            elseif (j .eq. 1  .and. i .ne. N-1 ) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                  & thermal_diffusivity_east * Sx_east(i,j)/ dabs(xv(i+1,j)-xv(i,j)) , &
                  & thermal_diffusivity_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) ))
            elseif (j .eq. M-1  .and. i.ne. N-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_north * Sy_north(i,j)/ (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                  & thermal_diffusivity_east * Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)), &
                  &  thermal_diffusivity_south * Sy_south(i,j)/ dabs(yv(i,j)-yv(i,j-1))))
            elseif (j.ne. 1 .and. i.eq. N-1  .and. j.ne.M-1) then
               dt3 = Co * Vol(i,j) *0.5_dp / (thermal_diffusivity_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)))
            elseif (j .eq. 1  .and. i.eq. N-1 ) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp), &
                  & thermal_diffusivity_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j))))
            elseif (j .eq. M-1  .and. i .eq. N-1) then
               dt3 = Co * Vol(i,j) * 0.5_dp / (max(thermal_diffusivity_north * Sy_north(i,j)/ (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                  & thermal_diffusivity_south * Sy_south(i,j)/ dabs(yv(i,j)-yv(i,j-1))))
            endif

            !======================= CFL water flow ========================================

            if (S(i,j) .gt. 0.) then
               uu = (2.0_dp * Ks(i,j) * ((1.0_dp-S(i,j)**(1.0_dp/mm(i,j)))**mm(i,j) - 1.0_dp) * (1.0_dp-S(i,j)** &
                  & (1.0_dp/mm(i,j)))**(mm(i,j)-1.0_dp) * S(i,j)**0.5_dp * S(i,j)**(1.0_dp/mm(i,j)-1.0_dp)) / &
                  & (irreducible-porosity(i,j)) - (Ks(i,j) * ((1.0_dp-S(i,j)**(1.0_dp/mm(i,j)))**mm(i,j) - 1.0_dp)**2.0_dp) / &
                  & (2.0_dp*(irreducible-porosity(i,j)) * S(i,j)**0.5_dp)
            else    !S(i,j)=1e-6 is used to avoid model divergence
               uu = 0._dp
            endif

            if (wrc(i,j) .eq. 1 .or. wrc(i,j) .eq. 4) then
               C = (porosity(i,j)-irreducible) * 2._dp * alpha(i,j)**nn(i,j) * nn(i,j) * mm(i,j) * dabs(P(i,j))** &
                  &   (nn(i,j)-1.0_dp) * (1.0_dp + dabs(2._dp * alpha(i,j)*P(i,j))**nn(i,j))**(-mm(i,j) - 1.0_dp)
            else
               C = (porosity(i,j)-irreducible) * alpha(i,j)**nn(i,j) * nn(i,j) * mm(i,j) * dabs(P(i,j))** &
                  & (nn(i,j)-1.0_dp) * (1.0_dp + dabs(alpha(i,j)*P(i,j))**nn(i,j))**(-mm(i,j) - 1.0_dp)
            endif
            D_south = K_south(i,j) / C ! grid Fourier number El-Kadi and Ling, 1993
            D_east =  K_east(i,j) / C ! grid Fourier number El-Kadi and Ling, 1993
            D_north = K_north(i,j) / C ! grid Fourier number El-Kabi and Ling, 1993

            if (j .ne. 1 .and. j .ne. M-1) then
               if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)), &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)), &
                     & uu * Sy_south(i,j) *0.5_dp ))
               else
                  dt1 = Co * Vol(i,j) *0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)), &
                     & uu * Sy_south(i,j) * 0.5_dp))
               endif
            elseif (j .eq. 1) then
              if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp), &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)), &
                     & uu * Sy_south(i,j) * 0.5_dp , &
                     & D_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j))))
              else
                  dt1 = Co * Vol(i,j) *0.5_dp / (max(D_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) , &
                     & uu * Sy_south(i,j) * 0.5_dp , &
                     & D_north * Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) ))
              endif
            elseif (j .eq. M-1) then
              if (i .lt. N-1) then
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_south * Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)), &
                     & D_east * Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)), &
                     & uu * Sy_south(i,j) * 0.5_dp, &
                     &  D_north * Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)))
              else
                  dt1 = Co * Vol(i,j) * 0.5_dp / (max(D_north * Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp), &
                     & uu * Sy_south(i,j) * 0.5_dp, &
                     & D_south * Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)) )
              endif
            endif

              Dt2 = min(+Dt2,+dt1,+dt3)

          enddo
      enddo

endif

Dt = Dt2
Dt = max(Dt, 1e-3_dp)

RETURN
end


	FUNCTION PR_PSPD  ( drct, sped )
C************************************************************************
C* PR_PSPD								*
C*									*
C* This function computes PSPD from DRCT and SPED.  PSPD is in the	*
C* form DDFFF, where DD is the wind direction in tens of degrees,	*
C* and FFF is either the wind speed or wind speed plus 500, 		*
C* depending on the unit digit of direction rounded to the nearest	*
C* 5 degrees.  The following equation is used:				*
C*									*
C*          PSPD  =  JDRCT * 500 + JSPED				*
C*                JDRCT = NINT ( DRCT / 5 )				*
C*                JSPED = NINT ( SPED )					*
C*									*
C* REAL PR_PSPD  ( DRCT, SPED )						*
C*									*
C* Input parameters:							*
C*	DRCT		REAL		Wind direction in degrees	*
C*	SPED		REAL		Wind speed 			*
C*									*
C* Output parameters:							*
C*	PR_PSPD		REAL		Packed speed and direction	*
C**									*
C* Log:									*
C* D. Frey/CSC		 9/82	Original source code			*
C* I. Graffman/RDS	11/84	Corrected speed variable names		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 7/88	Documentation,	correct rounding	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ( .not. ERMISS ( drct ) ) .and.
     +	      ( .not. ERMISS ( sped ) ) )  THEN
	   jdrct   = NINT ( drct / 5. )
	   jsped   = NINT ( sped )
	   PR_PSPD = jdrct * 500 + jsped
	ELSE
	   PR_PSPD = RMISSD
	END IF
C*
	RETURN
	END


      real             function SPPNML (U, MU, SIGMA)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SPPNML Krogh  Moved external statement up for mangle.
c>> 1994-10-20 SPPNML Krogh  Changes to use M77CON
c>> 1994-08-05 SPPNML WV Snyder
c
c     Compute the Percentage Point of the Normal (Gaussian) Probability
c     Distribution, g**(-1) (u;mu,sigma).  This is given in terms of the
c     inverse of the co-error function, erfci, by x = mu -
c     sigma * sqrt(2) * erfci(2*u).
c
      real             U, MU, SIGMA
c--S replaces "?": ?PPNML, ?ERFCI
      external SERFCI
      real             SQRT2, SERFCI
      parameter (SQRT2 = 1.414213562373095048801688724209698078569672e0)
c
      sppnml = mu - sigma * sqrt2 * serfci(u+u)
      return
      end


PROGRAM A4Q2
!--
!	Finds the number of non-negative number groups ('blobs') in the given 2D array.
!--
IMPLICIT NONE
INTEGER, DIMENSION(:,:), ALLOCATABLE :: A
INTEGER :: m, n, check
INTEGER :: i,j, bs

PRINT *, "Finds the number of non-negative number groups ('blobs') in the given 2D array."
DO
	PRINT *, 'Enter the dimensions m, n of the array. (enter a 0 for either value to stop)'
    READ *, m, n
    IF (m .eq. 0 .or. n .eq. 0) STOP
    ALLOCATE(A(m,n), STAT=check)
    IF (check .ne. 0) THEN
      	PRINT "(1X, 'Allocation unseccessful for an array of size:', I3, I3)", m, n
    ELSE
		PRINT "(1X, 'Enter the values for the array A with dimenstions: ', I3, I3)", m, n
        READ *, ((A(i, j),i=1,m),j=1,n)
		DO i = 1,m
			PRINT "(5X, 15I5)", A(i, 1:n)
        END DO
        PRINT "(1X, I5, ' blobs for the Array:' )", CountBlobs(A, m, n)
        DO i = 1,m
			PRINT "(5X, 15I5)", A(i, 1:n)
        END DO
		DEALLOCATE(A)
    END IF
END DO

CONTAINS
!-- Determine the # of 'blobs' in A
INTEGER FUNCTION CountBlobs(A, m, n)
	INTEGER, DIMENSION(1:m, 1:n), INTENT(INOUT) :: A
	INTEGER, INTENT(IN) :: m, n
    INTEGER :: c, i, j, p

    c = 0
	DO WHILE (ContainsPos(A, m, n))
		DO i = 1,m
			DO j = 1,n
            	IF (A(i, j) .gt. 0) THEN
                	! We've found a blob, lets see how big it is...
                	c = c + 1
                    A(i, j) = -c
                    CALL FollowBlob(A, m, n, c)
                END IF
            END DO
        END DO
    END WHILE
	CountBlobs = c

END FUNCTION CountBlobs
!-- Switch as many adjacent non-negative positive numbers as possible
SUBROUTINE FollowBlob(A, m, n, c)
	INTEGER, DIMENSION(1:m, 1:n), INTENT(INOUT) :: A
    INTEGER, INTENT(IN) :: m, n, c
    INTEGER :: p, q

    DO p = 1,m
      	DO q = 1,n
        	IF (A(p, q) .eq. -c)THEN
  				IF (p+1 .le. m .and. A(p+1, q) .gt. 0) THEN
                	A(p+1, q) = -c
                END IF
                IF (p-1 .gt. 0 .and. A(p-1, q) .gt. 0) THEN
                  	A(p-1, q) = -c
                END IF
                IF (q+1 .le. n .and. A(p, q+1) .gt. 0) THEN
                  	A(p, q+1) = -c
                END IF
                IF (q-1 .gt. 0 .and. A(p, q-1) .gt. 0) THEN
                  	A(p, q-1) = -c
                END IF
			END IF
        END DO
    END DO

END SUBROUTINE FollowBlob
!-- Does the array A still have positive numbers?
LOGICAL FUNCTION ContainsPos(A, m, n)
	INTEGER, DIMENSION(1:m, 1:n), INTENT(IN) :: A
	INTEGER, INTENT(IN) :: m, n
    INTEGER :: i, j
    LOGICAL :: found

    found = .false.
    DO i = 1,m
      	DO j = 1,n
			if (A(i,j) .gt. 0) THEN
            	found = .true.
            END IF
        END DO
    END DO
    ContainsPos = found

END FUNCTION ContainsPos
END PROGRAM A4Q2