subroutine downsize_mask(X, Y)
    use, intrinsic :: iso_c_binding
    implicit none

    logical(kind=c_bool), dimension(:, :), intent(in) :: X
    logical(kind=c_bool), dimension(:, :), intent(out) :: Y
    integer, dimension(2) :: src, dst
    integer :: src_width, src_height
    integer :: dst_width, dst_height
    integer :: i, j

    ! timing
    real :: t1, t2

    call cpu_time(t1)

    src = shape(X)
    src_width = src(1)
    src_height = src(2)

    dst = shape(Y)
    dst_width = dst(1)
    dst_height = dst(2)

    do concurrent(j=1:dst_height, i=1:dst_width)
        Y(i, j) = X(1 + (i - 1)*(src_width - 1)/(dst_width - 1), 1 + (j - 1)*(src_height - 1)/(dst_height - 1))
    end do

    call cpu_time(t2)

    print *, '[downsize_mask] SRC:', src, 'DST:', dst, 'elapsed:', 1000*(t2 - t1), '[ms]'

end subroutine downsize_mask

subroutine downsize_nn(X, Y)
    use, intrinsic :: iso_c_binding
    implicit none

    real(kind=c_float), dimension(:, :), intent(in) :: X
    real(kind=c_float), dimension(:, :), intent(out) :: Y
    integer, dimension(2) :: src, dst
    integer :: src_width, src_height
    integer :: dst_width, dst_height
    integer :: i, j

    ! timing
    real :: t1, t2

    call cpu_time(t1)

    src = shape(X)
    src_width = src(1)
    src_height = src(2)

    dst = shape(Y)
    dst_width = dst(1)
    dst_height = dst(2)

    do concurrent(j=1:dst_height, i=1:dst_width)
        Y(i, j) = X(1 + (i - 1)*(src_width - 1)/(dst_width - 1), 1 + (j - 1)*(src_height - 1)/(dst_height - 1))
    end do

    call cpu_time(t2)

    print *, '[downsize_nn] SRC:', src, 'DST:', dst, 'elapsed:', 1000*(t2 - t1), '[ms]'

end subroutine downsize_nn

subroutine downsize_linear(X, Y)
    use, intrinsic :: iso_c_binding
    implicit none

    ! the input array
    real(kind=c_float), dimension(:, :), intent(in) :: X

    ! the output (downsized) array
    real(kind=c_float), dimension(:, :), intent(out) :: Y

    ! a working array to handle image boundaries
    real(kind=c_float), dimension(:, :), allocatable :: W

    integer, dimension(2) :: src, dst
    integer :: src_width, src_height
    integer :: dst_width, dst_height

    ! source coordinates
    real :: Xs, Ys

    ! downsized destination coordinates
    integer :: Xd, Yd

    ! nearby-pixels
    real :: Xs0, Ys0, Xs1, Ys1

    ! interpolated values
    real :: I0, I1

    ! timing
    real :: t1, t2

    call cpu_time(t1)

    src = shape(X)
    src_width = src(1)
    src_height = src(2)

    dst = shape(Y)
    dst_width = dst(1)
    dst_height = dst(2)

    allocate (W(src_width + 1, src_height + 1))

    ! copy the image
    W(1:src_width, 1:src_height) = X

    ! then add the boundaries
    ! (Fourier transform origin, use reflection)
    W(src_width + 1, :) = X(1, :)
    W(:, src_height + 1) = X(:, 1)

    do concurrent(Yd=1:dst_height, Xd=1:dst_width)
        Xs = 1 + real(Xd - 1)*real(src_width - 1)/real(dst_width - 1)
        Ys = 1 + real(Yd - 1)*real(src_height - 1)/real(dst_height - 1)

        Xs0 = nint(Xs)
        Ys0 = nint(Ys)

        Xs1 = Xs0 + 1
        Ys1 = Ys0 + 1

        I0 = W(int(Xs0), int(Ys0))*(Xs1 - Xs) + W(int(Xs1), int(Ys0))*(Xs - Xs0)
        I1 = W(int(Xs0), int(Ys1))*(Xs1 - Xs) + W(int(Xs1), int(Ys1))*(Xs - Xs0)

        ! Linear Interpolation
        Y(Xd, Yd) = I0*(Ys1 - Ys) + I1*(Ys - Ys0)
    end do

    call cpu_time(t2)

    print *, '[downsize_linear] SRC:', src, 'DST:', dst, 'elapsed:', 1000*(t2 - t1), '[ms]'

end subroutine downsize_linear

elemental function Lanczos2(x)
    real :: Lanczos2
    real, intent(in) :: x
    real arg, sinc1, sinc2

    if (abs(x) .lt. 2) then
        arg = PI*x
        sinc1 = sin(arg)/arg
        sinc2 = sin(arg/2)/(arg/2)

        Lanczos2 = sinc1*sinc2
    else
        Lanczos2 = 0.0
    end if
end function Lanczos2

elemental function Lanczos3(x)
    real :: Lanczos3
    real, intent(in) :: x
    real arg, sinc1, sinc2

    if (abs(x) .lt. 3) then
        arg = PI*x
        sinc1 = sin(arg)/arg
        sinc2 = sin(arg/3)/(arg/3)

        Lanczos3 = sinc1*sinc2
    else
        Lanczos3 = 0.0
    end if
end function Lanczos3

subroutine downsize_lanczos_2(X, Y)
    use, intrinsic :: iso_c_binding
    implicit none

    ! the input array
    real(kind=c_float), dimension(:, :), intent(in) :: X

    ! the output (downsized) array
    real(kind=c_float), dimension(:, :), intent(out) :: Y

    ! a working array to handle image boundaries
    real(kind=c_float), dimension(:, :), allocatable :: W

    integer, dimension(2) :: src, dst
    integer :: src_width, src_height
    integer :: dst_width, dst_height

    ! source coordinates
    real :: Xs, Ys

    ! downsized destination coordinates
    integer :: Xd, Yd

    ! nearby-pixels
    real :: Xs0, Ys0, Xs1, Ys1, Xs2, Ys2, Xs3, Ys3

    ! interpolated values
    real :: I0, I1, I2, I3
    real :: a0, a1, a2, a3
    real :: b0, b1, b2, b3

    ! timing
    real :: t1, t2

    call cpu_time(t1)

    src = shape(X)
    src_width = src(1)
    src_height = src(2)

    dst = shape(Y)
    dst_width = dst(1)
    dst_height = dst(2)

    allocate (W(0:src_width + 2, 0:src_height + 2))

    ! copy the image
    W(1:src_width, 1:src_height) = X

    ! then add the boundaries
    ! (Fourier transform origin, use reflection)
    W(0, :) = X(src_width, :)
    W(src_width + 1, :) = X(1, :)
    W(src_width + 2, :) = X(2, :)

    W(:, 0) = X(:, src_height)
    W(:, src_height + 1) = X(:, 1)
    W(:, src_height + 2) = X(:, 2)

    ! the corners are not handled, we should be using the IPP

    do concurrent(Yd=1:dst_height, Xd=1:dst_width)

        Xs = 1 + real(Xd - 1)*real(src_width - 1)/real(dst_width - 1)
        Ys = 1 + real(Yd - 1)*real(src_height - 1)/real(dst_height - 1)

        Xs0 = nint(Xs) - 1
        Ys0 = nint(Ys) - 1

        Xs1 = Xs0 + 1
        Ys1 = Ys0 + 1

        Xs2 = Xs0 + 2
        Ys2 = Ys0 + 2

        Xs3 = Xs0 + 3
        Ys3 = Ys0 + 3

        ! Lanczos coefficients
        ! they should really be pre-calculated outside the loop
        a0 = Lanczos2(Xs - Xs0)
        a1 = Lanczos2(Xs - Xs1)
        a2 = Lanczos2(Xs - Xs2)
        a3 = Lanczos2(Xs - Xs3)

        b0 = Lanczos2(Ys - Ys0)
        b1 = Lanczos2(Ys - Ys1)
        b2 = Lanczos2(Ys - Ys2)
        b3 = Lanczos2(Ys - Ys3)

        ! intermediate intensities
        I0 = a0*W(int(Xs0), int(Ys0)) + &
             a1*W(int(Xs1), int(Ys0)) + &
             a2*W(int(Xs2), int(Ys0)) + &
             a3*W(int(Xs3), int(Ys0))

        I1 = a0*W(int(Xs0), int(Ys1)) + &
             a1*W(int(Xs1), int(Ys1)) + &
             a2*W(int(Xs2), int(Ys1)) + &
             a3*W(int(Xs3), int(Ys1))

        I2 = a0*W(int(Xs0), int(Ys2)) + &
             a1*W(int(Xs1), int(Ys2)) + &
             a2*W(int(Xs2), int(Ys2)) + &
             a3*W(int(Xs3), int(Ys2))

        I3 = a0*W(int(Xs0), int(Ys3)) + &
             a1*W(int(Xs1), int(Ys3)) + &
             a2*W(int(Xs2), int(Ys3)) + &
             a3*W(int(Xs3), int(Ys3))

        ! 2-lobed Lanczos
        Y(Xd, Yd) = b0*I0 + b1*I1 + b2*I2 + b3*I3

    end do

    call cpu_time(t2)

    print *, '[downsize_lanczos_2] SRC:', src, 'DST:', dst, 'elapsed:', 1000*(t2 - t1), '[ms]'

end subroutine downsize_lanczos_2

subroutine downsize_lanczos_3(X, Y)
    use, intrinsic :: iso_c_binding
    implicit none

    ! the input array
    real(kind=c_float), dimension(:, :), intent(in) :: X

    ! the output (downsized) array
    real(kind=c_float), dimension(:, :), intent(out) :: Y

    ! a working array to handle image boundaries
    real(kind=c_float), dimension(:, :), allocatable :: W

    integer, dimension(2) :: src, dst
    integer :: src_width, src_height
    integer :: dst_width, dst_height

    ! source coordinates
    real :: Xs, Ys

    ! downsized destination coordinates
    integer :: Xd, Yd

    ! nearby-pixels
    real :: Xs0, Ys0, Xs1, Ys1, Xs2, Ys2, Xs3, Ys3, Xs4, Ys4, Xs5, Ys5

    ! interpolated values
    real :: I0, I1, I2, I3, I4, I5
    real :: a0, a1, a2, a3, a4, a5
    real :: b0, b1, b2, b3, b4, b5

    ! timing
    real :: t1, t2

    call cpu_time(t1)

    src = shape(X)
    src_width = src(1)
    src_height = src(2)

    dst = shape(Y)
    dst_width = dst(1)
    dst_height = dst(2)

    allocate (W(-5:src_width + 6, -5:src_height + 6))

    ! copy the image
    W(1:src_width, 1:src_height) = X

    ! then replicate the borders
    W(-5, :) = X(1, :)
    W(-4, :) = X(1, :)
    W(-3, :) = X(1, :)
    W(-2, :) = X(1, :)
    W(-1, :) = X(1, :)
    W(0, :) = X(1, :)
    W(src_width + 1, :) = X(src_width, :)
    W(src_width + 2, :) = X(src_width, :)
    W(src_width + 3, :) = X(src_width, :)
    W(src_width + 4, :) = X(src_width, :)
    W(src_width + 5, :) = X(src_width, :)
    W(src_width + 6, :) = X(src_width, :)

    W(:, -5) = X(:, 1)
    W(:, -4) = X(:, 1)
    W(:, -3) = X(:, 1)
    W(:, -2) = X(:, 1)
    W(:, -1) = X(:, 1)
    W(:, 0) = X(:, 1)
    W(:, src_height + 1) = X(:, src_height)
    W(:, src_height + 2) = X(:, src_height)
    W(:, src_height + 3) = X(:, src_height)
    W(:, src_height + 4) = X(:, src_height)
    W(:, src_height + 5) = X(:, src_height)
    W(:, src_height + 6) = X(:, src_height)

    ! the corners are not handled, we should be using the IPP

    do concurrent(Yd=1:dst_height, Xd=1:dst_width)

        Xs = 1 + real(Xd - 1)*real(src_width - 1)/real(dst_width - 1)
        Ys = 1 + real(Yd - 1)*real(src_height - 1)/real(dst_height - 1)

        Xs0 = nint(Xs) - 2
        Ys0 = nint(Ys) - 2

        Xs1 = Xs0 + 1
        Ys1 = Ys0 + 1

        Xs2 = Xs0 + 2
        Ys2 = Ys0 + 2

        Xs3 = Xs0 + 3
        Ys3 = Ys0 + 3

        Xs4 = Xs0 + 4
        Ys4 = Ys0 + 4

        Xs5 = Xs0 + 5
        Ys5 = Ys0 + 5

        ! Lanczos coefficients
        ! they should really be pre-calculated outside the loop
        a0 = Lanczos2(Xs - Xs0)
        a1 = Lanczos2(Xs - Xs1)
        a2 = Lanczos2(Xs - Xs2)
        a3 = Lanczos2(Xs - Xs3)
        a4 = Lanczos2(Xs - Xs4)
        a5 = Lanczos2(Xs - Xs5)

        b0 = Lanczos2(Ys - Ys0)
        b1 = Lanczos2(Ys - Ys1)
        b2 = Lanczos2(Ys - Ys2)
        b3 = Lanczos2(Ys - Ys3)
        b4 = Lanczos2(Ys - Ys4)
        b5 = Lanczos2(Ys - Ys5)

        ! intermediate intensities
        I0 = a0*W(int(Xs0), int(Ys0)) + &
             a1*W(int(Xs1), int(Ys0)) + &
             a2*W(int(Xs2), int(Ys0)) + &
             a3*W(int(Xs3), int(Ys0)) + &
             a4*W(int(Xs4), int(Ys0)) + &
             a5*W(int(Xs5), int(Ys0))

        I1 = a0*W(int(Xs0), int(Ys1)) + &
             a1*W(int(Xs1), int(Ys1)) + &
             a2*W(int(Xs2), int(Ys1)) + &
             a3*W(int(Xs3), int(Ys1)) + &
             a4*W(int(Xs4), int(Ys1)) + &
             a5*W(int(Xs5), int(Ys1))

        I2 = a0*W(int(Xs0), int(Ys2)) + &
             a1*W(int(Xs1), int(Ys2)) + &
             a2*W(int(Xs2), int(Ys2)) + &
             a3*W(int(Xs3), int(Ys2)) + &
             a4*W(int(Xs4), int(Ys2)) + &
             a5*W(int(Xs5), int(Ys2))

        I3 = a0*W(int(Xs0), int(Ys3)) + &
             a1*W(int(Xs1), int(Ys3)) + &
             a2*W(int(Xs2), int(Ys3)) + &
             a3*W(int(Xs3), int(Ys3)) + &
             a4*W(int(Xs4), int(Ys3)) + &
             a5*W(int(Xs5), int(Ys3))

        I4 = a0*W(int(Xs0), int(Ys4)) + &
             a1*W(int(Xs1), int(Ys4)) + &
             a2*W(int(Xs2), int(Ys4)) + &
             a3*W(int(Xs3), int(Ys4)) + &
             a4*W(int(Xs4), int(Ys4)) + &
             a5*W(int(Xs5), int(Ys4))

        I5 = a0*W(int(Xs0), int(Ys5)) + &
             a1*W(int(Xs1), int(Ys5)) + &
             a2*W(int(Xs2), int(Ys5)) + &
             a3*W(int(Xs3), int(Ys5)) + &
             a4*W(int(Xs4), int(Ys5)) + &
             a5*W(int(Xs5), int(Ys5))

        ! 3-lobed Lanczos
        Y(Xd, Yd) = b0*I0 + b1*I1 + b2*I2 + b3*I3 + b4*I4 + b5*I5

    end do

    call cpu_time(t2)

    print *, '[downsize_lanczos_3] SRC:', src, 'DST:', dst, 'elapsed:', 1000*(t2 - t1), '[ms]'

end subroutine downsize_lanczos_3

subroutine to_json(str_val)
    use json_module
    implicit NONE

    CHARACTER(kind=json_CK, len=:), allocatable, intent(out) :: str_val

    type(json_core) :: json
    type(json_value), pointer :: p

    ! initialize the class
    call json%initialize(non_normal_mode=2)

    ! initialize the structure:
    call json%create_object(p, '')

    ! FITS HEADER
    ! call json%add(p, 'HEADER', char(item%hdr))
    call json%add(p, 'HEADER', 'N/A')

    ! misc. values
    call json%add(p, 'width', item%naxes(1))
    call json%add(p, 'height', item%naxes(2))
    call json%add(p, 'depth', item%naxes(3))
    call json%add(p, 'polarisation', item%naxes(4))
    call json%add(p, 'filesize', 0)
    call json%add(p, 'IGNRVAL', item%ignrval)

    call json%add(p, 'CD1_1', item%cd1_1)
    call json%add(p, 'CD1_2', item%cd1_2)
    call json%add(p, 'CD2_1', item%cd2_1)
    call json%add(p, 'CD2_2', item%cd2_2)

    call json%add(p, 'CRVAL1', item%crval1)
    call json%add(p, 'CDELT1', item%cdelt1)
    call json%add(p, 'CRPIX1', item%crpix1)
    call json%add(p, 'CUNIT1', trim(item%cunit1))
    call json%add(p, 'CTYPE1', trim(item%ctype1))

    call json%add(p, 'CRVAL2', item%crval2)
    call json%add(p, 'CDELT2', item%cdelt2)
    call json%add(p, 'CRPIX2', item%crpix2)
    call json%add(p, 'CUNIT2', trim(item%cunit2))
    call json%add(p, 'CTYPE2', trim(item%ctype2))

    call json%add(p, 'CRVAL3', item%crval3)
    call json%add(p, 'CDELT3', item%cdelt3)
    call json%add(p, 'CRPIX3', item%crpix3)
    call json%add(p, 'CUNIT3', trim(item%cunit3))
    call json%add(p, 'CTYPE3', trim(item%ctype3))

    call json%add(p, 'BMAJ', item%bmaj)
    call json%add(p, 'BMIN', item%bmin)
    call json%add(p, 'BPA', item%bpa)

    call json%add(p, 'BUNIT', trim(item%bunit))
    call json%add(p, 'BTYPE', trim(item%btype))
    call json%add(p, 'SPECSYS', trim(item%specsys))

    call json%add(p, 'RESTFRQ', item%restfrq)
    call json%add(p, 'OBSRA', item%obsra)
    call json%add(p, 'OBSDEC', item%obsdec)

    call json%add(p, 'OBJECT', trim(item%object))
    call json%add(p, 'DATEOBS', trim(item%date_obs))
    call json%add(p, 'TIMESYS', trim(item%timesys))
    call json%add(p, 'LINE', trim(item%line))
    call json%add(p, 'FILTER', trim(item%filter))

    call json%add(p, 'mean_spectrum', item%mean_spectrum)
    call json%add(p, 'integrated_spectrum', item%integrated_spectrum)

    ! statistics (image histogram)
    call json%add(p, 'histogram', item%hist)

    ! print out JSON
    ! call json%print(p)

    ! write the file:
    ! call json%print(p, char(item%datasetid)//'.json')

    ! serialize to string prior to further handling
    call json%serialize(p, str_val)

    ! cleanup:
    call json%destroy(p)

    if (json%failed()) stop 1

end subroutine to_json

function extract_datasetid_old(filename) result(datasetid)
    use iso_varying_string
    implicit none

    character(len=*), intent(in) :: filename
    type(varying_string) :: datasetid
    type(varying_string) :: letter
    integer :: i, str_len
    character :: c

    print *, 'extract_datasetid#1'

    datasetid = ''

    print *, 'extract_datasetid#2'

    ! work from the end, processing characters one by one
    ! exit upon encountering the first '/'
    str_len = len(filename)

    print *, 'extract_datasetid#3, len = ', str_len

    do i = str_len, 1, -1
        c = filename(i:i)

        if (c .eq. ' ') cycle

        if (c .eq. '/') exit

        print *, 'extract_datasetid#i=', i, 'BEFORE'
        ! prepend the element to tmp
        letter = c
        ! datasetid = letter//datasetid
        letter = insert(c, 1, datasetid)
        print *, 'extract_datasetid#i=', i, 'AFTER'
    end do

    print *, 'extract_datasetid#4'

    ! get rid of FITS file extensions
    ! should be able to handle .fits.gz etc... too

    ! lowercase, ignore starting positions .eq. 1
    i = index(datasetid, '.fits')
    if (i .gt. 1) datasetid = extract(datasetid, 1, i - 1)

    ! uppercase, ignore starting positions .eq. 1
    i = index(datasetid, '.FITS')
    if (i .gt. 1) datasetid = extract(datasetid, 1, i - 1)

end function extract_datasetid_old

!======================================================================
!    IDX$HASH
! Author:
! Alan Miller, Retired Scientist (Statistician)
! CSIRO Mathematical & Information Sciences
! Alan.Miller -at- vic.cmis.csiro.au
! http://www.ozemail.com.au/~milleraj
!======================================================================
FUNCTION hash(text) RESULT(hashed)
    IMPLICIT NONE
    CHARACTER(LEN=*), INTENT(IN) :: text
    INTEGER                       :: hashed     ! 32-bit integers assumed

    INTEGER, PARAMETER :: magic_numb = Z'5D7A9F43'
    INTEGER            :: i, j

    hashed = 0                              ! Note: B was not initialized before
    DO i = 1, LEN_TRIM(text)
        j = MOD(i - 1, 4)*8
        hashed = IEOR(hashed, ISHFT(ICHAR(text(i:i)), j))
    END DO

    hashed = ABS(IEOR(hashed, magic_numb))    ! Why take the absolute value?

    RETURN
END FUNCTION hash

use :: zmq

! ØMQ
! integer :: rc
! type(c_ptr)     :: server_context, client_context
! type(c_ptr)     :: server_socket, client_socket

subroutine recv_command(socket)
    type(c_ptr), intent(inout) :: socket
    character(kind=c_char, len=:), pointer :: buffer
    integer                                :: nbytes
    integer                                :: rc
    type(c_ptr)                            :: data
    type(zmq_msg_t)                        :: message

    rc = zmq_msg_init(message)

    ! print *, this_image(), 'zmq_msg_init::rc', rc

    nbytes = zmq_msg_recv(message, socket, 0)

    ! print *, this_image(), 'zmq_msg_recv::nbytes', nbytes

    data = zmq_msg_data(message)

    call c_f_pointer(data, buffer)

    if (nbytes .gt. 0) then
        print *, this_image(), '[ØMQ] msg len:', nbytes, 'buffer:', buffer
    end if

    rc = zmq_msg_close(message)
end subroutine recv_command

subroutine send_command(socket, cmd)
    use, intrinsic :: iso_c_binding

    type(c_ptr), intent(inout) :: socket
    character(kind=c_char), intent(in), target :: cmd(:)

    integer(kind=c_int)                         :: nbytes
    integer(kind=c_int)                         :: rc
    type(zmq_msg_t)                             :: message
    INTEGER(KIND=C_SIZE_T) :: msg_len

    msg_len = size(cmd)

    print *, '[ØMQ] msg_len:', msg_len

    rc = zmq_msg_init_data(message, c_loc(cmd), msg_len, c_null_funptr, c_null_ptr)

    print *, '[ØMQ] zmq_msg_init_data::rc', rc

    nbytes = zmq_msg_send(message, socket, 0)

    print *, '[ØMQ] nbytes sent', nbytes

    rc = zmq_msg_close(message)
end subroutine send_command

subroutine get_json_var(item, json)
    use iso_varying_string
    use json_for
    implicit none

    type(dataset), pointer, intent(in) :: item
    type(varying_string), intent(out) :: json
    integer :: str_len
    integer(kind=8) :: filesize

    ! calculate the FITS file size
    filesize = nint(real(size(item%hdr)) + real(item%naxes(1))*real(item%naxes(2))&
                   &*real(item%naxes(3))*real(item%naxes(4))*real(abs(item%bitpix)/8), kind=8)

    json = '{'

    !print *, 'header size:', size(item%hdr), 'flux:', trim(item%flux),&
    !& ', filesize:', filesize, ', cunit3:', trim(item%cunit3), ',json:', char(json), trim(item%cunit1)

    ! call json_add_string(json, 'HEADER', 'NULL')

    ! misc. values
    call json_add_integer_number(json, 'width', item%naxes(1))
    call json_add_integer_number(json, 'height', item%naxes(2))
    call json_add_integer_number(json, 'depth', item%naxes(3))
    call json_add_integer_number(json, 'polarisation', item%naxes(4))
    call json_add_long_number(json, 'filesize', filesize)
    call json_add_real_number(json, 'IGNRVAL', item%ignrval)

    call json_add_real_number(json, 'CD1_1', item%cd1_1)
    call json_add_real_number(json, 'CD1_2', item%cd1_2)
    call json_add_real_number(json, 'CD2_1', item%cd2_1)
    call json_add_real_number(json, 'CD2_2', item%cd2_2)

    call json_add_real_number(json, 'CRVAL1', item%crval1)
    call json_add_real_number(json, 'CDELT1', item%cdelt1)
    call json_add_real_number(json, 'CRPIX1', item%crpix1)
    call json_add_string(json, 'CUNIT1', trim(item%cunit1))
    call json_add_string(json, 'CTYPE1', trim(item%ctype1))

    call json_add_real_number(json, 'CRVAL2', item%crval2)
    call json_add_real_number(json, 'CDELT2', item%cdelt2)
    call json_add_real_number(json, 'CRPIX2', item%crpix2)
    call json_add_string(json, 'CUNIT2', trim(item%cunit2))
    call json_add_string(json, 'CTYPE2', trim(item%ctype2))

    call json_add_real_number(json, 'CRVAL3', item%crval3)
    call json_add_real_number(json, 'CDELT3', item%cdelt3)
    call json_add_real_number(json, 'CRPIX3', item%crpix3)
    call json_add_string(json, 'CUNIT3', trim(item%cunit3))
    call json_add_string(json, 'CTYPE3', trim(item%ctype3))

    call json_add_real_number(json, 'BMAJ', item%bmaj)
    call json_add_real_number(json, 'BMIN', item%bmin)
    call json_add_real_number(json, 'BPA', item%bpa)

    call json_add_string(json, 'BUNIT', trim(item%bunit))
    call json_add_string(json, 'BTYPE', trim(item%btype))
    call json_add_string(json, 'SPECSYS', trim(item%specsys))

    call json_add_real_number(json, 'RESTFRQ', item%restfrq)
    call json_add_real_number(json, 'OBSRA', item%obsra)
    call json_add_real_number(json, 'OBSDEC', item%obsdec)

    call json_add_string(json, 'OBJECT', trim(item%object))
    call json_add_string(json, 'DATEOBS', trim(item%date_obs))
    call json_add_string(json, 'TIMESYS', trim(item%timesys))
    call json_add_string(json, 'LINE', trim(item%line))
    call json_add_string(json, 'FILTER', trim(item%filter))

    ! statistics (image histogram)
    call json_add_integer_array(json, 'histogram', item%hist)
    ! print *, item%hist

    ! remove the last comma
    str_len = len(json)

    if (extract(json, str_len) .eq. ',') json = remove(json, str_len)

    json = char(json)//'}'

    print *, char(json)
    print *, 'JSON length:', len(json)
    ! print *, 'header size:', size(item%hdr), 'flux:', trim(item%flux)
end subroutine get_json_var

subroutine get_json_str(item, json)
    use json_for
    implicit none

    type(dataset), pointer, intent(in) :: item
    character(len=:), allocatable, intent(inout) :: json

    print *, item%hist

    json = '{'

    ! call json_test(json, 'width', 1011)

    ! call json_add_integer_number(json, 'width', 1011)
    ! call json_add_integer_number(json, 'width', item%naxes(1))
    ! call json_add_integer_number(json, 'height', item%naxes(2))
    ! call json_add_integer_number(json, 'depth', item%naxes(3))
    ! call json_add_integer_number(json, 'polarisation', item%naxes(4))

    print *, item%hist, 'size:', size(item%hist)
    print *, json

end subroutine get_json_str


    subroutine dc13_speciation
!   **************************
    implicit none
    include 'combine_foam.inc'

    do j=1,nbasin-1
        edb(j)=(24.12-9866/temp_box(j))*1.d-3 !H2CO3 -> HCO3
        ebc(j)=((653.627/(temp_box(j)-233.45)**2)+0.22)*1.d-3 ! HCO3 -> CO3
        dco3(j)=(var(1,j)*var(13,j)-ebc(j)*hco3(j) &
                -ebc(j)*h2co3(j)-edb(j)*h2co3(j))/ &
                var(1,j)
        dhco3(j)=dco3(j)+ebc(j)
        dh2co3(j)=dhco3(j)+edb(j)
    end do
    return
    end


        subroutine parabol (x1, x2, x3, y1, y2, y3, aa, bb, cc)
c============================================================================
c       PARABOLIC PARAMETRIZED CURVE FITTING SUBROUTINE
c============================================================================
        dd = x1 * x1 * (x2 - x3) - x1 * (x2 * x2 - x3 * x3) +
     &     (x2 * x2 * x3 - x3 * x3 * x2)
        da = y1 * (x2 - x3) - x1 * (y2 - y3) + (y2 * x3 - x2 * y3)
        db = x1 * x1 * (y2 - y3) - y1 * (x2 * x2 - x3 * x3) +
     &     (x2 * x2 * y3 - x3 * x3 * y2)
        dc = x1 * x1 * (x2 * y3 - y2 * x3) - x1 *
     &    (x2 * x2 * y3 - y2 * x3 * x3) + y1 *
     &    (x2 * x2 * x3 - x3 * x3 * x2)
        aa = da / dd
        bb = db / dd
        cc = dc / dd
        return
        end
c--------------------------------------------------------------------


      subroutine cov_vol2vol(ivol1,ivol2,vvcov)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c     Returns the covariance between to volume, ivol1 and ivol2
c     in case volume average data is present
c     *********************************************
c
c     INPUT VARIABLES:
c
c     ivol1        number of volume 1
c     ivol2        number of volume 2
c
c     OUTPUT VARIABLES:
c
c     vvcov       volume to voume covariance
c
c     ORIGINAL : Thomas Mejer Hansen                       DATE: June 2004
c
c     TODO : Use either lookup table in RAM or a lookup table on disk
c
c-----------------------------------------------------------------------
      use geostat_allocate
	  include 'visim.inc'
      real vvcov
      integer i,j,k,ivol_temp
      real x1,x2,y1,y2,z1,z2
      real cov

      if ((ivol1.eq.0).AND.(ivol2.eq.0)) then
         if (idbg.gt.0) then
            write(*,*) 'Initializing vol2vol covar lookup table'
         endif
         k=0
         do i=1,MAXVOLS
            do j=1,MAXVOLS
               cv2v(i,j)=UNEST
            enddo
         enddo
        vvcov=0
        return
      endif

c     UNCOMMENT NEXT LINE TO NOT USE LOOKUP TABLE
c      cv2v(ivol1,ivol2)=UNEST

      if (cv2v(ivol1,ivol2).eq.UNEST) then
         vvcov=0
         do i=1,ndatainvol(ivol1)
            do j=1,ndatainvol(ivol2)
               x1=volx(ivol1,i)
               y1=voly(ivol1,i)
               z1=volz(ivol1,i)
               x2=volx(ivol2,j)
               y2=voly(ivol2,j)
               z2=volz(ivol2,j)

               call cova3(x1,y1,z1,
     +              x2,y2,z2,1,nst,MAXNST,c0,it,
     +              cc,aa,1,MAXROT,rotmat,cmax,cov)

               vvcov=vvcov +
     +              dble(cov)*( voll(ivol1,i) * voll(ivol2,j) )

            enddo
         enddo
c     PUT VALUE IN LOOKUP TABLE
         cv2v(ivol1,ivol2) =  dble(vvcov )
      else
         vvcov = dble(cv2v(ivol1,ivol2))
      endif

      return
      end


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlower,ylower,dx,dy,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays

c     #   aux(i,j,1) is edge velocity at "left" boundary of grid point (i,j)
c     #   aux(i,j,2) is edge velocity at "bottom" boundary of grid point (i,j)

c
c
      implicit double precision (a-h,o-z)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, maux)
c
c     # constant velocities which are used if tperiod=0 is specified
c     # in setprob.data

      do 20 i=1-mbc,mx+mbc
         do 20 j=1-mbc,my+mbc

c           # coordinates of lower left corner of grid cell:
            xll = xlower + (i-1)*dx
            yll = ylower + (j-1)*dy

c           # difference stream function psi to get normal velocities:
            aux(i,j,1) = -(psi(xll, yll+dy) - psi(xll,yll)) / dy
            aux(i,j,2) =  (psi(xll+dx, yll) - psi(xll,yll)) / dx
   20       continue

c
       return
       end


c=======================================================================
c
c     subroutine MULTIVOLRFR
c
c     Risk Budgeting allocation strategy with a risk-free asset
c
c     w(i), i=1,...,n the riskly assets (portfolio weights)
c     w(0), the risk-free asset
c
c     Max[ w'*rho - k*w'*Q*w]
c      s.t.
c     sqrt[w'*cov_i*w] <= sigma(i)  (i-th risk budgeting constraint)
c     C*w <= b                      (general linear constraints)
c     Cinf(i) <= w(i) <= Csup(i)    (riskly assets lower/upper bounds)
c     Cinf(0) <= w(0) <= Csup(0)    (risk-free asset lower/upper bounds)
c
c        Q   : covariance matrix
c        rho : expected returns
c        rfr : risk-free rate
c
c-----------------------------------------------------------------------
      SUBROUTINE multivolrfr ( n, cov, Q, kappa, rho, rfr,
     &                         neq, nin, ccst, bcst,
     &                         cinf, csup, cinfrfr, csuprfr,
     &                         nbc, class, sigma,
     &                         iwork, dwork, wopt, wrf, lambda, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       cov    : covariance matrix (n*n)                          double
c       Q      : risk aversion matrix (n*n)                       double
c       kappa  : risk aversion coefficient                        double
c       rho    : expected returns vector (n)                      double
c       rfr    : expected risk-free rate                          double
c       neq    : number equality constraints                     integer
c       nin    : number inequality constraints                   integer
c       ccst   : matrix of constraints (nasset*(neq+nin))         double
c       bcst   : vector initial of constraints (neq+nin)          double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       cinfrfr: risk-free lower bound                            double
c       csuprfr: risk-free upper bound                            double
c       nbc    : number of risk budgeting constraints (>=1)      integer
c       class  : block definition (n)                            integer
c       sigma  : volatilities budgets constraints (nbc)           double
c
c     WORKSPACE
c       iwork  : 2*nbc + 5*n + neq + 2*tnin + 7                  integer
c              = 2*nbc + 5*n + neq + 2*nin + 11
c       dwork  : nbc*(nbc+21)/2
c              + n*(8*n+2*neq+2*tnin+22)+5*neq+7*tnin+16          double
c              = nbc*(nbc+21)/2
c              + n*(8*n+2*neq+2*nin+26)+ 5*neq+7*nin +30
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       wrf    : optimal risk-free asset                          double
c       lambda : optimal lambda (nbc)                             double
c       info   : diagnostic argument                             integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin, nbc
      INTEGER class(*)
      DOUBLE PRECISION wrf, rfr, kappa, cinfrfr, csuprfr
      DOUBLE PRECISION cov(*), Q(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*), sigma(*), lambda(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, npk, totitr, totsim, ncst, ntot, tnin,
     &        infoBFGS, infot, IZERO, test
      INTEGER piwbf, pisim, pinfo, pin, pineq, pinin, piclass, piqp,
     &        pydual, pbinf, pbsup, pgrad, pwbf, pdsim,
     &        pdcov, pdrho, pdcinf, pdcsup, pdsigma, pdc, pdb,
     &        pdcov1, pdQ, pdkappa, pdcinf0, pdcsup0, pdqp, pdlagr
      DOUBLE PRECISION funct, epsbfg, sum, scal, tmp
      DOUBLE PRECISION INFINI, MINFINI, ZERO, EPS, ONE, COEF, TOL
      PARAMETER (IZERO=0, ZERO=0.E0,EPS=1.E-15,ONE=1.E0,COEF=-0.5E0)
      PARAMETER (TOL=1.E-15, INFINI=1.E+15, MINFINI = -1.E+10)
c
c     external subroutines
      EXTERNAL simmvolrfr, gesterr, testsdp, OVTMCV, IVX, YV,
     &         bfgsmvol, checklinbox, initfeas, IVI, SEV
c
c     intrinsic functions
c
c-----------------------------------------------------------------------
c
c
c     initializations
      info = 0          ! diagnostic argument
      ntot = neq + nin  ! number total of input constraint
      tnin = nin + 2    ! add risk-free constraints (lower/upper)
      ncst = neq + tnin ! number total of constrains
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwbf = 1
c     piwbf : pointer for BFGSBOX who needs (2*nbc + 1)
      pisim  = piwbf + (2*nbc + 1)
c     pisim : pointer for simulator SIMMVOLRFR (5*n + neq + 2*tnin + 6)
      pinfo = pisim
c     pinfo : pointer for info (errors of simul), so 1 more
      pin   = pinfo + ( 1 )
c     pin   : pointer for value of n, so 1 more
      pineq = pin + ( 1 )
c     pineq : pointer for value of neq, so 1 more
      pinin = pineq + ( 1 )
c     pinin : pointer for value of nin, so 1 more
      piclass = pinin + ( 1 )
c     piclass: pointer for value of class, so n more
      piqp = piclass + ( n )
c     piqp : pointer for QP (SIMMVOLRFR)
c
c     Total size of dwork array = (2*nbc + 1) + (5*n + neq + 2*tnin + 6)
c                               = 2*nbc + 5*n + neq + 2*nin + 10
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pydual = 1
c     pydual: pointer for initial value of ydual (nbc)
      pbinf = pydual + ( nbc )
c     pbinf : pointer for inferior bounds binf (nbc)
      pbsup = pbinf + ( nbc )
c     pbsup : pointer for superior bounds bsup (nbc)
      pgrad = pbsup + ( nbc )
c     pgrad : pointer for gradient at solution (nbc)
      pwbf = pgrad + ( nbc )
c     pwbf  : pointer for BFGSMVOL ( nbc*(nbc+11)/2 )
      pdsim = pwbf + ( nbc*(nbc+11)/2 )
c     pdsim  : pointer for the simulator SIMMVOLRFR
c              n*(7*n+2*neq+2*tnin+21)+nbc+4*neq+6*tnin+16
      pdcov   = pdsim
c     pdcov : pointer for cov. matrix (n*n)
      pdQ     = pdcov + ( n*n )
c     pdQ   : pointer for Q matrix (n*n)
      pdkappa = pdQ + ( n*n )
c     pdcov : pointer for kappa (1)
      pdrho   = pdkappa + ( 1 )
c     pdrho : pointer for expected returns (n)
      pdcinf  = pdrho + ( n )
c     pdcinf : pointer for lower bounds (n)
      pdcsup  = pdcinf + ( n )
c     pdcsup : pointer for upper bounds (n)
      pdcinf0 = pdcsup + ( n )
c     pdcinf0 : pointer for risk-free lower bounds (1)
      pdcsup0 = pdcinf0 + ( 1 )
c     pdcsup0 : pointer for risk-free upper bounds (1)
      pdsigma = pdcsup0 + ( 1 )
c     pdsigma : pointer for risk budget constraint (nbc)
      pdc     = pdsigma + ( nbc )
c     pdc : pointer for matrix constraint (n*(neq + tnin))
      pdb     = pdc + ( n*(neq + tnin) )
c     pdb : pointer for vector constraint (neq + tnin)
      pdqp    = pdb + ( neq + tnin )
c     pdqp : pointer for QP (SIMMVOLRFR), n*(neq+tnin+2*n+15)+2*neq +4*tnin+13
      pdlagr  = pdqp + ( n*(5*n+neq+tnin+18)+3*neq+5*tnin+13 )
c     pdlagr : pointer for QP Lagrange parameter (n + neq + tnin)
      pdcov1  = pdlagr + ( n + neq + tnin )
c     + n*n
c
c     Total size of dwork array = 4*nbc + ( nbc*(nbc+11)/2 )
c                               + n*(7*n+2*neq+2*tnin+21)+nbc+4*neq+6*tnin+16 (SIMMVOLRFR)
c                               + n*n
c                               + n+neq+tnin
c              = nbc*(nbc+21)/2 + n*(8*n+2*neq+2*tnin+22)+5*neq+7*tnin+16
c-----------------------------------------------------------------------
c
c      TODO - test if classes are not all null
c
c-----------------------------------------------------
c     satisfiability conditions (well-defined problem)
c-----------------------------------------------------
c
c     test if the covariance matrix is SDP
      CALL testsdp (n, cov, iwork(pisim), dwork(pdsim), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
      IF (kappa .LT. EPS) THEN
        CALL YV ( n*n, cov, dwork(pdQ) )
      ELSE
        CALL YV ( n*n, Q, dwork(pdQ) )
        CALL testsdp (n, dwork(pdQ), iwork(pisim), dwork(pdsim), info)
        IF (info .NE. 0) THEN
            info = -109
            RETURN
        ENDIF
      ENDIF
c
c     case sigma(1)=0
      IF (nbc .EQ. 1) THEN
        IF (ABS(sigma(1)) .LT. EPS) THEN
            CALL IVX ( n, wopt, ZERO )
            IF (csuprfr .GT. (1.0-10*EPS)) THEN
                wrf = 1.0
            ELSE
                wrf  = cinfrfr
                info = 110
            ENDIF
            RETURN
        ENDIF
      ENDIF
c
c     problem initialization and feasibility check
      CALL initfeas ( n, cinf, csup, neq, nin, ccst, bcst,
     &               iwork(piqp), dwork(pdqp), wopt, info )
      IF (info .EQ. 1111) THEN
        info = -100
        RETURN
      ENDIF
c
c-----------------------------------------------------------------
c     construction of work vectors (communication with simmvolrfr)
c-----------------------------------------------------------------
c
c     initialization
      CALL IVX ( nbc, dwork(pydual), ONE )   ! dual
      CALL IVX ( nbc, dwork(pbinf), ZERO )   ! lower bounds
      CALL IVX ( nbc, dwork(pbsup), INFINI ) ! upper bounds
c
c     construct of iwork (communication with simmvol)
      iwork(pinfo) = 0       ! diagnostic argument
      iwork(pin)   = n       ! number of asset(s)
      iwork(pineq) = neq     ! number of eq. constraint(s)
      iwork(pinin) = nin     ! number of ineq. constraint(s)
      CALL YVI ( n, class, iwork(piclass) ) ! cov. matrix partition
c
c     construct dwork (communication with simmvol)
      CALL YV ( n*n, cov, dwork(pdcov) )     ! cov. matrix
      CALL YV ( n*n, Q, dwork(pdQ) )         ! Q matrix (risk aversion)
      CALL YV ( n, rho, dwork(pdrho) )       ! rho
      DO i = 1,n
        dwork(pdrho + i - 1) = dwork(pdrho + i - 1) - rfr
      ENDDO
      dwork(pdkappa) = kappa                 ! kappa coef.
      CALL YV ( n, cinf, dwork(pdcinf) )     ! lower bounds
      CALL YV ( n, csup, dwork(pdcsup) )     ! upper bounds
      CALL YV ( 1, cinfrfr, dwork(pdcinf0) ) ! risk-free lower bound
      CALL YV ( 1, csuprfr, dwork(pdcsup0) ) ! risk-free upper bound
      CALL YV ( nbc, sigma, dwork(pdsigma) ) ! risk budget(s)
c
c     case rho(1) = rho(2) = ... = rho(n)
      tmp = rho(1)
      test = 0
      DO i = 2,n
       IF (ABS(tmp - rho(i)) .GT. EPS) THEN
        test = 1
       ENDIF
      ENDDO
      IF (test .EQ. 0) THEN
        dwork(pdrho + 1) = dwork(pdrho + 1)
     &                   + 1.E-4*(MAX(dwork(pdrho + 1),1.E-6))
      ENDIF
c
c     case ncst <> 0 (neq=0, nin=0)
      IF (ntot .NE. 0) THEN
        CALL YM ( n, ntot, ccst, dwork(pdc) )  ! constraint matrix
        CALL YV ( ntot, bcst, dwork(pdb) )    ! constraint vector
      ENDIF
c
c     linear constraints (C*w <= b)
      DO i = 1,n
        dwork(pdc + ntot*n + i - 1)     =  1.0
        dwork(pdc + (ntot+1)*n + i - 1) = -1.0
      ENDDO
      dwork(pdb + ntot)     = 1.0 - cinfrfr
      dwork(pdb + ntot + 1) = csuprfr - 1.0
c
c-------------------------------------------------------------------
c     Non Linear optimization (BFGS)
c-------------------------------------------------------------------
      epsbfg = 1.E-10   ! precision stop test
      CALL bfgsmvol ( simmvolrfr, gesterr, nbc, dwork(pydual), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pwbf),
     &                funct, dwork(pgrad), totitr, totsim, info)
      CALL YV ( nbc, dwork(pydual), lambda ) ! ydual -> lambda
      infoBFGS = info ! BFGS diagnostic argument
c
c-------------------------------------------------
c     Optimize with optimal dual solution (lambda)
c-------------------------------------------------
c
      CALL IMX ( n, n, dwork(pdcov), ZERO ) ! initialize pdcov
c
c     construct cov. matrix with optimal dual solution
      DO i = 1,nbc
         CALL IVI(n, iwork(piwbf), IZERO) ! initialize piwbf
c
c        dimension of block i
         npk = 0
         DO j = 1,n
            IF (class(j) .EQ. i) THEN
               npk = npk + 1
               iwork(piwbf + npk - 1) = j
            ENDIF
         ENDDO
         IF (npk .GT. 1) THEN
c
c           initialize temporary cov. matrix
            CALL IMX ( npk, npk, dwork(pdcov1), ZERO )
c
c           extract block i
            CALL YMCPI ( n, cov, npk, iwork(piwbf), dwork(pdcov1), info)
c
c           product lambda(i)*cov(i)
            CALL PMX (npk, npk, dwork(pdcov1), lambda(i), dwork(pdcov1))
c
c           sub-block -> cov. matrix
            CALL YMCPIR (npk, dwork(pdcov1), n, iwork(piwbf),
     &                   dwork(pdcov), info)
         ENDIF
      ENDDO
c
c     product kappa*Q -> pdcov1
      CALL PMX (n, n, Q, kappa, dwork(pdcov1))
c
c     kappa*Q + Sum(Cov_i)
      CALL SM ( n, n, dwork(pdcov), dwork(pdcov1), dwork(pdcov))
c
c     linear part: l(i) = -0.5*rho(i)
      CALL PVX ( n, rho, COEF, dwork(pdrho) )
c
c     problem initialization and feasibility check
      CALL initfeas ( n, cinf, csup, neq, tnin, dwork(pdc), dwork(pdb),
     &                iwork(piqp), dwork(pdqp), wopt, info)
      IF (info .EQ. 1111) THEN
        info = -100
        RETURN
      ENDIF
c
c     quadratic solver
      CALL qp ( n,dwork(pdcov), dwork(pdrho), neq, tnin,
     &          dwork(pdc), dwork(pdb), cinf, csup,
     &          iwork(piqp), dwork(pdqp),
     &          dwork(pdlagr), wopt, info )
c
c     risk-free asset
      CALL SEV ( n, wopt, sum )
      wrf = 1.0 - sum
c
c-------------------------------------------------------------
c     test if the ith-volatility budget constraint is too high/small
c     (budget constraint not attainable) -> info = 111/110
c-------------------------------------------------------------
c
      IF (info .NE. 1001) THEN
        DO i = 1,nbc
            IF (ABS(lambda(i)) .LT. 1.E-15) THEN
                info = 111
            ENDIF
            IF (ABS(lambda(i)) .GT. 1.E+14) THEN
                info = 110
            ENDIF
        ENDDO
      ENDIF
c
c     checking non-emptiness of linear constraints
      CALL checklinbox ( n, wopt, neq, tnin,
     &                   dwork(pdc), dwork(pdb),
     &                   cinf, csup,
     &                   dwork(pwbf), infot )
      IF (infot .LT. 0) THEN
        info = infot
        RETURN
      ENDIF
c
c     construct cov. matrix with optimal dual solution
      DO i = 1,nbc
         DO j = 1,n
            iwork(piwbf + i - 1) = 0
         ENDDO
c
c        dimension of the i-th block
         npk = 0
         DO j = 1,n
            IF (class(j) .EQ. i) THEN
               npk = npk + 1
               iwork(piwbf + npk - 1) = j
            ENDIF
         ENDDO
         IF (npk .GT. 1) THEN
c
c           initialize temporary cov. matrix
            CALL IMX ( npk, npk, dwork(pdcov1), ZERO )
            CALL IMX ( n, n, dwork(pdcov), ZERO )
c
c           extracting the i-th block
            CALL YMCPI(n, cov, npk, iwork(piwbf), dwork(pdcov1), infot)
c
c           sub-block -> cov. matrix
            CALL YMCPIR (npk, dwork(pdcov1), n, iwork(piwbf),
     &                   dwork(pdcov), infot)
c
c           variance of the i-th block, w'*Cov*w
            CALL OVTMCV(n, dwork(pdcov), wopt, scal)
            scal = SQRT(scal)
            IF (scal .GT. (sigma(i)+1.E-4)) THEN
                info = -120
                RETURN
            ENDIF
         ENDIF
      ENDDO
c
c     BFGS diagnostic (very complex case)
      IF ((infoBFGS .NE. 0) .AND. (info .EQ. 0)) THEN
        info = infoBFGS
      ENDIF
      RETURN
      END


Function pyspen(xrein, ximin, ireim)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Dimension b(0:14)
  Data b/1.000000E+00, -5.000000E-01, 1.666667E-01, 0.000000E+00, -3.333333E-02, 0.000000E+00, 2.380952E-02, 0.000000E+00, -3.333333E-02, 0.000000E+00, 7.575757E-02, 0.000000E+00, -2.531135E-01, 0.000000E+00, 1.166667E+00/
  xre = xrein
  xim = ximin
  If (abs(1.-xre)<1.E-6 .And. abs(xim)<1.E-6) Then
    If (ireim==1) pyspen = paru(1)**2/6.
    If (ireim==2) pyspen = 0.
    Return
  End If
  xmod = sqrt(xre**2+xim**2)
  If (xmod<1.E-6) Then
    If (ireim==1) pyspen = 0.
    If (ireim==2) pyspen = 0.
    Return
  End If
  xarg = sign(acos(xre/xmod), xim)
  sp0re = 0.
  sp0im = 0.
  sgn = 1.
  If (xmod>1.) Then
    algxre = log(xmod)
    algxim = xarg - sign(paru(1), xarg)
    sp0re = -paru(1)**2/6. - (algxre**2-algxim**2)/2.
    sp0im = -algxre*algxim
    sgn = -1.
    xmod = 1./xmod
    xarg = -xarg
    xre = xmod*cos(xarg)
    xim = xmod*sin(xarg)
  End If
  If (xre>0.5) Then
    algxre = log(xmod)
    algxim = xarg
    xre = 1. - xre
    xim = -xim
    xmod = sqrt(xre**2+xim**2)
    xarg = sign(acos(xre/xmod), xim)
    algyre = log(xmod)
    algyim = xarg
    sp0re = sp0re + sgn*(paru(1)**2/6.-(algxre*algyre-algxim*algyim))
    sp0im = sp0im - sgn*(algxre*algyim+algxim*algyre)
    sgn = -sgn
  End If
  xre = 1. - xre
  xim = -xim
  xmod = sqrt(xre**2+xim**2)
  xarg = sign(acos(xre/xmod), xim)
  zre = -log(xmod)
  zim = -xarg
  spre = 0.
  spim = 0.
  savere = 1.
  saveim = 0.
  Do i = 0, 14
    termre = (savere*zre-saveim*zim)/float(i+1)
    termim = (savere*zim+saveim*zre)/float(i+1)
    savere = termre
    saveim = termim
    spre = spre + b(i)*termre
    spim = spim + b(i)*termim
  End Do
  If (ireim==1) pyspen = sp0re + sgn*spre
  If (ireim==2) pyspen = sp0im + sgn*spim
  Return
End Function pyspen


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

      s12=s(j1,j2)
      s13=s(j1,j3)
      s41=s(j4,j1)
      s23=s(j2,j3)
      s24=s(j2,j4)
      s34=s(j3,j4)
      s123=s12+s13+s23
      s234=s23+s24+s34
      s341=s34+s41+s13
      s412=s41+s12+s24
      mhsq=s12+s13+s41+s23+s24+s34

C---arXIv:09060008v1 Eq.(4.9)
      Vlc = -2d0*epinv**2
     &  -epinv*lnrat(musq,-s23)-epinv*lnrat(musq,-s41)
     &  -0.5d0*lnrat(musq,-s23)**2-0.5d0*lnrat(musq,-s41)**2
     & +13d0/6d0*(2d0*epinv+lnrat(musq,-s12)+lnrat(musq,-s34))
     & - Lsm1_2me(s123,s234,s23,mhsq)
     % - Lsm1_2me(s341,s412,s41,mhsq)
     & - Lsm1DS(s23,s34,s234)
     & - Lsm1DS(s34,s41,s341)
     & - Lsm1DS(s41,s12,s412)
     & - Lsm1DS(s12,s23,s123)
     & + 101d0/9d0 - deltar/3d0

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

      return
      end


*DECK BESI1
      FUNCTION BESI1 (X)
C***BEGIN PROLOGUE  BESI1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI1-S, DBESI1-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI1(X) calculates the modified (hyperbolic) Bessel function
C of the first kind of order one for real argument X.
C
C Series for BI1        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.40E-17
C                                         log weighted error  16.62
C                               significant figures required  16.23
C                                    decimal places required  17.14
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESI1
      DIMENSION BI1CS(11)
      LOGICAL FIRST
      SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
      DATA BI1CS( 1) /   -.0019717132 61099859E0 /
      DATA BI1CS( 2) /    .4073488766 7546481E0 /
      DATA BI1CS( 3) /    .0348389942 99959456E0 /
      DATA BI1CS( 4) /    .0015453945 56300123E0 /
      DATA BI1CS( 5) /    .0000418885 21098377E0 /
      DATA BI1CS( 6) /    .0000007649 02676483E0 /
      DATA BI1CS( 7) /    .0000000100 42493924E0 /
      DATA BI1CS( 8) /    .0000000000 99322077E0 /
      DATA BI1CS( 9) /    .0000000000 00766380E0 /
      DATA BI1CS(10) /    .0000000000 00004741E0 /
      DATA BI1CS(11) /    .0000000000 00000024E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI1
      IF (FIRST) THEN
         NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
         XMIN = 2.0*R1MACH(1)
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI1 = 0.0
      IF (Y.EQ.0.0)  RETURN
C
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1',
     +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) BESI1 = 0.5*X
      IF (Y.GT.XSML) BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1))
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI1',
     +   'ABS(X) SO BIG I1 OVERFLOWS', 2, 2)
C
      BESI1 = EXP(Y) * BESI1E(X)
C
      RETURN
      END


      PROGRAM xbnldev
C     driver for routine bnldev
      INTEGER N,NPTS,ISCAL,NN
      PARAMETER(N=20,NPTS=1000,ISCAL=200,NN=100)
      INTEGER i,idum,j,k,klim,llen
      REAL bnldev,dist(21),pp,xm
      CHARACTER text(50)*1
      idum=-133
      llen=50
10    do 11 j=1,21
        dist(j)=0.0
11    continue
      write(*,*)
     *     'Mean of binomial distribution (0 to 20) (Negative to END)'
      read(*,*) xm
      if (xm.lt.0) goto 99
      pp=xm/NN
      do 12 i=1,NPTS
        j=int(bnldev(pp,NN,idum))
        if ((j.ge.0).and.(j.le.N)) dist(j+1)=dist(j+1)+1
12    continue
      write(*,'(1x,t5,a,t10,a,t18,a)') 'x','p(x)','graph:'
      do 15 j=1,N
        dist(j)=dist(j)/NPTS
        do 13 k=1,50
          text(k)=' '
13      continue
        text(1)='*'
        klim=int(ISCAL*dist(j))
        if (klim.gt.llen) klim=llen
        do 14 k=1,klim
          text(k)='*'
14      continue
        write(*,'(1x,f5.1,f8.4,3x,50a1)') float(j-1),dist(j),
     *       (text(k),k=1,50)
15    continue
      goto 10
99    END

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


subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

    ! Called to update q by solving source term equation
    ! $q_t = \psi(q)$ over time dt starting at time t.
    !
    ! This default version integrates manning friction or other friction terms if present

    ! Version from 1D branch of GeoClaw originally from Dave George
    ! with alternative friction.

    use geoclaw_module, only: dry_tolerance, grav, DEG2RAD
    use geoclaw_module, only: friction_forcing
    use geoclaw_module, only: frictioncoeff => friction_coefficient

    implicit none
    integer, intent(in) :: mbc,mx,meqn,maux
    real(kind=8), intent(in) :: xlower,dx,t,dt
    real(kind=8), intent(in) ::  aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) ::  q(meqn,1-mbc:mx+mbc)

    !Locals
    real(kind=8) :: gamma
    integer :: i

      if (frictioncoeff.gt.0.d0 .and. friction_forcing) then
          ! integrate source term based on Manning formula
            do i=1,mx
               if (q(1,i)<=dry_tolerance) then
                  q(2,i) = 0.0
               else
                  gamma= dsqrt(q(2,i)**2)*(grav*frictioncoeff**2)/(q(1,i)**(7.0/3.0))
                  q(2,i)= q(2,i)/(1.d0 + dt*gamma)
              endif
            enddo
        endif

end subroutine src1


SUBROUTINE Poly_Intercept (a, b, x, y, n, u, v, m, num, ierr)
!-----------------------------------------------------------------------

!                 INTERSECTION OF A STRAIGHT LINE
!                       AND POLYGONAL PATH

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

! The polygon is defined by the set of points (xi, yi), i = 1, 2, ..., n.
! The straight line is from (a1,a2) to (b1,b2).
! On exit, the arrays U and V contain the num points at which the line
! crosses the polygon in order, provided that num <= m.
! Error indicator:
! ierr = 0 no error detected
!      = 1 if a = b
!      = 2 U and V require more storage, i.e. num > m.
!      = -i if the ith segment of the polygon is coincident with part of the
!           line.

! Based upon routine PFIND from the NSWC Mathematics Library.

! Code converted using TO_F90 by Alan Miller
! Date: 2000-07-04  Time: 12:24:01

IMPLICIT NONE

REAL, INTENT(IN)      :: a(2)
REAL, INTENT(IN)      :: b(2)
REAL, INTENT(IN)      :: x(:)
REAL, INTENT(IN)      :: y(:)
INTEGER, INTENT(IN)   :: n
REAL, INTENT(OUT)     :: u(:)
REAL, INTENT(OUT)     :: v(:)
INTEGER, INTENT(IN)   :: m
INTEGER, INTENT(OUT)  :: num
INTEGER, INTENT(OUT)  :: ierr

! Local variables

INTEGER  :: i, ind, nm1
REAL     :: d, diff, diff1, eps, h, hi, k, ki, onem, onep, p, q, s,  &
            t, tmax, tmin, tol, tol0
!----------------------

!     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
!            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .

eps = EPSILON(1.0)

!----------------------
num = 0
IF (n < 2) GO TO 200
h = b(1) - a(1)
k = b(2) - a(2)
IF (h == 0.0 .AND. k == 0.0) GO TO 200

ierr = 0
nm1 = n - 1
tol = 4.0*eps
tol0 = 2.0*eps
onep = 1.0 + tol
onem = 0.5 + (0.5 - tol0)

ind = 0
DO  i = 1, nm1
  hi = x(i + 1) - x(i)
  ki = y(i + 1) - y(i)
  IF (hi == 0.0 .AND. ki == 0.0) CYCLE
  ind = 1

!           CHECK IF THE LINE FROM A TO B AND THE I-TH
!                 LINE IN THE PATH ARE PARALLEL

  s = hi*k
  t = h*ki
  d = s - t
  IF (ABS(d) <= tol*MAX(ABS(s), ABS(t))) GO TO 40
!-----------------------------------------------------------------------
!                   THE LINES ARE NOT PARALLEL
!-----------------------------------------------------------------------
  p = x(i) - a(1)
  q = y(i) - a(2)
  s = hi*q
  t = ki*p
  diff = s - t
  IF (ABS(diff) <= tol*MAX(ABS(s),ABS(t))) diff = 0.0
  s = h*q
  t = k*p
  diff1 = s - t
  IF (ABS(diff1) <= tol*MAX(ABS(s),ABS(t))) diff1 = 0.0

  s = diff/d
  t = diff1/d
  IF (s < 0.0 .OR. s > onep) CYCLE
  IF (t < 0.0 .OR. t > onep) CYCLE
  IF (num > 0 .AND. t == 0.0) CYCLE
  IF (s > 0.0) GO TO 20

!                   POINT A IS ON THE I-TH LINE

  10 num = num + 1
  IF (num > m) GO TO 210
  u(num) = a(1)
  v(num) = a(2)
  CYCLE

!                   POINT B IS ON THE I-TH LINE

  20 IF (s < onem) GO TO 30
  21 num = num + 1
  IF (num > m) GO TO 210
  u(num) = b(1)
  v(num) = b(2)
  CYCLE

!              THE INTERIOR OF THE LINE FROM A TO B
!                 INTERSECTS WITH THE I-TH LINE

  30 num = num + 1
  IF (num > m) GO TO 210
  u(num) = a(1) + s*h
  v(num) = a(2) + s*k
  CYCLE
!-----------------------------------------------------------------------
!                     THE LINES ARE PARALLEL
!-----------------------------------------------------------------------
  40 IF (ABS(hi) > ABS(ki)) GO TO 50

  d = a(2) - y(i)
  IF (ABS(d) <= tol0*MAX(ABS(a(2)),ABS(y(i)))) d = 0.0
  s = d/ki

  p = x(i) + s*hi
  IF (ABS(a(1) - p) > tol*MAX(ABS(a(1)),ABS(p))) CYCLE

  d = b(2) - y(i)
  IF (ABS(d) <= tol0*MAX(ABS(b(2)),ABS(y(i)))) d = 0.0
  t = d/ki
  GO TO 60

  50 d = a(1) - x(i)
  IF (ABS(d) <= tol0*MAX(ABS(a(1)),ABS(x(i)))) d = 0.0
  s = d/hi

  p = y(i) + s*ki
  IF (ABS(p - a(2)) > tol*MAX(ABS(p),ABS(a(2)))) CYCLE

  d = b(1) - x(i)
  IF (ABS(d) <= tol0*MAX(ABS(b(1)),ABS(x(i)))) d = 0.0
  t = d/hi

!              THE 2 LINES ARE PORTIONS OF THE SAME
!                     STRAIGHT INFINITE LINE

  60 IF (s > 0.0 .AND. s < onem) GO TO 220
  IF (t > 0.0 .AND. t < onem) GO TO 220
  tmin = MIN(s,t)
  tmax = MAX(s,t)
  IF (tmax <= 0.0) GO TO 70
  IF (tmin >= onem) GO TO 80
  GO TO 220

  70 IF (tmax < 0.0) CYCLE
  IF (num > 0) CYCLE
  IF (tmax == s) GO TO 10
  GO TO 21

  80 IF (tmin > 1.0) CYCLE
  IF (tmin == s) GO TO 10
  GO TO 21

END DO
IF (ind == 0) GO TO 200

IF (num < 2) RETURN
IF (u(num) == x(1) .AND. v(num) == y(1)) num = num - 1
RETURN

!                          ERROR RETURN

200 ierr = 1
RETURN

210 ierr = 2
num = num - 1
RETURN

220 ierr = -i
RETURN
END SUBROUTINE Poly_Intercept


subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

    ! Called to update q by solving source term equation
    ! $q_t = \psi(q)$ over time dt starting at time t.
    !
    ! This default version integrates manning friction or other friction terms if present

    ! Version from 1D branch of GeoClaw originally from Dave George

    ! Also handles radial source term, if desired.
    ! Note: assumes radial about lower boundary, wall bc should be imposed

    use geoclaw_module, only: dry_tolerance, grav, DEG2RAD
    use geoclaw_module, only: friction_forcing
    use geoclaw_module, only: frictioncoeff => friction_coefficient
    use geoclaw_module, only: earth_radius, coordinate_system
    use grid_module, only: mx_edge, xp_edge
    use bouss_module, only: bouss,solve_tridiag

    implicit none
    integer, intent(in) :: mbc,mx,meqn,maux
    real(kind=8), intent(in) :: xlower,dx,t,dt
    real(kind=8), intent(in) ::  aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) ::  q(meqn,1-mbc:mx+mbc)

    ! Locals
    real(kind=8) :: gamma, rcell, u, xcell, tanxR
    real(kind=8) :: rk_stage(1:mx,4), delt
    integer ::  i,k,ii,nstep,rk_order
    real(kind=8)  q0(meqn,1-mbc:mx+mbc)
    real(kind=8) psi(mx+2)

      if (frictioncoeff.gt.0.d0 .and. friction_forcing) then
          ! integrate source term based on Manning formula
            do i=1,mx
               if (q(1,i)<=dry_tolerance) then
                  q(2,i) = 0.0
               else
                  gamma= dsqrt(q(2,i)**2)*(grav*frictioncoeff**2)/(q(1,i)**(7.0/3.0))
                  q(2,i)= q(2,i)/(1.d0 + dt*gamma)
              endif
            enddo
        endif

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

    !if (radial) then  ! OLD
    if (coordinate_system == -1) then
        ! radial source term for SWE:
        do i=1,mx
            if (q(1,i) .gt. dry_tolerance) then
                ! assume x is radial coordinate in meters, x>=0,
                ! u = radial velocity
                rcell = 0.5*(xp_edge(i) + xp_edge(i+1))
                !rcell = 0.5*(xp_edge(i) + xp_edge(i+1)) - xp_edge(1) ! OLD
                q(1,i) = q(1,i) - dt/rcell * q(2,i)
                u = q(2,i)/q(1,i)
                q(2,i) = q(2,i) - dt/rcell * q(1,i)*u**2
            endif
         enddo
     endif

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

    if (coordinate_system == 2) then
        ! source term for x = latitude in degrees -90 <= x <= 90,
        ! u = velocity in latitude direction (m/s) on sphere:
        do i=1,mx
            if (q(1,i) .gt. dry_tolerance) then
                xcell = 0.5*(xp_edge(i) + xp_edge(i+1))
                tanxR = tan(xcell*DEG2RAD) / earth_radius
                q(1,i) = q(1,i) + dt * tanxR * q(2,i)
                u = q(2,i)/q(1,i)
                q(2,i) = q(2,i) + dt * tanxR * q(1,i)*u**2
            endif
         enddo
     endif

    ! -------------------------------------------------
    if (bouss) then

        ! Boussinesq terms

        nstep = 1  ! set > 1 to do subcycling with source term
        delt = dt / nstep

        rk_order = 1  ! 1 for Forward Euler, 2 for second-order RK

        do ii=1,nstep

          rk_stage = 0.d0
          q0  = q

          !-----------------------
          if (rk_order == 1) then
              ! Forward Euler

              call solve_tridiag(mx,meqn,mbc,dx,q0,maux,aux,psi)

              ! Forward Euler update:
              ! Note component 1 of psi used for BC, so psi(2) updates q(:,1):
              q(2,1:mx) = q(2,1:mx) + delt*psi(2:mx+1)

          endif  ! rk_order == 1

          !-----------------------
          if (rk_order == 2) then

              ! Second-order explicit R-K
              ! First Stage

              call solve_tridiag(mx,meqn,mbc,dx,q0,maux,aux,psi)

              rk_stage(1:mx,1) = psi(2:mx+1)

              q0(2,1:mx)=q(2,1:mx) + delt/2.d0*rk_stage(1:mx,1)

              ! Second Stage

              call solve_tridiag(mx,meqn,mbc,dx,q0,maux,aux,psi)

              rk_stage(1:mx,2)=psi(2:mx+1)

              q(2,1:mx) = q(2,1:mx) + delt*rk_stage(1:mx,2)

          endif ! rk_order == 2

        enddo

    endif ! end of Bouss terms

end subroutine src1


c
c  RCS $Revision: 1.1.1.1 $  $Date: 2001/04/09 08:15:53 $
c
*deck droot
      subroutine droot(nroots,n1,xx,ff,c,s,a,rt,r,w,uf,wf)
c
c  ith root of the jth rys polynomial is returned in r(i,j)
c  with the corresponding weight factor in w(i,j).  j=1,2,...,n
c  this version uses christoffel formula for weights.
c
*mdc*if real16 vax ibm cray
*      implicit real*16 (a-h,o-z)
*      real*8 xx,uf,wf
*mdc*else
      implicit real*8 (a-h,o-z)
      real*8 xx,uf,wf
*mdc*endif
*mdc*if real16q ibm vax rs6000 fujitsu
*c *** this mdc block is not necessary since the constants will be ***
*c *** correctly converted at compile time.  should it be removed? ***
*      parameter (a0=0.0q0, a1s2=0.5q0, a1=1.0q0, a4=4.0q0)
*mdc*else
      parameter (a0=0.0d0, a1s2=0.5d0, a1=1.0d0, a4=4.0d0)
*mdc*endif
c     common /ffm/ x,nn,n1,k
c     dimension uf(*), wf(*)
c     dimension ff(19), c(10,10), s(10,10), a(10), rt(10),
c    &  r(9,9), w(9,9)
      dimension ff(*), c(n1,*), s(n1,*), a(*), rt(*),
     &  r(nroots,*), w(nroots,*), uf(*), wf(*)
c
      n=max(nroots,2)
      x=xx
c     n1=n+1
      nn=n+n
      call dfunc(nn,x,ff,c)
      do 15 i=1,n1
        do 10 j=1,n1
          s(i,j)=ff(i+j-1)
   10   continue
   15 continue
      call dsmit(n1,c,s,a,rt)
      do 25 i=1,n
        do 20 j=1,i
          w(i,j)=a0
          r(i,j)=a0
   20   continue
   25 continue
      wsum=ff(1)
      w(1,1)=wsum
      r(1,1)=ff(2)/wsum
      dum=sqrt(c(2,3)**2-a4*c(1,3)*c(3,3))
      r(1,2)=a1s2*(-c(2,3)-dum)/c(3,3)
      r(2,2)=a1s2*(-c(2,3)+dum)/c(3,3)
      if(n.eq.2) go to 50
      do 30 i=3,n1
        rt(i)=a1
   30 continue
      rt(1)=r(1,2)
      rt(2)=r(2,2)
      do 45 k=3,n
        k1=k+1
        do 35 i=1,k1
          a(i)=c(i,k1)
   35   continue
        call dnode(k,a,rt)
        do 40 i=1,k
          r(i,k)=rt(i)
   40   continue
   45 continue
   50 continue
      do 70 k=2,n
        do 65 i=1,k
          root=r(i,k)
          dum=a1/ff(1)
          do 60 j=1,k-1
            j1=j+1
            poly=c(j1,j1)
            do 55 m=1,j
              poly=poly*root+c(j1-m,j1)
   55       continue
            dum=dum+poly*poly
   60     continue
          w(i,k)=a1/dum
   65   continue
   70 continue
      do 75 k=1,nroots
        dum=r(k,nroots)
        uf(k)=dum/(a1-dum)
        wf(k)=w(k,nroots)
   75 continue
      return
      end


      FUNCTION poidev(xm,idum)
      INTEGER idum
      REAL poidev,xm,PI
      PARAMETER (PI=3.141592654)
CU    USES gammln,ran1
      REAL alxm,em,g,oldm,sq,t,y,gammln,ran1
      SAVE alxm,g,oldm,sq
      DATA oldm /-1./
      if (xm.lt.12.)then
        if (xm.ne.oldm) then
          oldm=xm
          g=exp(-xm)
        endif
        em=-1
        t=1.
2       em=em+1.
        t=t*ran1(idum)
        if (t.gt.g) goto 2
      else
        if (xm.ne.oldm) then
          oldm=xm
          sq=sqrt(2.*xm)
          alxm=log(xm)
          g=xm*alxm-gammln(xm+1.)
        endif
1       y=tan(PI*ran1(idum))
        em=sq*y+xm
        if (em.lt.0.) goto 1
        em=int(em)
        t=0.9*(1.+y**2)*exp(em*alxm-gammln(em+1.)-g)
        if (ran1(idum).gt.t) goto 1
      endif
      poidev=em
      return
      END

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


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of ISHFT
module m1
  logical :: test_ishft_lsb = all(ishft(1, [-32, -31, -1, 0, 1, 2, 31, 32]) == [0, 0, 0, 1, 2, 4, int(z'80000000'), 0])
  logical :: test_ishft_msb = all(ishft(ishft(1,31), [-32, -31, -1, 0, 1, 2, 31, 32]) == [0, 1, int(z'40000000'), int(z'80000000'), 0, 0, 0, 0])
end module


      SUBROUTINE W3FM07(FIN,FOUT,CWORK,GAMMA,NCOL,NROW)
C$$$  SUBROUTINE DOCUMENTATION BLOCK ***
C
C SUBR: W3FM07   - NINE-POINT SMOOTHER FOR RECTANGULAR GRIDS
C   AUTHOR: CHASE, P.          ORG: W345          DATE:    APR 75
C
C ABSTRACT: SMOOTHS DATA ON A RECTANGULAR GRID USING A NINE-POINT
C   SMOOTHING OPERATOR.
C
C PROGRAM HISTORY LOG:
C   75-04-01  P.CHASE
C   84-07-01  R.E.JONES   CHANGE TO IBM VS FORTRAN
C   91-04-24  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE: CALL W3FM07 (FIN, FOUT, CWORK, GAMMA, NCOL, NROW)
C
C   INPUT:
C     '   FIN' - REAL   SIZE(NCOL*NROW) ARRAY OF DATA TO BE SMOOTHED
C     ' CWORK' - REAL   SIZE(2*NCOL*(NROW+2)) WORK ARRAY
C     ' GAMMA' - COMPLEX SMOOTHING PARAMETER. THE IMAGINARY PART MUST
C                BE POSITIVE.
C     '  NCOL' - INTEGER   NUMBER OF COLUMNS IN THE GRID
C     '  NROW' - INTEGER   NUMBER OF ROWS IN THE GRID
C   OUTPUT:
C     '  FOUT' - REAL   SIZE(NCOL*NROW) ARRAY OF SMOOTHED DATA. MAY
C                BE THE SAME ARRAY AS 'FIN' OR OVERLAP IT IN ANY
C                FASHION.
C
C   EXIT STATES: NONE
C
C   EXTERNAL REFERENCES: NONE
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      REAL    FIN(NCOL,NROW)
      REAL    FOUT(NCOL,NROW)
C
      COMPLEX CWORK(NCOL,*),GAMMA,GAMMX,GAMA,GAMB,GAMC
C
      GAMMX  = GAMMA
      XSWTCH = AIMAG(GAMMX)
      NCOLM  = NCOL-1
      NROWM  = NROW-1
C
C INITIALIZE WORK ARRAY.  WORK ARRAY STARTS UP TWO ROWS SO IT CAN SMOOTH
C DOWNWARD WITHOUT OVERLAP OF SMOOTHED AND UNSMOOTHED DATA
C
      DO 10 J = 1,NROW
      DO 10 I = 1,NCOL
        CWORK(I,J+2) = CMPLX(FIN(I,J),0.)
 10   CONTINUE
      IF (XSWTCH .EQ. 0.) GO TO 30
      DO 20 J = 1,NROW,NROWM
        JJ = J+ISIGN(1,NROWM-J)
      DO 20 I = 1,NCOL,NCOLM
        II = I+ISIGN(1,NCOLM-I)
        CWORK(I,J+2) = CMPLX(FIN(I,JJ)+FIN(II,J)-FIN(II,JJ),0.)
 20   CONTINUE
C
C SET SMOOTHING OPERATORS
C
 30   GAMA = 0.50 * GAMMX * (1.0 - GAMMX)
      GAMB = 0.25 * GAMMX * GAMMX
      GAMC = 0.50 * GAMMX
C
C SMOOTH WORK ARRAY, PUTTING SMOOTHED POINTS DOWN TWO ROWS
C
      CWORK(1,1) = CWORK(1,3)
      CWORK(NCOL,1) = CWORK(NCOL,3)
      DO 40 I = 2,NCOLM
      CWORK(I,1) = CWORK(I,3)+GAMC*(CWORK(I-1,3)-2.*CWORK(I,3)+
     & CWORK(I+1,3))
 40   CONTINUE
      DO 60 J = 2,NROWM
      DO 50 I = 1,NCOL,NCOLM
      CWORK(I,J) = CWORK(I,J+2)+GAMC*(CWORK(I,J+1)-2.*CWORK(I,J+2)+
     & CWORK(I,J+3))
 50   CONTINUE
      DO 60 I = 2,NCOLM
      CWORK(I,J) = CWORK(I,J+2)+GAMA*(CWORK(I+1,J+2)+CWORK(I-1,J+2)+
     & CWORK(I,J+1)+CWORK(I,J+3)-4.*CWORK(I,J+2))+GAMB*(CWORK(I-1,J+1)+
     & CWORK(I+1,J+1)+CWORK(I-1,J+3)+CWORK(I+1,J+3)-4.*CWORK(I,J+2))
 60   CONTINUE
      CWORK(1,NROW) = CWORK(1,NROW+2)
      CWORK(NCOL,NROW) = CWORK(NCOL,NROW+2)
      DO 70 I = 2,NCOLM
      CWORK(I,NROW) = CWORK(I,NROW+2)+GAMC*(CWORK(I-1,NROW+2)-2.*
     & CWORK(I,NROW+2)+CWORK(I+1,NROW+2))
 70   CONTINUE
C
C IF IMAGINARY PART OF SMOOTHING PARAMETER IS NOT POSITIVE, DONE
C
      IF (XSWTCH .LE. 0.) GO TO 90
C
C OTHERWISE MOVE WORK ARRAY BACK UP TWO ROWS
C
      DO 80 JJ=1,NROW
      J = NROW+1-JJ
      DO 80 I=1,NCOL
      CWORK(I,J+2) = CWORK(I,J)
 80   CONTINUE
C
C SET SMOOTHING PARAMETER FOR CONJUGATE PASS AND GO DO IT
C
      GAMMX  = CONJG(GAMMX)
      XSWTCH = AIMAG(GAMMX)
      GO TO 30
C
C DONE.  OUTPUT SMOOTH ARRAY
C
 90   DO 100 J = 1,NROW
      DO 100 I = 1,NCOL
        FOUT(I,J) = REAL(CWORK(I,J))
 100  CONTINUE
      RETURN
      END


      program prog
      call exercise_c_keywords
      call exercise_char_ichar
      call exercise_nint
      call exercise_double
      call exercise_string
      call exercise_index
      call exercise_min_max
      end

      subroutine exercise_c_keywords
      num = 84
      val = float(num)
      val = val + 0.99
      num = int(val)
      write(6, '(f4.1,1x,i2)') val, num
      end

      subroutine exercise_char_ichar
      character c*1
      c = 'R'
      i = ichar(c)
      write(6, '(i3)') i
      c = 'X'
      write(6, '(a)') c
      c = char(i)
      write(6, '(a)') c
      end

      subroutine exercise_nint
      real rv(8)
      double precision dv(8)
      data rv /0.49, 0.51, -0.49, -0.51, 3.49, 3.51, -2.49, -2.51/
      data dv /1.49, 2.51, -3.49, -4.51, 5.49, 6.51, -7.49, -8.51/
      write(6, '(8i3)') (nint(rv(i)), i=1,8)
      write(6, '(8i3)') (nint(dv(i)), i=1,8)
      end

      subroutine exercise_double
      write(6, '(f6.2)') dacos(0.5d0)
      write(6, '(f6.2)') dasin(0.5d0)
      write(6, '(f6.2)') datan2(0.1d0, 0.2d0)
      write(6, '(f6.2)') dtan(0.5d0)
      end

      subroutine exercise_string
      character s4*4
      s4 = 'Xy'
      write(6, '(i1)') lnblnk(s4)
      end

      subroutine exercise_index
      character digits*10
      data digits /'0123456789'/
      write(6, *) index(digits, 'x')
      write(6, *) index(digits, '0')
      write(6, *) index(digits, '5')
      write(6, *) index(digits, '9')
      write(6, *) index(digits, '24')
      write(6, *) index(digits, '34')
      end

      subroutine exercise_min_max
      real a,b,c,d,e
      a = 2
      b = 4
      c = 0
      d = 3
      e = 1
      write(6, *) amin1(a,b,c,d,e)
      write(6, *) amax1(a,b,c,d,e)
      end


function F(x)

  implicit none

  real,intent(in) :: x !! Función con raíces desconocidas en I=[a,b]
  real::F

  F = sin(3*x-0.1)

  end function


c-----------------------------------------------------------
c Chapter 7: Next permutation of n letters(p59)
c-----------------------------------------------------------
c   Name of subroutine: NEXPER
c
c   Algorithm:Generating next permutation of 1,2,...n.
c
c   input:    n=5
c   complier: f77 nexper_2.f
c-----------------------------------------------------------

c      parameter(n=6)
c      integer a(n),b(n),i
c      logical mtc,even
c      mtc=.false.
c  10  call nexper(n,a,mtc,even)
c      write(*,*)(a(i),i=1,n)
c      if(mtc)goto 10
c      stop
c      end

c-----Subroutine begins here--------------------------------
      subroutine nexper(n,a,mtc,even)
c next permutation of {1,...,n}. Ref NW p 59.
      integer a(*),s,d
      logical mtc,even
      integer i,j,n,i1,nm3,ia
      nm3=n-3
      if(mtc)goto 10
      do 1 i=1,n
    1 a(i)=i
      mtc=.true.
    5 even=.true.
      if(n.eq.1)goto 8
    6 if(a(n).ne.1.or.a(1).ne.2+mod(n,2))return
      if(n.le.3)goto 8
      do 7 i=1,nm3
      if(a(i+1).ne.a(i)+1)return
    7 continue
    8 mtc=.false.
      return
   10 if(n.eq.1)goto 27
      if(.not.even)goto 20
      ia=a(1)
      a(1)=a(2)
      a(2)=ia
      even=.false.
      goto 6
   20 s=0
      do 26 i1=2,n
   25 ia=a(i1)
      i=i1-1
      d=0
      do 30 j=1,i
   30 if(a(j).gt.ia) d=d+1
      s=d+s
      if(d.ne.i*mod(s,2)) goto 35
   26 continue
   27 a(1)=0
      goto 8
   35 m=mod(s+1,2)*(n+1)
      do 40 j=1,i
      if(isign(1,a(j)-ia).eq.isign(1,a(j)-m))goto 40
      m=a(j)
      l=j
   40 continue
      a(l)=ia
      a(i1)=m
      even=.true.
      return
      end
c-----------------------------------------------------------
c
c    Calucul de la factorielle
c
c-----------------------------------------------------------
c-----Subroutine begins here--------------------------------
      integer function factoriel(n)
	integer res,n,a
	a=n
        res=1
	do while (n.GT.1)
		res=res*n
		n=n-1
	enddo
	factoriel=res
        n=a
	return
	end


module diag
implicit none
contains

!> @brief  Extract the diagnoal elements from a matrix.
subroutine diagv(M, v)
    real(8), intent(in), dimension(:, :) :: M
    integer :: i
    real(8), intent(out), dimension(size(M, 1)) :: v
    ! note: no error handling of dimension mismatch
    v = [(M(i, i), i = 1, size(M, 1))]
end subroutine

end module


module Deriv
    use Const
    use Utils
    use FuncIfaces
    use IO_array
    implicit none
    interface pder
        module procedure :: pder_vec
        module procedure :: pder_scalar
    end interface pder
contains
!----------------------------------------------------------
! pder( f, i, x0) -> val
! f   : function \R^n \to \R^n
! x_0 : initial point
!       computes i-th partial derivative at given point
!----------------------------------------------------------
    function pder_vec(f, i, x_0) result(res)
        integer, intent(in) :: i
        real(mpc), intent(in), dimension(:) :: x_0
        real(mpc), dimension(size(x_0)) :: res
        procedure (fRnRn) :: f
        integer :: n
        real(mpc), dimension(size(x_0)) :: x_1
        real(mpc) :: delta, seps

        n = size(x_0)
        if ( i > n) stop "pder: Illegal variable number"
        x_1 = x_0

        ! тут можно сказать пару слов, почему \sqrt(\eps)
        ! С одной стороны, есть погрешность ~ \delta^2 из-за разложения
        ! С другой стороны, f(x) представляется с погрешностью f(x) * \eps, так что
        !+ при делении разности на \delta погрешность будет \delta^{-1} f(x) \eps.
        ! Если пытаться уменьшить и то и то, как раз нужен \sqrt{\eps}
        seps = sqrt(eps)
        ! тут какая-то магия с точностью.
        ! Оно иногда ломается, но я не знаю как лучше (
        if (x_1(i) < 1.0_mpc) then
            delta = seps
        else
            delta = seps * x_1(i)
        end if
        x_1(i) = x_1(i) + delta
        delta = x_1(i) - x_0(i)! ещё магия

        res = ( f(x_1) - f(x_0) ) / (delta)
    end function pder_vec
    function pder_scalar(f, i, x_0) result(res)
        integer, intent(in) :: i
        real(mpc), intent(in), dimension(:) :: x_0
        real(mpc) :: res
        procedure (fRnR1) :: f
        integer :: n
        real(mpc), dimension(size(x_0)) :: x_1
        real(mpc) :: delta, seps

        n = size(x_0)
        if ( i > n) stop "pder: Illegal variable number"
        x_1 = x_0

        seps = sqrt(eps)
        if (x_1(i) < 1.0_mpc) then
            delta = seps
        else
            delta = seps * x_1(i)
        end if
        x_1(i) = x_1(i) + delta
        delta = x_1(i) - x_0(i)! ещё магия

        res = ( f(x_1) - f(x_0) ) / (delta)
    end function pder_scalar

    !-----------------------------------------------------------------------
    ! jacobimtx (f, x_0) -> J
    ! f: \R^n -> \R^n
    ! x_0: \in \R^n
    !
    ! 	computes jacobi matrix of f in x_0
    !-----------------------------------------------------------------------
    function jacobimtx(f, x_0) result(J)
        real(mpc), intent(in), dimension(:) :: x_0
        procedure (fRnRn) :: f
        real(mpc), dimension(size(x_0), size(x_0)) :: J
        integer :: n, k

        J=0

        n = size(x_0)
        do k = 1, n
            J(k, :) = pder(f, k, x_0)
        end do
        J = transpose(J)

    end function jacobimtx

    function ngrad(f,x0) result(grad)
        real(mpc), intent(in), dimension(:) :: x0
        procedure (fRnR1) :: f
        real(mpc), dimension(size(x0)) :: grad
        real(mpc) :: f_0, shiftsize
        integer :: n, k

        n = size(x0)
        shiftsize = opt_shiftsize(x0)
        f_0 = f(x0)
        do k = 1, n
            grad(k) = (f(x0 + shiftsize*unit_v(k)) - f_0) / shiftsize
        end do
        contains
            pure function unit_v(i) result(e)
                integer, intent(in) :: i
                real(mpc), dimension(size(x0)) :: e
                e = 0
                e(i) = 1.0_mpc
            end function
    end function ngrad

    function opt_shiftsize(x) result(s)
        real(mpc), intent(in), dimension(:) :: x
        real(mpc) :: s
        if (norm2(x) < 1.0_mpc) then
            s = sqrt(eps)
        else
            s = norm2(x)*sqrt(eps)
        end if
    end function opt_shiftsize

    function hess_mtx(f, x0) result(hessm)
        procedure (fRnR1) :: f
        real(mpc), intent(in), dimension(:) :: x0
        real(mpc), dimension(size(x0), size(x0)) :: hessm
        real(mpc) :: f_0, f_i, shiftsize
        integer :: n,i,j

        n = size(x0)

        shiftsize = opt_shiftsize(x0)
        f_0 = f(x0)

        do i = 1, n
            f_i = f(x0 + shiftsize*unit_v(i))
            do j = i, n
                hessm(i,j) = ( f(x0 + shiftsize*(unit_v(i) + unit_v(j))) - f_i - f(x0 + shiftsize*unit_v(j)) + f_0) / (shiftsize**2)
                hessm(j,i) = hessm(i,j)
            end do
        end do
        contains
            pure function unit_v(i) result(e)
                integer, intent(in) :: i
                real(mpc), dimension(size(x0)) :: e
                e = 0
                e(i) = 1.0_mpc
            end function
    end function hess_mtx

    function dir_deriv(f,x0,v) result(der)
        procedure (fRnRn) :: f
        real(mpc), intent(in), dimension(:) :: x0
        real(mpc), intent(in), dimension(size(x0)) :: v
        real(mpc), dimension(size(x0)) :: der
        real(mpc) :: f_0(size(x0)), shiftsize
        integer :: n,i,j

        shiftsize = opt_shiftsize(x0)
        f_0 = f(x0)
        der = (f(x0 + shiftsize*v) - f_0) / shiftsize
    end function dir_deriv
end module Deriv


      subroutine ludcmp(a,n,np,indx,d)

	implicit real*4 (a-h,o-z)

      include 'PARAMETER'  !por nmax==kn
c      parameter (nmax=100,tiny=1.0d-20)
c      dimension a(np,np),indx(n),vv(nmax)

      parameter (tiny=1.0d-20)
      dimension a(np,np),indx(n),vv(kn)

      d=1.d0

      do 12 i=1,n

        aamax=0.d0

        do 11 j=1,n

          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))

11      continue

C        if (aamax.eq.0.d0) pause 'singular matrix.'
        if (aamax.eq.0.d0) aamax=1.e-6

        vv(i)=1.d0/aamax

12    continue

      do 19 j=1,n

        if (j.gt.1) then

          do 14 i=1,j-1

            sum=a(i,j)

            if (i.gt.1)then

              do 13 k=1,i-1

                sum=sum-a(i,k)*a(k,j)

13            continue

              a(i,j)=sum

            endif

14        continue

        endif

        aamax=0.d0

        do 16 i=j,n

          sum=a(i,j)

          if (j.gt.1)then

            do 15 k=1,j-1

              sum=sum-a(i,k)*a(k,j)

15          continue

            a(i,j)=sum

          endif

          dum=vv(i)*abs(sum)

          if (dum.ge.aamax) then

            imax=i

            aamax=dum

          endif

16      continue

        if (j.ne.imax)then

          do 17 k=1,n

            dum=a(imax,k)

            a(imax,k)=a(j,k)

            a(j,k)=dum

17        continue

          d=-d

          vv(imax)=vv(j)

        endif

        indx(j)=imax

        if(j.ne.n)then

          if(a(j,j).eq.0.d0)a(j,j)=tiny

          dum=1./a(j,j)

          do 18 i=j+1,n

            a(i,j)=a(i,j)*dum

18        continue

        endif

19    continue

      if(a(n,n).eq.0.d0)a(n,n)=tiny

      return

      end


program problem28
  implicit none
  integer, parameter :: limit=1001
  integer            :: start,k,answer=1

  start=2
  do k=3,limit,2
     answer=answer+ring(start,k)
     start=start+k+k+(k-2)+(k-2)
  end do
  print *, answer

contains
  pure function ring(start,k)
    implicit none
    integer, intent(in) :: start,k
    integer             :: i,j
    integer             :: ring

    j=0
    ring=0
    do i=start+k+k+(k-2)+(k-2)-1,start,-1
       if (mod(j,k-1) == 0) then
          ring=ring+i
       end if
       j=j+1
    end do
  end function ring

end program problem28


      subroutine dcholsl(a,n,d,b,x)
c********************************************
c  Solves the n linear equations Ax=b
c  Input: A & d from DCHOLDC. Only lower triangle of A is used
c============================================
      integer n,i,k
      real*8 a(n,n),b(n),d(n),x(n),sum
      intent(in) a,b,d
      intent(out) x
c********************************************
      do i=1,n
       sum=b(i)
       do k=i-1,1,-1
        sum=sum-a(i,k)*x(k)
       enddo
       x(i)=sum/d(i)
      enddo
c------
      do i=n,1,-1
       sum=x(i)
       do k=i+1,n
        sum=sum-a(k,i)*x(k)
       enddo
       x(i)=sum/d(i)
      enddo
c------
      return
      end


*DECK COMLR
      SUBROUTINE COMLR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR)
C***BEGIN PROLOGUE  COMLR
C***PURPOSE  Compute the eigenvalues of a complex upper Hessenberg
C            matrix using the modified LR method.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      COMPLEX (COMLR-C)
C***KEYWORDS  EIGENVALUES, EISPACK, LR METHOD
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure COMLR,
C     NUM. MATH. 12, 369-376(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C
C     This subroutine finds the eigenvalues of a COMPLEX
C     UPPER Hessenberg matrix by the modified LR method.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, HR and HI, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix, N.
C
C        HR and HI contain the real and imaginary parts, respectively,
C          of the complex upper Hessenberg matrix.  Their lower
C          triangles below the subdiagonal contain the multipliers
C          which were used in the reduction by  COMHES, if performed.
C          HR and HI are two-dimensional REAL arrays, dimensioned
C          HR(NM,N) and HI(NM,N).
C
C     On OUTPUT
C
C        The upper Hessenberg portions of HR and HI have been
C          destroyed.  Therefore, they must be saved before calling
C          COMLR  if subsequent calculation of eigenvectors is to
C          be performed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues of the upper Hessenberg matrix.  If an
C          error exit is made, the eigenvalues should be correct for
C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N.
C
C     Calls CSROOT for complex square root.
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV, CSROOT
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COMLR
C
      INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR
      REAL HR(NM,*),HI(NM,*),WR(*),WI(*)
      REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,S1,S2
C
C***FIRST EXECUTABLE STATEMENT  COMLR
      IERR = 0
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
      DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0E0
      TI = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW E0 -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     1             + ABS(HR(L,L)) + ABS(HI(L,L))
         S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1))
         IF (S2 .EQ. S1) GO TO 300
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
      XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0E0
      YI = (HI(ENM1,ENM1) - SI) / 2.0E0
      CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2))
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS ..........
      XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1))
      YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1))
      ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN))
C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
      DO 380 MM = L, ENM1
         M = ENM1 + L - MM
         IF (M .EQ. L) GO TO 420
         YI = YR
         YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1))
         XI = ZZR
         ZZR = XR
         XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1))
         S1 = ZZR / YI * (ZZR + XR + XI)
         S2 = S1 + YR
         IF (S2 .EQ. S1) GO TO 420
  380 CONTINUE
C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  420 MP1 = M + 1
C
      DO 520 I = MP1, EN
         IM1 = I - 1
         XR = HR(IM1,IM1)
         XI = HI(IM1,IM1)
         YR = HR(I,IM1)
         YI = HI(I,IM1)
         IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460
C     .......... INTERCHANGE ROWS OF HR AND HI ..........
         DO 440 J = IM1, EN
            ZZR = HR(IM1,J)
            HR(IM1,J) = HR(I,J)
            HR(I,J) = ZZR
            ZZI = HI(IM1,J)
            HI(IM1,J) = HI(I,J)
            HI(I,J) = ZZI
  440    CONTINUE
C
         CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
         WR(I) = 1.0E0
         GO TO 480
  460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
         WR(I) = -1.0E0
  480    HR(I,IM1) = ZZR
         HI(I,IM1) = ZZI
C
         DO 500 J = I, EN
            HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
            HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  500    CONTINUE
C
  520 CONTINUE
C     .......... COMPOSITION R*L=H ..........
      DO 640 J = MP1, EN
         XR = HR(J,J-1)
         XI = HI(J,J-1)
         HR(J,J-1) = 0.0E0
         HI(J,J-1) = 0.0E0
C     .......... INTERCHANGE COLUMNS OF HR AND HI,
C                IF NECESSARY ..........
         IF (WR(J) .LE. 0.0E0) GO TO 580
C
         DO 540 I = L, J
            ZZR = HR(I,J-1)
            HR(I,J-1) = HR(I,J)
            HR(I,J) = ZZR
            ZZI = HI(I,J-1)
            HI(I,J-1) = HI(I,J)
            HI(I,J) = ZZI
  540    CONTINUE
C
  580    DO 600 I = L, J
            HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
            HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  600    CONTINUE
C
  640 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 WR(EN) = HR(EN,EN) + TR
      WI(EN) = HI(EN,EN) + TI
      EN = ENM1
      GO TO 220
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END