!
!
! fast_iterator.f90 - Example of fortran module to be called by Python
!
!
! Autor: Pedro Garcia Freitas [sawp@sawp.com.br]
! License: Creative Commons
!      <http://creativecommons.org/licenses/by-nc-nd/2.5/br/>
!
! see: http://www.sawp.com.br
!
! Sep 2011
!

module halftone
  implicit none
  real, dimension(0:9), parameter, private :: shiaufan_factors = &
    (/  0., 0., 0.53333333, 0., 0., 0.06666667, 0.13333333, 0.26666667, 0., 0./)
  real, dimension(0:11), parameter, private :: atkinson_factors = &
    (/ 0.125, 0.125, 0.0, 0.125, 0.125, 0.125, 0.0, 0.0, 0.0, 0.125, 0.0, 0.0 /)
  real, dimension(0:6), parameter, private :: sierra2_factors = &
    (/ 0.25, 0.1875, 0.0625, 0.125, 0.1875, 0.125, 0.0625 /)
  real, dimension(0:11), parameter, private :: sierra3_factors = &
    (/ 0.15625, 0.09375, 0.0625, 0.125, 0.15625, 0.125, 0.0625, &
       0.0, 0.0625, 0.09375, 0.0625, 0.0 /)
  real, dimension(0:6), parameter, private :: burkes_factors = &
    (/ 0.25, 0.125, 0.0625, 0.125, 0.25, 0.125, 0.0625 /)
  real, dimension(0:11), parameter, private :: stucki_factors = &
    (/ 0.19047619,  0.0952381, 0.04761905,  0.0952381 ,  0.19047619, &
       0.0952381 ,  0.04761905, 0.02380952,  0.04761905,  0.0952381, &
       0.04761905,  0.02380952 /)
  real, dimension(0:11), parameter, private :: jarvis_factors = &
    (/ 0.10417, 0.14583, 0.0625, 0.10417, 0.14583, 0.10417, 0.0625, &
    0.02083, 0.0625, 0.10417, 0.0625, 0.02083 /)
  real, dimension(0:3), parameter, private :: floyd_factors = &
    (/ 0.4374, 0.1875,  0.3125,  0.0625 /)
  real, dimension(0:3), parameter, private :: sierra24A_factors = &
    (/ 0.5, 0.25, 0.25, 0.0 /)
  real, parameter, private :: threshold = 127.5
  contains
    subroutine shiaufan_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, colm1, colm2, colp3, colm3
      real    :: error
      real, dimension(0:11) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 1
      cols = n - 6
      tmp = matrix

      do row = 0, rows - 1
        do col = 3, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:9) = (/ (error * shiaufan_factors(i), i=0, 9) /)
          colp3 = col + 3
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          colm1 = col - 1
          colm2 = col - 2
          colm3 = col - 3
          tmp(row, colp3) =  diff_error(0) + tmp(row, colp3)
          tmp(row, colp2) =  diff_error(1) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(2) + tmp(row, colp1)
          tmp(rowp1, colp3) =  diff_error(3) + tmp(rowp1, colp3)
          tmp(rowp1, colp2) =  diff_error(4) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(5) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(6) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(7) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(8) + tmp(rowp1, colm2)
          tmp(rowp1, colm3) =  diff_error(9) + tmp(rowp1, colm3)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine shiaufan_iterator

    subroutine atkinson_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, rowp2, colm1, colm2
      real    :: error
      real, dimension(0:11) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 2
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:11) = (/ (error * atkinson_factors(i), i=0, 11) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          rowp2 = row + 2
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
          tmp(rowp2, colp2) =  diff_error(7) + tmp(rowp2, colp2)
          tmp(rowp2, colp1) =  diff_error(8) + tmp(rowp2, colp1)
          tmp(rowp2, col) =  diff_error(9) + tmp(rowp2, col)
          tmp(rowp2, colm1) =  diff_error(10) + tmp(rowp2, colm1)
          tmp(rowp2, colm2) =  diff_error(11) + tmp(rowp2, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine atkinson_iterator

    subroutine sierra24a_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-2, 0:n-3), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, rowp1, colm1
      real    :: error
      real, dimension(0:3) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 1
      cols = n - 2
      tmp = matrix
      do row = 0, rows - 1
        do col = 1, cols
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          !print *, row, col, n, m
          error = tmp(row, col) - dithered(row, col)
          diff_error(0:3) = (/ (error * sierra24A_factors(i), i=0, 3) /)
          colp1 = col + 1
          rowp1 = row + 1
          colm1 = col - 1
          tmp(row, colp1) =  diff_error(0) + tmp(row, colp1)
          tmp(rowp1, colp1) =  diff_error(1) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(2) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(3) + tmp(rowp1, colm1)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine sierra24a_iterator

    subroutine sierra2_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, colm1, colm2
      real    :: error
      real, dimension(0:6) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 1
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:6) = (/ (error * sierra2_factors(i), i=0, 6) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine sierra2_iterator

    subroutine sierra3_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, rowp2, colm1, colm2
      real    :: error
      real, dimension(0:11) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 2
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:11) = (/ (error * sierra3_factors(i), i=0, 11) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          rowp2 = row + 2
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
          tmp(rowp2, colp2) =  diff_error(7) + tmp(rowp2, colp2)
          tmp(rowp2, colp1) =  diff_error(8) + tmp(rowp2, colp1)
          tmp(rowp2, col) =  diff_error(9) + tmp(rowp2, col)
          tmp(rowp2, colm1) =  diff_error(10) + tmp(rowp2, colm1)
          tmp(rowp2, colm2) =  diff_error(11) + tmp(rowp2, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine sierra3_iterator

    subroutine burkes_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, colm1, colm2
      real    :: error
      real, dimension(0:6) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 1
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:6) = (/ (error * burkes_factors(i), i=0, 6) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols+1)
    end subroutine burkes_iterator

    subroutine stucki_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, rowp2, colm1, colm2
      real    :: error
      real, dimension(0:11) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 2
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:11) = (/ (error * stucki_factors(i), i=0, 11) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          rowp2 = row + 2
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
          tmp(rowp2, colp2) =  diff_error(7) + tmp(rowp2, colp2)
          tmp(rowp2, colp1) =  diff_error(8) + tmp(rowp2, colp1)
          tmp(rowp2, col) =  diff_error(9) + tmp(rowp2, col)
          tmp(rowp2, colm1) =  diff_error(10) + tmp(rowp2, colm1)
          tmp(rowp2, colm2) =  diff_error(11) + tmp(rowp2, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine stucki_iterator

    subroutine floyd_steinberg_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-2, 0:n-3), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, rowp1, colm1
      real    :: error
      real, dimension(0:3) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 1
      cols = n - 2
      tmp = matrix
      do row = 0, rows - 1
        do col = 1, cols
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          !print *, row, col, n, m
          error = tmp(row, col) - dithered(row, col)
          diff_error(0:3) = (/ (error * floyd_factors(i), i=0, 3) /)
          colp1 = col + 1
          rowp1 = row + 1
          colm1 = col - 1
          tmp(row, colp1) =  diff_error(0) + tmp(row, colp1)
          tmp(rowp1, colp1) =  diff_error(1) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(2) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(3) + tmp(rowp1, colm1)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine floyd_steinberg_iterator

    subroutine jarvis_iterator(matrix, m, n, returnParam)
      integer, intent(in) :: n, m
      real, dimension(0:m-1, 0:n-1), intent(in) :: matrix
      real, dimension(0:m-3, 0:n-5), intent(out) :: returnParam

      integer :: rows
      integer :: cols
      integer :: row, col, i
      integer colp1, colp2, rowp1, rowp2, colm1, colm2
      real    :: error
      real, dimension(0:11) :: diff_error
      integer, dimension(0:m-1, 0:n-1) :: dithered
      real, dimension(0:m-1, 0:n-1) :: tmp

      rows = m - 2
      cols = n - 4
      tmp = matrix

      do row = 0, rows - 1
        do col = 2, cols + 1
          if (tmp(row, col) >= threshold) then
            dithered(row,col) = 255
          else
            dithered(row,col) = 0
          end if
          error = - dithered(row, col) + tmp(row, col)
          diff_error(0:11) = (/ (error * jarvis_factors(i), i=0, 11) /)
          colp2 = col + 2
          colp1 = col + 1
          rowp1 = row + 1
          rowp2 = row + 2
          colm1 = col - 1
          colm2 = col - 2
          tmp(row, colp2) =  diff_error(0) + tmp(row, colp2)
          tmp(row, colp1) =  diff_error(1) + tmp(row, colp1)
          tmp(rowp1, colp2) =  diff_error(2) + tmp(rowp1, colp2)
          tmp(rowp1, colp1) =  diff_error(3) + tmp(rowp1, colp1)
          tmp(rowp1, col) =  diff_error(4) + tmp(rowp1, col)
          tmp(rowp1, colm1) =  diff_error(5) + tmp(rowp1, colm1)
          tmp(rowp1, colm2) =  diff_error(6) + tmp(rowp1, colm2)
          tmp(rowp2, colp2) =  diff_error(7) + tmp(rowp2, colp2)
          tmp(rowp2, colp1) =  diff_error(8) + tmp(rowp2, colp1)
          tmp(rowp2, col) =  diff_error(9) + tmp(rowp2, col)
          tmp(rowp2, colm1) =  diff_error(10) + tmp(rowp2, colm1)
          tmp(rowp2, colm2) =  diff_error(11) + tmp(rowp2, colm2)
        end do
      end do
      returnParam = dithered(0:rows-1, 2:cols + 1)
    end subroutine jarvis_iterator

    subroutine ordered_dithering3x3(quantized, h, l, returnParam)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: quantized
      integer, dimension(0:3*h-1, 0:3*l-1), intent(out) :: returnParam

      integer, dimension(3,3) :: selectedLevel
      integer :: i, j, k, r, xs, xf, ys, yf
      integer level

      k = 0
      r = 0

      do i = 0, h-1
        do j = 0, l-1
          level = quantized(i,j)
          select case (level)
            case (1)
              selectedLevel(1,:) = (/ 0, 0, 0 /)
              selectedLevel(2,:) = (/ 0, 0, 0 /)
              selectedLevel(3,:) = (/ 0, 0, 0 /)
            case (2)
              selectedLevel(1,:) = (/ 0, 0, 0 /)
              selectedLevel(2,:) = (/ 0, 1, 0 /)
              selectedLevel(3,:) = (/ 0, 0, 0 /)
            case(3)
              selectedLevel(1,:) = (/ 0, 0, 0 /)
              selectedLevel(2,:) = (/ 1, 1, 0 /)
              selectedLevel(3,:) = (/ 0, 0, 0 /)
            case (4)
              selectedLevel(1,:) = (/ 0, 0, 0 /)
              selectedLevel(2,:) = (/ 1, 1, 0 /)
              selectedLevel(3,:) = (/ 0, 1, 0 /)
            case (5)
              selectedLevel(1,:) = (/ 0, 0, 0 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 0, 1, 0 /)
            case(6)
              selectedLevel(1,:) = (/ 0, 0, 1 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 1, 0, 1 /)
            case (7)
              selectedLevel(1,:) = (/ 0, 0, 1 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 1, 1, 0 /)
            case (8)
              selectedLevel(1,:) = (/ 1, 0, 1 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 1, 1, 0 /)
            case (9)
              selectedLevel(1,:) = (/ 1, 0, 1 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 1, 1, 1 /)
            case default
              selectedLevel(1,:) = (/ 1, 1, 1 /)
              selectedLevel(2,:) = (/ 1, 1, 1 /)
              selectedLevel(3,:) = (/ 1, 1, 1 /)
          end select
          xs = i + k
          xf = xs + 3
          ys = j + r
          yf = ys + 3
          returnParam(xs:xf, ys:yf) = selectedLevel
          r = r + 2
        end do
          r = 0
          k = k + 2
      end do
    end subroutine ordered_dithering3x3

    subroutine ordered_comb4_iterator(masked, h, l, binary)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: masked
      integer, dimension(0:h-1, 0:4*l-1), intent(out) :: binary

      integer :: i, j, r
      integer, dimension(0:15, 4) :: level

      level(0, :) = (/ 0, 0, 0, 0 /)
      level(1, :) = (/ 0, 0, 0, 1 /)
      level(2, :) = (/ 0, 0, 1, 0 /)
      level(3, :) = (/ 0, 0, 1, 1 /)
      level(4, :) = (/ 0, 1, 0, 0 /)
      level(5, :) = (/ 0, 1, 0, 1 /)
      level(6, :) = (/ 0, 1, 1, 0 /)
      level(7, :) = (/ 0, 1, 1, 1 /)
      level(8, :) = (/ 1, 0, 0, 0 /)
      level(9, :) = (/ 1, 0, 0, 1 /)
      level(10, :) = (/ 1, 0, 1, 0 /)
      level(11, :) = (/ 1, 0, 1, 1 /)
      level(12, :) = (/ 1, 1, 0, 0 /)
      level(13, :) = (/ 1, 1, 0, 1 /)
      level(14, :) = (/ 1, 1, 1, 0 /)
      level(15, :) = (/ 1, 1, 1, 1 /)

      do i = 0, h - 1
        r = 0
        do j = 0, l - 1
          binary(i, j+r:j+r+3) = level(masked(i, j), :)
          r = r + 3
        end do
      end do
    end subroutine ordered_comb4_iterator

    subroutine ordered_comb2_iterator(masked, h, l, returnParam)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: masked
      integer, dimension(0:h-1, 0:2*l-1), intent(out) :: returnParam

      integer :: i, j, r
      integer, dimension(0:3, 2) :: level
      integer, dimension(0:h-1, 0:2*l-1) :: binary

      level(0, :) = (/ 0, 0 /)
      level(1, :) = (/ 0, 1 /)
      level(2, :) = (/ 1, 0 /)
      level(3, :) = (/ 1, 1 /)
      do i = 0, h - 1
        r = 0
        do j = 0, l - 1
          binary(i, j+r:j+r+1) = level(masked(i, j), :)
          r = r + 1
        end do
      end do
      returnParam = binary
    end subroutine ordered_comb2_iterator

    subroutine ordered_comb3_iterator(masked, h, l, returnParam)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: masked
      integer, dimension(0:h-1, 0:3*l-1), intent(out) :: returnParam

      integer :: i, j, r
      integer, dimension(0:7, 3) :: level
      integer, dimension(0:h-1, 0:3*l-1) :: binary

      level(0, :) = (/ 0, 0, 0 /)
      level(1, :) = (/ 0, 0, 1 /)
      level(2, :) = (/ 0, 1, 0 /)
      level(3, :) = (/ 0, 1, 1 /)
      level(4, :) = (/ 1, 0, 0 /)
      level(5, :) = (/ 1, 0, 1 /)
      level(6, :) = (/ 1, 1, 0 /)
      level(7, :) = (/ 1, 1, 1 /)
      do i = 0, h - 1
        r = 0
        do j = 0, l - 1
          binary(i, j+r:j+r+2) = level(masked(i, j), :)
          r = r + 2
        end do
      end do
      returnParam = binary
    end subroutine ordered_comb3_iterator
end module halftone

module inverse_halftone
  implicit none

  contains
    subroutine inverse_ordered_comb2_iterator(binary, h, l, returnParam)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: binary
      integer, dimension(0:h-1, 0:l/2-1), intent(out) :: returnParam

      integer :: i, j, m
      integer ::  selectedLevel, x
      integer, dimension(0:3, 0:1) :: level
      integer, dimension(0:h-1, 0:l/2-1) :: restored
      real :: top, base, color, intervalsize

      level(0, :) = (/ 0, 0/)
      level(1, :) = (/ 0, 1 /)
      level(2, :) = (/ 1, 0 /)
      level(3, :) = (/ 1, 1 /)
      intervalsize = 255.0 / 4.0
      do i = 0, h - 1
        do j = 0, l - 1, 2
          do x = 0, 3
            selectedLevel = 0
            do m = 0, 1
              if (binary(i, j + m) == level(x, m)) then
                selectedLevel = selectedLevel + 1
              end if
            end do
            if (selectedLevel == 2) then
              selectedLevel = x
              exit
            end if
          end do
          base = selectedLevel * intervalsize
          top = base + intervalsize
          color = base + (top - base) * rand()
          restored(i, j / 2) = int(color)
        end do
      end do
      returnParam = restored
    end subroutine inverse_ordered_comb2_iterator

    subroutine inverse_ordered_comb3_iterator(binary, h, l, returnParam)
      implicit none
      integer, intent(in) :: h, l
      integer, dimension(0:h-1, 0:l-1), intent(in) :: binary
      integer, dimension(0:h-1, 0:l/3-1), intent(out) :: returnParam

      integer :: i, j, m
      integer ::  selectedLevel, x
      integer, dimension(0:7, 0:2) :: level
      integer, dimension(0:h-1, 0:l/3-1) :: restored
      real :: top, base, color, intervalsize

      level(0, :) = (/ 0, 0, 0 /)
      level(1, :) = (/ 0, 0, 1 /)
      level(2, :) = (/ 0, 1, 0 /)
      level(3, :) = (/ 0, 1, 1 /)
      level(4, :) = (/ 1, 0, 0 /)
      level(5, :) = (/ 1, 0, 1 /)
      level(6, :) = (/ 1, 1, 0 /)
      level(7, :) = (/ 1, 1, 1 /)
      intervalsize = 255.0 / 8.0
      do i = 0, h - 1
        do j = 0, l - 1, 3
          do x = 0, 7
            selectedLevel = 0
            do m = 0, 2
              if (binary(i, j + m) == level(x, m)) then
                selectedLevel = selectedLevel + 1
              end if
            end do
            if (selectedLevel == 3) then
              selectedLevel = x
              exit
            end if
          end do
          base = selectedLevel * intervalsize
          top = base + intervalsize
          color = base + (top - base) * rand()
          restored(i, j / 3) = int(color)
        end do
      end do
      returnParam = restored
    end subroutine inverse_ordered_comb3_iterator

    subroutine inverse_ordered_dithering_iterator(bin, h, l, msize, returnp)
      implicit none
      integer, intent(in) :: h, l, msize
      integer, dimension(0:h-1, 0:l-1), intent(in) :: bin
      integer, dimension(0:h/msize, 0:l/msize), intent(out) :: returnp

      integer :: i=0, j=0, stepx=0, stepy=0
      integer :: chosedLevel
      integer, dimension(0:h+msize-1, 0:l+msize-1) :: tmp
      integer, dimension(msize, msize) :: mask
      real :: intervalSize, base, top, greyValue

      intervalsize = 255.0 / (msize * msize)
      tmp(0:h-1, 0:l-1) = bin
      do i = 0, msize - 1
        tmp(h + i, :) = 0
        tmp(:, l+i) = 0
      end do

      do i = 0, h/msize-1
        do j = 0, l/msize-1
          mask(:,:) = tmp(stepx+i:stepx+i+msize, stepy+j:stepy+j+msize)
          chosedLevel = sum(mask) - 1
          base = chosedLevel * intervalsize
          top = base + intervalsize
          greyValue = base + (top - base) * rand()
          returnp(i,j) = int(greyValue)
          stepy = stepy + msize - 1
        end do
        stepy = 0
        stepx = stepx + msize - 1
      end do
    end subroutine inverse_ordered_dithering_iterator
end module inverse_halftone

module fbih
  implicit none
  real, parameter, private :: DEBLUR_FACTOR = 1.5d0
  real, parameter, private :: NORM = 100000000
  real, parameter, private :: THRESHOLD_DIFF = 0
  real, parameter, private :: ERRTO = 0.25
  integer, parameter, private :: TRUE = 1
  integer, parameter, private :: FALSE = 0

  contains
    subroutine inverse_halftone(im, rows, cols, returnParam)
      implicit none
      integer, intent(in) :: rows, cols
      integer, dimension(0:rows-1, 0:cols-1), intent(in) :: im
      integer, dimension(0:rows-1, 0:cols-1), intent(out) :: returnParam

      integer :: i, j
      real, dimension(0:rows-1, 0:cols-1) :: inputImage
      real, dimension(0:rows-1, 0:cols-1) :: gaussianLvlOne
      real, dimension(0:rows-1, 0:cols-1) :: median
      real, dimension(0:rows-1, 0:cols-1) :: gaussianLvlTwo
      real, dimension(0:rows-1, 0:cols-1) :: gaussianLvlThree
      real, dimension(0:rows-1, 0:cols-1) :: quantiz

      do i = 0, rows-1
        do j = 0, cols - 1
          inputImage(i, j) = float(im(i, j))
        end do
      end do
      call GaussianFilter1(rows, cols, inputImage, gaussianLvlOne)
      call medianFilter3by3(rows, cols, gaussianLvlOne, median)
      call GaussianFilter2(rows, cols, median, gaussianLvlTwo)
      call GaussianFilter3(rows, cols, gaussianLvlTwo, gaussianLvlThree)
      call thresholdDiff(rows, cols, gaussianLvlTwo, gaussianLvlThree, quantiz)
      call normalise(rows, cols, quantiz, median, returnParam)
    end subroutine inverse_halftone

    subroutine medianFilter3by3(rows, cols, img, output)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: img
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: output

      integer :: row, col
      integer :: lastRow, lastCol, nextRow, nextCol
      real :: block(0:9)

      do row = 0, rows-1
        do col = 0, cols-1
          lastRow = abs(row - 1)
          lastCol = abs(col - 1)
          nextRow = abs(row + 1)
          nextCol = abs(col + 1)
          block(1) = img(lastRow, lastCol)
          block(2) = img(lastRow, col)
          if (nextCol >= cols) then
            block(3) = img(lastRow, 2 * cols - nextCol - 2)
            block(6) = img(row, 2 * cols - nextCol - 2)
          else
            block(3) = img(lastRow, nextCol)
            block(6) = img(row, nextCol)
          end if
          block(4) = img(row, lastCol)
          block(5) = img(row, col)
          if (nextRow >= rows) then
            block(7) = img(2 * rows - nextRow - 2, lastCol)
            block(8) = img(2 * rows - nextRow - 2, col)
          else
            block(7) = img(nextRow, nextCol)
            block(8) = img(nextRow, col)
          end if
          if (nextRow >= rows .and. nextCol >= cols) then
            block(9) = img(2 * rows - nextRow - 2, 2 * cols - nextCol - 2)
          end if
          if (nextRow >= rows .and. nextCol < cols) then
            block(9) = img(2 * rows - nextRow - 2, nextCol)
          end if
          if (nextRow < rows .and. nextCol >= cols) then
            block(9) = img(nextRow, 2 * cols - nextCol - 2)
          end if
          if (nextRow < rows .and. nextCol < cols) then
            block(9) = img(nextRow, nextCol)
          end if
          output(row, col) = getPixel(5, 9, block)
        end do
      end do
    end subroutine medianFilter3by3

    subroutine SWAP(a, b)
      implicit none
      real, intent(inout) :: a, b
      real :: temp
      temp = a
      a = b
      b = temp
    end subroutine SWAP

    real function getPixel(pos, blocksize, blk)
      implicit none
      integer, intent(in) :: pos
      integer, intent(in) :: blocksize
      real, dimension(blocksize), intent(in) :: blk

      integer :: i, j, l, mid, ir
      real :: temp, selected
      real, dimension(blocksize) :: block
      integer, save :: s = 0

      s = s + 1

      i = 0
      j = 0
      mid = 0
      temp = 0.0
      l = 1
      ir = blocksize
      block(:) = blk(:)
      do
        if (ir <= l + 1) then
          if (ir == l + 1 .and. block(ir) < block(l)) then
            call SWAP(block(ir), block(l))
          end if
          exit
        else
          i = l + 1
          j = ir
          mid = int((l + ir) / 2)
          call SWAP(block(l+1), block(mid))
          if (block(l) > block(ir)) then
            call SWAP(block(ir), block(l))
          end if
          if (block(l+1) > block(ir)) then
            call SWAP(block(ir), block(l+1))
          end if
          if (block(l) > block(l+1)) then
            call SWAP(block(l), block(l+1))
          end if
          selected = block(l+1)
          do
            do
              i = i + 1
              if (block(i) >= selected) exit
            end do
            do
              j = j - 1
              if (block(j) <= selected) exit
            end do
            if (j < i) exit
            call SWAP(block(j), block(i))
          end do
          block(l+1) = block(j)
          block(j) = selected
          if (j >= pos) then
            ir = j - 1
          end if
          if (j <= pos) then
            l = i
          end if
        end if
      end do
      getPixel = block(pos)
      return
    end function getPixel

    subroutine GaussianFilter1(m, n, s, output)
      implicit none
      integer, intent(in) :: m, n
      real, dimension(0:m-1, 0:n-1), intent(in) :: s
      real, dimension(0:m-1, 0:n-1), intent(out) :: output
      integer, dimension(9) :: filter = &
        (/ 11, 135, 808, 2359, 3372, 2359, 808, 135, 11 /)
      call separable9x9FIRBinaryImage(m, n, s, filter, output)
    end subroutine GaussianFilter1

    subroutine separable9x9FIRBinaryImage(rows, cols, source, filter, dest)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: source
      integer, dimension(9), intent(in) :: filter
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: dest

      real, dimension(0:rows-1, 0:cols-1) :: ws

      call rowConvolutions9by9(rows, cols, source, filter, ws)
      call columnConvolutions9by9(rows, cols, ws, filter, dest)
    end subroutine separable9x9FIRBinaryImage

    subroutine rowConvolutions9by9(rows, cols, src, filter, ws)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: src
      integer, dimension(9), intent(in) :: filter
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: ws

      integer :: i, j, k
      integer, dimension(9) :: p
      real :: sums
      real, dimension(cols) :: sourceRow

      do i = 0, rows-1
        sourceRow(:) = src(i, :)
        do j = 0, cols-1
          sums = 0.0
          p(1) = j - 4
          p(2) = j - 3
          p(3) = j - 2
          p(4) = j - 1
          p(5) = j
          p(6) = j + 1
          p(7) = j + 2
          p(8) = j + 3
          p(9) = j + 4
          p(1) = abs(p(1))
          p(2) = abs(p(2))
          p(3) = abs(p(3))
          p(4) = abs(p(4))
          p(6) = reflect(p(6), cols)
          p(7) = reflect(p(7), cols)
          p(8) = reflect(p(8), cols)
          p(9) = reflect(p(9), cols)
          do k = 1, 9
            if (sourceRow(p(k)) /= 0) then
              sums = sums + filter(k)
            end if
          end do
          ws(i, j) = 255 * sums
        end do
      end do
    end subroutine rowConvolutions9by9

    subroutine columnConvolutions9by9(rows, cols, src, filter, dest)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: src
      integer, dimension(9), intent(in) :: filter
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: dest

      integer :: i, j
      integer, dimension(9) :: p
      real :: sums

      p = 0
      do j = 0, cols-1
        do i = 0, rows-1
          sums = 0.0
          p(1) = i - 4
          p(2) = i - 3
          p(3) = i - 2
          p(4) = i - 1
          p(5) = i
          p(6) = i + 1
          p(7) = i + 2
          p(8) = i + 3
          p(9) = i + 4
          p(1) = abs(p(1))
          p(2) = abs(p(2))
          p(3) = abs(p(3))
          p(4) = abs(p(4))
          p(6) = reflect(p(6), rows)
          p(7) = reflect(p(7), rows)
          p(8) = reflect(p(8), rows)
          p(9) = reflect(p(9), rows)
          sums = filter(5) * src(i, j)
          sums = sums + filter(1) * (src(p(1), j) + src(p(9), j))
          sums = sums + filter(2) * (src(p(2), j) + src(p(8), j))
          sums = sums + filter(3) * (src(p(3), j) + src(p(7), j))
          sums = sums + filter(4) * (src(p(4), j) + src(p(6), j))
          dest(i, j) = sums / NORM + ERRTO
        end do
      end do
    end subroutine columnConvolutions9by9

    subroutine GaussianFilter2(m, n, s, dest)
      implicit none
      integer, intent(in) :: m, n
      real, dimension(0:m-1, 0:n-1), intent(in) :: s
      real, dimension(0:m-1, 0:n-1), intent(out) :: dest
      integer, dimension(7) :: filter = &
        (/ 44, 540, 2420, 3991, 2420, 540, 44 /)
      call separable7x7FIRGreyImage(m, n, s, filter, dest)
    end subroutine GaussianFilter2

    subroutine GaussianFilter3(m, n, s, dest)
      implicit none
      integer, intent(in) :: m, n
      real, dimension(0:m-1, 0:n-1), intent(in) :: s
      real, dimension(0:m-1, 0:n-1), intent(out) :: dest
      integer, dimension(7) :: filter = &
        (/ 1, 103, 2075, 5641, 2075, 103, 1 /)
      call separable7x7FIRGreyImage(m, n, s, filter, dest)
    end subroutine GaussianFilter3

    subroutine separable7x7FIRGreyImage(rows, cols, source, filter, dest)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: source
      integer, dimension(7), intent(in) :: filter
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: dest

      integer :: i, j
      real, dimension(0:rows-1, 0:cols-1) :: ws
      real, dimension(0:cols-1) :: sourceRow
      integer :: p2, p3, p4, p6, p7, p8

      do i = 0, rows-1
        sourceRow = source(i,:)
        do j = 0, cols-1
          p2 = j - 3
          p3 = j - 2
          p4 = j - 1
          p6 = j + 1
          p7 = j + 2
          p8 = j + 3
          p2 = abs(p2)
          p3 = abs(p3)
          p4 = abs(p4)
          p6 = reflect(p6, cols)
          p7 = reflect(p7, cols)
          p8 = reflect(p8, cols)
          ws(i, j) = filter(4) * sourceRow(j)
          ws (i, j) = ws(i, j) + filter(1) * (sourceRow(p2) + sourceRow(p8))
          ws (i, j) = ws(i, j) + filter(2) * (sourceRow(p3) + sourceRow(p7))
          ws (i, j) = ws(i, j) + filter(3) * (sourceRow(p4) + sourceRow(p6))
        end do
      end do
      call columnConvolutions7by7(rows, cols, ws, filter, dest)
    end subroutine separable7x7FIRGreyImage

    subroutine columnConvolutions7by7(rows, cols, src, filter, dest)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: src
      integer, dimension(7), intent(in) :: filter
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: dest

      integer :: i, j
      integer :: p2, p3, p4, p6, p7, p8
      real :: sums

      do j = 0, cols-1
        do i = 0, rows-1
          p2 = i - 3
          p3 = i - 2
          p4 = i - 1
          p6 = i + 1
          p7 = i + 2
          p8 = i + 3
          p2 = abs(p2)
          p3 = abs(p3)
          p4 = abs(p4)
          p6 = reflect(p6, rows)
          p7 = reflect(p7, rows)
          p8 = reflect(p8, rows)
          sums = filter(4) * src(i,j)
          sums = sums + filter(1) * (src(p2, j) + src(p8, j))
          sums = sums + filter(2) * (src(p3, j) + src(p7, j))
          sums = sums + filter(3) * (src(p4, j) + src(p6, j))
          dest(i, j) = real(int(sums / NORM + ERRTO))
        end do
      end do
    end subroutine columnConvolutions7by7

    integer function reflect(x, y)
      implicit none
      integer, intent(in) :: x, y
      if (x >= y) then
        reflect = 2 * y - x - 2
      else
        reflect = x
      end if
    end function

    subroutine thresholdDiff(rows, cols, xi, zi, hie)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: xi, zi
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: hie

      real, dimension(0:rows-1, 0:cols-1) :: x, z
      real, dimension(0:rows-1, 0:cols-1) :: edgeMap
      real :: pixel
      integer :: i, j

      x(:,:) = xi(:,:)
      z(:,:) = zi(:,:)
      call binaryMedialFilter5by5(rows, cols, z, edgeMap)

      do i = 0, rows-1
        do j = 0, cols-1
          pixel = x(i, j) - z(i, j)
          if (pixel <= THRESHOLD_DIFF .and. pixel >= -THRESHOLD_DIFF) then
            z(i, j) = 0.0
          else
            z(i, j) = 1.0
          end if
          hie(i,j) = pixel
        end do
      end do
      do i = 0, rows-1
        do j = 0, cols-1
          hie(i, j) = hie(i, j) * z(i, j) * edgeMap(i, j)
        end do
      end do
    end subroutine thresholdDiff

    subroutine binaryMedialFilter5by5(rows, cols, img, filtered)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: img
      real, dimension(0:rows-1, 0:cols-1), intent(out) :: filtered

      integer :: row, col
      integer :: ones
      integer, parameter :: threshold = 12

      do row = 0, rows-1
        do col = 0, cols-1
          ones = bitBlockCounter(rows, cols, row, col, img)
          if (ones > threshold) then
            filtered(row, col) = 1.0
          else
            filtered(row, col) = 0.0
          end if
        end do
      end do
    end subroutine binaryMedialFilter5by5

    integer function bitBlockCounter(rows, cols, row, col, img)
      implicit none
      integer, intent(in) :: row, col, rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: img

      integer :: countOnes, blockX, blockY, r, c
      integer, parameter :: blocksize = 4
      integer, parameter :: threshold = 12

      countOnes = 0
      do blockX = 0, blocksize
        r = row - blockX
        do blockY = 0, blocksize
          c = col - blockY
          if (r >= 0 .and. c >= 0) then
            if (img(r, c) > 0) then
              countOnes = countOnes + 1
            end if
            if (countOnes > threshold) then
              exit
            end if
          end if
        end do
        if (countOnes > threshold) then
          exit
        end if
      end do
      bitBlockCounter = countOnes
    end function bitBlockCounter

    subroutine normalise(rows, cols, hie, y1, outputImage)
      implicit none
      integer, intent(in) :: rows, cols
      real, dimension(0:rows-1, 0:cols-1), intent(in) :: hie, y1
      integer, dimension(0:rows-1, 0:cols-1), intent(out) :: outputImage

      integer :: i, j
      real :: outputValue

      do i = 0, rows-1
        do j = 0, cols-1
          outputValue = ERRTO
          outputValue = outputValue + DEBLUR_FACTOR * (hie(i, j) + y1(i, j))
          outputImage(i, j) = int(outputValue)
        end do
      end do
    end subroutine normalise
end module fbih


real, dimension(5)      ::      x=(/1.,2.,3.,4.,5./)
real					::      m

call median(x,5,m)
write(*,*)'m=',m

end


      SUBROUTINE TAVISPAK(KREQMT,ELEMSIN,UTARG,ANGREQ,
     *       KFLAGOUT,ANG1,ANG2,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE COMPUTES THE ANGLES = TRUE ANOMALY PLUS ARG-OF-PERIGEE
C BETWEEN WHICH A CELESTIAL POINT SOURCE TARGET(EX, A STAR, PLANET,
C ...) IS AVAILABLE FOR OBSERVATION FROM AN EARTH-ORBITING SPACECRAFT.
C
C >>> AVAILABLE MEANS THAT THE LINE OF SIGHT TO THE TARGET SATISFIES
C     THE APPROPRIATE CONDITION --
C
C      KREQMT = 1.  EARTH HORIZON AVOIDANCE. LINE OF SIGHT TO THE TARGET
C                   IS EQ/GT A SPECIFIED ANGLE ABOVE THE HORIZON.
C
C      KREQMT = 2.  VELOCITY VECTOR AVOIDANCE. LINE OF SIGHT TO THE
C                   TARGET IS EQ/GT A SPECIFIED ANGLE FROM THE VEL VEC.
C                   TARGET OCCULATION IS NOT CONSIDERED HERE.
C
C      KREQMT = 3.  ZENITH ANGLE RANGE. LINE OF SIGHT TO THE TARGET IS
C                   LT/EQ A SPECIFIED ANGLE FROM THE INSTANTANEOUS
C                   ZENITH DIRECTION. TARGET OCCULATION IS NOT
C                   CONSIDERED HERE.
C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C
C KREQMT    1   I*4  I  AS DESCRIBED IN THE COMMENTS ABOVE. IF NOT
C                       1, 2, OR 3, AN ERROR CONDITION.
C
C ELEMSIN   5   R*8  I  THE KEPLERIAN ELEMENTS OF THE SPACECRAFT ORBIT.
C                       ORDER IS SMA, ECC, INCL, NODE, ARGP.
C                       IN KILOMETERS AND RADIANS.
C
C                       THE COORDINATE SYSTEM MAY BE ANY GEOCENTRIC ONE
C                       THAT IS CONVENIENT.
C
C                       ECCENTRICITY MAY BE ZERO.  IF SO, PERIGEE HAS NO
C                       PHYSICALLY UNIQUE LOCATION AND ZERO TRUE ANOMALY
C                       IS DEFINED TO OCCUR ELEMSIN(5) RADIANS AFTER THE
C                       S/C CROSSES THE ASCENDING NODE.
C
C UTARG     3   R*8  I  UNIT VECTOR OF THE TARGET. THE COORDINATE SYSTEM
C                       IS THE SAME AS THAT USED FOR ELEMSIN ABOVE. NO
C                       ERROR CHECK IS DONE TO VERIFY VECTOR IS UNIT.
C
C ANGREQ    1   R*8  I  FOR KREQMT=1,
C
C                         THE HORIZON AVOIDANCE ANGLE. IF THE TARGET
C                         DIRECTION LIES MORE THAN ANGREQ RADIANS ABOVE
C                         THE CURRENT HORIZON, THEN IT IS CONSIDERED
C                         AVAILABLE.  OTHERWISE, NOT AVAILABLE.
C                         IN RADIANS.
C
C                         (ANGREQ + SOLID EARTH ANGLE AT PERIGEE) MUST
C                         BE IN THE 0 TO PI RANGE, INCLUDING 0 AND
C                         PI.
C
C                       FOR KREQMT=2,
C
C                         THE VELOCITY VECTOR AVOIDANCE ANGLE. IF THE
C                         TARGET DIRECTION LIES MORE THAN ANGREQ RADIANS
C                         FROM THE VELOCITY VECTOR DIRECTION, THEN IT IS
C                         CONSIDERED AVAILABLE. OTHERWISE, NOT
C                         AVAILABLE. IN RADIANS.
C
C                         ANGREQ MUST BE IN THE 0 TO PI RANGE, INCLUDING
C                         0 AND PI.
C
C                       FOR KREQMT=3,
C                         THE ZENITH VECTOR SEPARATION ANGLE. IF THE
C                         TARGET DIRECTION LIES LESS THAN ANGREQ RADIANS
C                         FROM THE CURRENT ZENITH DIRECTION, THEN IT IS
C                         CONSIDERED AVAILABLE. OTHERWISE, NOT
C                         AVAILABLE. IN RADIANS.
C
C                         ANGREQ MUST BE IN THE 0 TO PI RANGE, INCLUDING
C                         0 AND PI.
C
C KFLAGOUT  1   I*4  O  FLAG INDICATING THE AVAILABILITY STATUS OF THE
C                       TARGET WHEN THE SPECIFIED REQUIREMENT IS
C                       APPLIED.
C
C                       = -1, TARGET NEVER AVAILABLE.
C                       =  0, TARGET SOMETIMES AVAILIBLE, SOMETIMES NOT.
C                       =  1, TARGET ALWAYS AVAILABLE.
C                       = 9999. ACCOMPANIES ERROR CONDITION.
C
C ANG1      1   R*8  O  THE SUM OF THE ARGUMENT OF PERIGEE AND THE
C                       TRUE ANOMALY AT WHICH THE TARGET BECOMES
C                       AVAILABLE.
C
C                       THIS IS THE ANGLE IN THE ORBIT PLANE, VERTEX AT
C                       EARTH CENTER, BETWEEN THE ASCENDING NODE AND
C                       THE PLACE WHERE AVAILABILITY BEGINS.
C
C                       IN RADIANS, IN RANGE ZERO TO TWOPI.
C
C ANG2      1   R*8  O  SIMILAR TO ANG1, BUT FOR THE PLACE WHERE
C                       AVAILABLITY CEASES.  IN RADIANS, IN RANGE ZERO
C                       TO TWOPI.
C
C                       ANG2 MAY BE SMALLER THAN ANG1.
C
C                       IF THE TARGET IS ALWAYS AVAILABLE, THEN
C                       ANG1 = 0.D0 AND ANG2 = TWOPI
C
C                       IF THE TARGET IS NEVER AVAILABLE, THEN
C                       ANG1 = 0.D0 AND ANG2 = 0.D0
C
C                       ON AN ERROR RETURN, ANG1 = ANG2 = 999.D0/DEGRAD
C
C LUERR     1   I*4  I  FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                       IF ZERO OR NEGATIVE, NO MESSAGES WILL BE GIVEN.
C
C IERR      1   I*4  O  ERROR RETURN FLAG.
C                        = 0, NO ERRORS.
C                        = 1, BAD KREQMT VALUE INPUT
C                        = 2, BAD ELEMS(1) OR ELEMS(2)
C                        = 3, ALGORITHM ERROR IN TAVISPAK99
C                        = 4, ALGORITHM DID NOT CONVERGE
C                        = 5, (KREQMT=1) ANGREQ VALUE IS INCONSISTENT
C                             WITH REARTH AND ELEMS. SEE ERROR CHECK IN
C                             TAVISPAK51.
C                        = 6, (KREQMT=1) PERIGEE RADIUS IS BELOW THE
C                             EARTH SURFACE.
C                        = 7, (KREQMT=2 AND 3) ANGREQ IS OUTSIZE OF THE
C                             0 TO PI RANGE.
C                        = 8, ALGORITHM ERROR IN TAVISPAK3B
C
C                        IF AN ERROR IS SENSED, ANG1=ANG2=0.D0 IS
C                        RETURNED.
C
C***********************************************************************
C
C CODED BY C PETRUZZO, GSFC/742, 1/86.
C    MODIFIED....  CJP. 10/86.  COMMENT ADDED IN ELEMSIN DESCRIPTION.
C
C***********************************************************************
C
C THE UNDERLYING ALGORITHMS WERE DERIVED BY H.P. SWARTWOOD(GSFC/742) AND
C WERE DOCUMENTED IN MEMORANDUMS TO FILES IN OCTOBER AND NOVEMBER, 1985.
C
C
      REAL*8 UTARG(3),ORBDATA(20)
      REAL*8 ELEMSIN(5),ELEMOLD(5)/5*1.D10/,ELEMS(5),ORBNORM(3)
      LOGICAL NEWSTATE
      REAL*8 PI     / 3.141592653589793D0 /
      REAL*8 TWOPI  / 6.283185307179586D0 /
      REAL*8 DEGRAD / 57.29577951308232D0 /
      REAL*8 PITESTMIN/0.D0/
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,7701)
     *    KREQMT,ELEMSIN(1),ELEMSIN(2),(ELEMSIN(I)*DEGRAD,I=3,6),
     *    UTARG,ANGREQ*DEGRAD
 7701 FORMAT(/,' TAVISPAK DEBUG. ENTRY VALUES ARE    KREQMT=',I4/,
     *  '    ELEMSIN=',2(T15,3G16.8/),
     *  '    UTARG=',3G16.8/,
     *  '    ANGREQ=',G16.8)
C
C ****************
C *  INITIALIZE  *
C ****************
C
      IERR = 0
C
      DO I=1,5
        ELEMS(I) = ELEMSIN(I)
        END DO
      IF(ELEMSIN(2).EQ.0.D0) ELEMS(5) = 0.D0   ! ELIMINATES AMBIGUITY
      IF(PITESTMIN.EQ.0.D0) THEN
        PITESTMIN =  PI - 1.D-4/DEGRAD
        PITESTMAX =  PI + 1.D-4/DEGRAD
        ZEROTEST =        1.D-4/DEGRAD
        END IF
C
C
C ******************
C *  ERROR CHECKS  *
C ******************
C
      CALL TAVISPAK1(KREQMT,ELEMS,ANGREQ,LUERR,IERR)
      IF(IERR.NE.0) GO TO 9999
C
C
C *********************************************************
C *  CHECK FOR ANGREQ VALUES THAT DO NOT NEED ALGORITHMS  * SAVES TIME
C *********************************************************
C
C FOR VELOCITY VECTOR AVOIDANCE
C
      IF(KREQMT.EQ.2) THEN
        IF(ANGREQ.LE.ZEROTEST) THEN
C        IE, TARGET IS GT/EQ ZERO RADIANS FROM VELOCITY VECTOR
          KVISFLAG = 1   ! ALWAYS
          GO TO 9999
          END IF
        IF(ANGREQ.GE.PITESTMIN) THEN
C        IE, TARGET IS PI RADIANS FROM VELOCITY VECTOR
          KVISFLAG = -1  !NEVER. ACTUALLY, ONLY INSTANTANEOUSLY POSSIBLE
          GO TO 9999
          END IF
        END IF
C
C FOR ZENITH MAX SEPARATION REQUIREMENT
C
      IF(KREQMT.EQ.3) THEN
        IF(ANGREQ.LE.ZEROTEST) THEN
C        IE, TARGET IS WITHIN ZERO RADIANS OF ZENITH
          KVISFLAG = -1  !NEVER. ACTUALLY, ONLY INSTANTANEOUSLY POSSIBLE
          GO TO 9999
          END IF
        IF(ANGREQ.GE.PITESTMIN) THEN
C        IE, TARGET IS WITHIN PI RADIANS OF ZENITH
          KVISFLAG = 1   ! ALWAYS
          GO TO 9999
          END IF
        END IF
C
C ***********************************************
C * SET DATA RELATED TO THE ORBITAL PARAMETERS  *
C ***********************************************
C
C IF THE STATE IS DIFFERENT THAN ON THE PREVIOUS CALL, COMPUTE NEW
C VALUES FOR THE ORBDATA ARRAY.
C
      NEWSTATE = .FALSE.
      DO I=1,5
        NEWSTATE = NEWSTATE .OR. ELEMOLD(I).NE.ELEMS(I)
        END DO
      IF(NEWSTATE) THEN
        CALL TAVISPAK2(ELEMS,ORBDATA)
        IF(IBUG.NE.0) THEN
          ORBNORM(1) = ORBDATA(18)
          ORBNORM(2) = ORBDATA(19)
          ORBNORM(3) = ORBDATA(20)
          CALL XYZSPH(-1,RANORM,DECNORM,DUM,ORBNORM,1.D0)
          WRITE(LUBUG,7702) RANORM*DEGRAD,DECNORM*DEGRAD,ORBDATA
 7702     FORMAT(/,' TAVISPAK DEBUG 7702.   RANORM,DECNORM=',2G13.5/,
     *             '   ORBDATA='/,(T12,4G16.8))
          END IF
        END IF
C
C
C **************
C *  SOLVE IT  *
C **************
C
      CALL TAVISPAK3(KREQMT,ELEMS,UTARG,ANGREQ,
     *       KVISFLAG,EABEGIN,EACEASE,ORBDATA,LUERR,IERR)
      IF(IERR.NE.0) GO TO 9999
C
C
C *************
C *  WRAP UP  *
C *************
C
 9999 CONTINUE
C
      IF(IERR.EQ.0) THEN
C
       IF(KVISFLAG.EQ.0) THEN
C        SET THE TRUE ANOMALY PLUS ARGUMENT OF PERIGEE
          KFLAGOUT = 0
          ANG1 = EQVANG(ELEMS(5)+ANOMLY2(1,EABEGIN,ELEMS(2),LUERR,IER1))
          IF(IER1.NE.0) THEN
C          ELEMS(2) WAS TESTED IN TAVISPAK1 AND WAS OK.  NOT OK NOW.
            STOP ' TAVISPAK. CODING ERROR. STOPPED.'
            END IF
          ANG2 = EQVANG(ELEMS(5)+ANOMLY2(1,EACEASE,ELEMS(2),LUERR,IER2))
        ELSE
          IF(KVISFLAG.EQ.-1) THEN
C          TARGET IS NEVER AVAILABLE.
            KFLAGOUT = -1
            ANG1 = 0.D0
            ANG2 = 0.D0
            END IF
          IF(KVISFLAG.EQ.+1) THEN
C          TARGET IS ALWAYS AVAILABLE.
            KFLAGOUT = 1
            ANG1 = 0.D0
            ANG2 = TWOPI
            END IF
          END IF
C      SAVE INFO FOR USE ON NEXT CALL.
        DO I=1,5
          ELEMOLD(I) = ELEMS(I)
          END DO
        END IF
C
      IF(IERR.NE.0) THEN
C      ERROR CONDITION.  SET ANG1 AND ANG2 AS STATED IN THE PROLOGUE.
C      THE ELEMOLD(1) VALUE MAKES THE NEXT CALL INITIALIZE PROPERLY.
        ELEMOLD(1) = -1.D10
        KFLAGOUT = 9999
        ANG1 = 999.D0/DEGRAD
        ANG2 = ANG1
        CALL TAVISPAK4(KREQMT,ELEMS,LUERR,IERR)
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,8605) IERR,ANG1*DEGRAD,ANG2*DEGRAD
 8605 FORMAT(' TAVISPAK DEBUG. EXIT VALUES: IERR=',I2,'  ANG1,ANG2=',
     *           2G13.5/)
C
      RETURN
      END


      double complex function F41m(psq,s,t)
c--- note: ordering of arguments to function is taken from, e.g.
c---       arXiV:0804.4149v3 (App. B) and not hep-ph/0607139 (Eq. 21)
      implicit none
c      include 'epinv.f'
c      include 'scale.f'
      double precision s,t,psq
c      double precision den
c      double complex qlI4
      double complex F31m,F41mF
c      integer ep
c      den=s*t
c      F41m=czip
c      do ep=-2,0
c      F41m=F41m+den*epinv**(-ep)
c     . *qlI4(0d0,0d0,0d0,psq,s,t,0d0,0d0,0d0,0d0,musq,ep)
c      enddo

c--- NOTE: checked on 8/30/09 that this agrees with the expression above
      F41m=2d0*(F31m(s)+F31m(t)-F31m(psq)+F41mF(psq,s,t))

      return
      end


c
c Last update: Mar 29, 2014
c
************************************************************************
* Subroutine to compute the momenta p1,....,p6 of six particles of mass
* xm1,...,xm6 given a point in the 14 dimensional hypercube [0,1]^14
* Returns also xjac, the weight due to the jacobian.
*
* The phase space mapping corresponds to
*   [4(rm1[a,b]) --> 2(rm11[a,b,c],p1,p2)+2(rm12[a,b,c],p3,p4)] +
*                     [2(rm2[a,b,c],p5,p6)]
* where rm1[a,b], rm11[a,b,c],rm2[a,b,c],rm12[a,b,c] are the masses of the
*   intermediate resonances
* rm1 can resonate at two different masses
*    (e.g. H, H') with rm1a < rm1b.
* rm11, rm12 and rm2 can resonate at three different masses
*    (e.g. Z, H, H') with
* rmXa < rmXb < rmXc.
* CHECK
* If only one resonance is needed set the corresponding
*    spmXahi=spmXalo=0.d0
* ENDCHECK
*
* If in the main x had dimension 15 with x(1) and x(2) fixing the
*  initial state particle momentum fraction the subroutine can be called
*   as     call phsp2_4(x(3),shat,.......)
*

* INPUT:

*  x,shat        : vegas random points, total energy squared
*  xm(8),xmsq(8) : masses and masses squared of the particles
*                        in the order used in the main program
*  rmN,gamN      : N=1[a,b],2[a,b,c],11[a,b,c],12[a,b,c] mass and width for
*                        intermediate resonance N.
*  spmNlo,spmNhi : N=1[a,b],11[a,b,c],12[a,b,c],1,2[a,b,c] low and high limit of
*                        resonance mapping. Outside this range the
*                         mapping is flat
*  iorder(6)     : specifies the permutation that relates internal and
*
*                      external momenta: p = p(i,iorder(1))
* OUTPUT:

*  p(0:3,8)      : momenta in the hard scattering CM.
*                        Includes initial momenta.
*  xjac          : full jacobian
************************************************************************

        subroutine phsp2_4_multi7(x,shat,
     &                    rm1a,gam1a,spm1alo,spm1ahi,
     &                    rm1b,gam1b,spm1blo,spm1bhi,
     &                    rm11a,gam11a,spm11alo,spm11ahi,
     &                    rm11b,gam11b,spm11blo,spm11bhi,
     &                    rm11c,gam11c,spm11clo,spm11chi,
     &                    rm12a,gam12a,spm12alo,spm12ahi,
     &                    rm12b,gam12b,spm12blo,spm12bhi,
     &                    rm12c,gam12c,spm12clo,spm12chi,
     &                    rm2a,gam2a,spm2alo,spm2ahi,
     &                    rm2b,gam2b,spm2blo,spm2bhi,
     &                    rm2c,gam2c,spm2clo,spm2chi,
     &                    xm,xmsq,iorder,
     &                    p,xjac)

      IMPLICIT NONE
      REAL*8 x(13),shat,
     &       rm1a,gam1a,spm1alo,spm1ahi,
     &       rm1b,gam1b,spm1blo,spm1bhi,
     &       rm11a,gam11a,spm11alo,spm11ahi,
     &       rm11b,gam11b,spm11blo,spm11bhi,
     &       rm11c,gam11c,spm11clo,spm11chi,
     &       rm12a,gam12a,spm12alo,spm12ahi,
     &       rm12b,gam12b,spm12blo,spm12bhi,
     &       rm12c,gam12c,spm12clo,spm12chi,
     &       rm2a,gam2a,spm2alo,spm2ahi,
     &       rm2b,gam2b,spm2blo,spm2bhi,
     &       rm2c,gam2c,spm2clo,spm2chi,
     &       xm(8),xmsq(8),
     &       p(0:3,8),xjac,xjacvar,svar
      INTEGER iorder(6)
* Local variables
      REAL*8 e_sup,e_inf,x_max,x_min,app,
     &       s11,s12,s1,s2,q11(0:3),q12(0:3),q1(0:3),q2(0:3),
     &       e11,e12,e1,e2,p11mod,p12mod,p1mod,p2mod,pmod,
     &       pi,twopi,fourpi,
     &       costh,sinth,ph,ran2
      INTEGER idum,io1,io2,io3,io4,io5,io6,i,iregion
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi,
     &           fourpi=4.d0*pi)

* Mutimapping
      REAL*8 alfa1,alfa2,auxalfa2,
     &       alfa3,auxalfa3,alfa4,auxalfa4,
     &       alfa5,auxalfa5,alfa6,auxalfa6,
     &       xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &       xw2_min,xw2_max,xf3_min,xf3_max,
     &       xw3_min,xw3_max,xf4_min,xf4_max,
     &       vegas_x

      COMMON /pharand/ idum
c giuseppe 29/09/2007
      INTEGER maxnresonant
      PARAMETER (maxnresonant=4)
      INTEGER isresonant(maxnresonant),imapregion(maxnresonant)
      COMMON /iphsp_fxn/ isresonant,imapregion

       DO i=1,maxnresonant
         isresonant(i)=0
         imapregion(i)=0
      ENDDO
c end giuseppe 29/09/2007

      io1=iorder(1)
      io2=iorder(2)
      io3=iorder(3)
      io4=iorder(4)
      io5=iorder(5)
      io6=iorder(6)

      xjac=1.d0

* s11 = (p1+p2)**2 = q11**2
      e_sup = sqrt(shat)-xm(io3)-xm(io4)-xm(io5)-xm(io6)
      e_inf = xm(io1)+xm(io2)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      iregion=3
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm11alo,spm11ahi,rm11a,gam11a,
     &               spm11blo,spm11bhi,rm11b,gam11b,
     &               spm11clo,spm11chi,rm11c,gam11c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      CALL PHSP_7(x(1),
     &               rm11a,gam11a,rm11b,gam11b,rm11c,gam11c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max,
     &                     iregion,
     &                     svar,xjacvar)
      s11=svar
      xjac=xjac*xjacvar

* s12 = (p3+p4)**2 = q12**2
      e_sup = sqrt(shat)-xm(io5)-xm(io6)-sqrt(s11)
      e_inf = xm(io3)+xm(io4)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      iregion=4
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm12alo,spm12ahi,rm12a,gam12a,
     &               spm12blo,spm12bhi,rm12b,gam12b,
     &               spm12clo,spm12chi,rm12c,gam12c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      CALL PHSP_7(x(2),
     &               rm12a,gam12a,rm12b,gam12b,rm12c,gam12c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max,
     &                     iregion,
     &                     svar,xjacvar)
      s12=svar
      xjac=xjac*xjacvar

* s1 = (q11+q12)**2 = q1**2
      e_sup = sqrt(shat)-xm(io5)-xm(io6)
      e_inf = sqrt(s11)+ sqrt(s12)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      iregion=1
      CALL PHSP_INI5(e_sup,e_inf,
     &               spm1alo,spm1ahi,rm1a,gam1a,
     &               spm1blo,spm1bhi,rm1b,gam1b,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max)
      CALL PHSP_5(x(3),
     &               rm1a,gam1a,rm1b,gam1b,
     &                     alfa1,alfa2,auxalfa2,
     &                     alfa3,auxalfa3,alfa4,auxalfa4,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &                     iregion,
     &                     svar,xjacvar)
      s1=svar
      xjac=xjac*xjacvar

* s2 = (p5+p6)**2 = q2**2
      e_sup = sqrt(shat)-sqrt(s1)
      e_inf = xm(io5)+xm(io6)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      iregion=2
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm2alo,spm2ahi,rm2a,gam2a,
     &               spm2blo,spm2bhi,rm2b,gam2b,
     &               spm2clo,spm2chi,rm2c,gam2c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      CALL PHSP_7(x(4),
     &               rm2a,gam2a,rm2b,gam2b,rm2c,gam2c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max,
     &                     iregion,
     &                     svar,xjacvar)
      s2=svar
      xjac=xjac*xjacvar

* q1 and q2
      app=((shat-s1-s2)**2-4.d0*s1*s2)/(4.d0*shat)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      pmod=sqrt(app)
      costh=min(x(5)*2.d0-1.d0,1.d0)
      costh=max(costh,-1.d0)
      sinth=sqrt(1.d0-costh*costh)
      ph=ran2(idum)*twopi
      q1(0)=sqrt(pmod*pmod+s1)
      q1(1)=pmod*sinth*cos(ph)
      q1(2)=pmod*sinth*sin(ph)
      q1(3)=pmod*costh
      q2(0)=sqrt(pmod*pmod+s2)
      q2(1)=-q1(1)
      q2(2)=-q1(2)
      q2(3)=-q1(3)
* beta/2/(4*pi)**2
      xjac=xjac*pmod/sqrt(shat)/(fourpi)**2
      xjac=xjac*fourpi

* q11 and q12
      app=((s1-s11-s12)**2-4.d0*s11*s12)/(4.d0*s1)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p1mod=sqrt(app)
      CALL TWOBODY_Z(q1,s1,p1mod,s11,s12,x(6),x(7),q11,q12)
* beta/2/(4*pi)**2
      xjac=xjac*p1mod/sqrt(s1)/(fourpi)**2
      xjac=xjac*fourpi

* q11 --> p1 and p2
      app=((s11-xmsq(io1)-xmsq(io2))**2
     &              -4.d0*xmsq(io1)*xmsq(io2))/(4.d0*s11)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p11mod=sqrt(app)
      CALL TWOBODY(q11,s11,p11mod,xmsq(io1),xmsq(io2),x(8),x(9),
     &             p(0,io1),p(0,io2))
* beta/2/(4*pi)**2
      xjac=xjac*p11mod/sqrt(s11)/(fourpi)**2
      xjac=xjac*fourpi

* q12 --> p3 and p4
      app=((s12-xmsq(io3)-xmsq(io4))**2
     &              -4.d0*xmsq(io3)*xmsq(io4))/(4.d0*s12)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p12mod=sqrt(app)
      CALL TWOBODY(q12,s12,p12mod,xmsq(io3),xmsq(io4),x(10),x(11),
     &             p(0,io3),p(0,io4))
* beta/2/(4*pi)**2
      xjac=xjac*p12mod/sqrt(s12)/(fourpi)**2
      xjac=xjac*fourpi

* q2 --> p5 and p6
      app=((s2-xmsq(io5)-xmsq(io6))**2
     &             -4.d0*xmsq(io5)*xmsq(io6))/(4.d0*s2)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p2mod=sqrt(app)
      CALL TWOBODY(q2,s2,p2mod,xmsq(io5),xmsq(io6),x(12),x(13),
     &             p(0,io5),p(0,io6))
* beta/2/(4*pi)**2
      xjac=xjac*p2mod/sqrt(s2)/(fourpi)**2
      xjac=xjac*fourpi

      RETURN
      END


      SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct, for a given system G = (A,B,C,D), an output
C     injection matrix H, an orthogonal transformation matrix Z, and a
C     gain matrix V, such that the systems
C
C          Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D)
C     and
C          R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V)
C
C     provide a stable left coprime factorization of G in the form
C                   -1
C              G = R  * Q,
C
C     where G, Q and R are the corresponding transfer-function matrices
C     and the denominator R is co-inner, that is, R(s)*R'(-s) = I in
C     the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time
C     case. The Z matrix is not explicitly computed.
C
C     Note: G must have no observable poles on the imaginary axis
C     for a continuous-time system, or on the unit circle for a
C     discrete-time system. If the given state-space representation
C     is not detectable, the undetectable part of the original
C     system is automatically deflated and the order of the systems
C     Q and R is accordingly reduced.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the state vector, i.e. the order of the
C             matrix A, and also the number of rows of the matrices B
C             and BR, and the number of columns of the matrix C.
C             N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector, i.e. the number of columns
C             of the matrices B and D.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of output vector, i.e. the number of rows
C             of the matrices C, D and DR, and the number of columns
C             of the matrices BR and DR.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A. The matrix A must not
C             have observable eigenvalues on the imaginary axis, if
C             DICO = 'C', or on the unit circle, if DICO = 'D'.
C             On exit, the leading NQ-by-NQ part of this array contains
C             the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the
C             state dynamics matrix of the numerator factor Q, in a
C             real Schur form. The leading NR-by-NR part of this matrix
C             represents the state dynamics matrix of a minimal
C             realization of the denominator factor R.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix.
C             On exit, the leading NQ-by-M part of this array contains
C             the leading NQ-by-M part of the matrix Z'*(B+H*D), the
C             input/state matrix of the numerator factor Q.
C             The remaining part of this array is needed as workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-NQ part of this array contains
C             the leading P-by-NQ part of the matrix V*C*Z, the
C             state/output matrix of the numerator factor Q.
C             The first NR columns of this array represent the
C             state/output matrix of a minimal realization of the
C             denominator factor R.
C             The remaining part of this array is needed as workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,M,P), if N > 0.
C             LDC >= 1,          if N = 0.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C             (LDD,MAX(M,P))
C             On entry, the leading P-by-M part of this array must
C             contain the input/output matrix.
C             On exit, the leading P-by-M part of this array contains
C             the matrix V*D representing the input/output matrix
C             of the numerator factor Q.
C             The remaining part of this array is needed as workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     NQ      (output) INTEGER
C             The order of the resulting factors Q and R.
C             Generally, NQ = N - NS, where NS is the number of
C             unobservable eigenvalues outside the stability region.
C
C     NR      (output) INTEGER
C             The order of the minimal realization of the factor R.
C             Generally, NR is the number of observable eigenvalues
C             of A outside the stability region (the number of modified
C             eigenvalues).
C
C     BR      (output) DOUBLE PRECISION array, dimension (LDBR,P)
C             The leading NQ-by-P part of this array contains the
C             leading NQ-by-P part of the output injection matrix
C             Z'*H, which reflects the eigenvalues of A lying outside
C             the stable region to values which are symmetric with
C             respect to the imaginary axis (if DICO = 'C') or the unit
C             circle (if DICO = 'D'). The first NR rows of this matrix
C             form the input/state matrix of a minimal realization of
C             the denominator factor R.
C
C     LDBR    INTEGER
C             The leading dimension of array BR.  LDBR >= MAX(1,N).
C
C     DR      (output) DOUBLE PRECISION array, dimension (LDDR,P)
C             The leading P-by-P part of this array contains the lower
C             triangular matrix V representing the input/output matrix
C             of the denominator factor R.
C
C     LDDR    INTEGER
C             The leading dimension of array DR.  LDDR >= MAX(1,P).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of
C             C are considered zero (used for observability tests).
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance, defined by  TOLDEF = N*EPS*NORM(C),
C             is used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH) and NORM(C) denotes
C             the infinity-norm of C.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.
C             LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = K:  K violations of the numerical stability condition
C                   NORM(H) <= 10*NORM(A)/NORM(C) occured during the
C                   assignment of eigenvalues.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the ordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + H*C)*Z
C                   along the diagonal;
C             = 3:  if DICO = 'C' and the matrix A has an observable
C                   eigenvalue on the imaginary axis, or DICO = 'D' and
C                   A has an observable eigenvalue on the unit circle.
C
C     METHOD
C
C     The subroutine uses the right coprime factorization algorithm with
C     inner denominator of [1] applied to G'.
C
C     REFERENCES
C
C     [1] Varga A.
C         A Schur method for computing coprime factorizations with
C         inner denominators and applications in model reduction.
C         Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
C
C     NUMERICAL ASPECTS
C                                            3
C     The algorithm requires no more than 14N  floating point
C     operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine LCFID.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     May  2003, A. Varga, DLR Oberpfaffenhofen.
C     Nov  2003, A. Varga, DLR Oberpfaffenhofen.
C
C     KEYWORDS
C
C     Coprime factorization, eigenvalue, eigenvalue assignment,
C     feedback control, pole placement, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR,
     $                  LDWORK, M, N, NQ, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*),
     $                  D(LDD,*), DR(LDDR,*), DWORK(*)
C     .. Local Scalars ..
      INTEGER           I, KBR, KW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External subroutines ..
      EXTERNAL          AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD,
     $                  TB01XD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      IWARN = 0
      INFO  = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.LSAME( DICO, 'C' ) .AND.
     $    .NOT.LSAME( DICO, 'D' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) )
     $      THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN
         INFO = -12
      ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN
         INFO = -18
      ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P,
     $                        4*M ) ) ) THEN
         INFO = -21
      END IF
      IF( INFO.NE.0 )THEN
C
C        Error return.
C
         CALL XERBLA( 'SB08CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, P ).EQ.0 ) THEN
         NQ = 0
         NR = 0
         DWORK(1) = ONE
         CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR )
         RETURN
      END IF
C
C     Compute the dual system G' = (A',C',B',D').
C
      CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $             INFO )
C
C     Compute the right coprime factorization with inner
C     denominator of G'.
C
C     Workspace needed:      P*N;
C     Additional workspace:  need  MAX( N*(N+5), P*(P+2), 4*P, 4*M );
C                            prefer larger.
C
      KBR = 1
      KW  = KBR + P*N
      CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD,
     $             NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW),
     $             LDWORK-KW+1, IWARN, INFO )
      IF( INFO.EQ.0 ) THEN
C
C        Determine the elements of the left coprime factorization from
C        those of the computed right coprime factorization and make the
C        state-matrix upper real Schur.
C
         CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ),
     $                A, LDA, B, LDB, C, LDC, D, LDD, INFO )
C
         CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR )
         CALL MA02BD( 'Left', NQ, P, BR, LDBR )
C
         DO 10 I = 2, P
            CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 )
   10    CONTINUE
C
      END IF
C
      DWORK(1) = DWORK(KW) + DBLE( KW-1 )
C
      RETURN
C *** Last line of SB08CD ***
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYGVMD
C...Evaluates the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.

      SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Local arrays and data.
      DIMENSION XPGA(-6:6), VXPGA(-6:6)
      DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/

C...Reset output.
      DO 100 KFL=-6,6
        XPGA(KFL)=0D0
        VXPGA(KFL)=0D0
  100 CONTINUE
      KFA=ABS(KF)

C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
      ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
      P2EFF=MAX(P2,1.2D0*ALAM3**2)
      IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)

C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5

C...Find s as sum of 3-, 4- and 5-flavour parts.
      S=0D0
      IF(NFP.EQ.3) THEN
        Q2DIV=PMC**2
        IF(NFQ.EQ.3) Q2DIV=Q2EFF
        S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
      ENDIF
      IF(NFP.LE.4.AND.NFQ.GE.4) THEN
        P2DIV=P2EFF
        IF(NFP.EQ.3) P2DIV=PMC**2
        Q2DIV=Q2EFF
        IF(NFQ.EQ.5) Q2DIV=PMB**2
        S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
      ENDIF
      IF(NFQ.EQ.5) THEN
        P2DIV=PMB**2
        IF(NFP.EQ.5) P2DIV=P2EFF
        S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
      ENDIF

C...Calculate frequent combinations of x and s.
      X1=1D0-X
      XL=-LOG(X)
      S2=S**2
      S3=S**3
      S4=S**4

C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
      IF(ISET.EQ.0) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = X * 1.5D0 * (X**2+X1**2)
          XGLU = 0D0
          XSEA = 0D0
        ELSE
          XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
     &    (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
     &    5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
     &    X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
          XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
     &    X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
     &    ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
          XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
     &    X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
     &    ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
     &    (2D0*X-1D0)*X*XL**2)
        ENDIF

C...Evaluate set 1D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.1) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
          XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
          XSEA = 0.100D0 * X1**3.76D0
        ELSE
          XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
     &    X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
          XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
     &    X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
     &    XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
     &    X**0.40D0 * X1**(1.76D0+3D0*S)
          XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
     &    (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
     &    X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
          XSEA0 = 0.100D0 * X1**3.76D0
        ENDIF

C...Evaluate set 1M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.2) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
          XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
          XSEA = 0D0
        ELSE
          XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
     &    X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
          XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
     &    EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
     &    X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
     &    EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
          XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
     &    X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
     &    XL**(2.8D0*S)
          XSEA0 = 0D0
        ENDIF

C...Evaluate set 2D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.3) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
          XGLU = 1.925D0 * X1**2
          XSEA = 0.242D0 * X1**4
        ELSE
          XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
     &    X**(0.46D0+0.25D0*S) *
     &    X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
     &    (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
          XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
     &    EXP(-18.67D0*S) *
     &    X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
     &    * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
     &    XL**(9.3D0*S/(1D0+1.7D0*S))
          XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
     &    (1D0-0.607D0*S+21.95D0*S2) *
     &    X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
          XSEA0 = 0.242D0 * X1**4
        ENDIF

C...Evaluate set 2M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.4) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
          XGLU = 1.808D0 * X1**2
          XSEA = 0.209D0 * X1**4
        ELSE
          XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
     &    X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
     &    X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
     &    XL**(5.15D0*S/(1D0+2D0*S)) +
     &    (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
          XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
     &    X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
     &    X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
     &    XL**(10.9D0*S/(1D0+2.5D0*S))
          XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
     &    X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
     &    X1**(4D0+S) * XL**(0.45D0*S)
          XSEA0 = 0.209D0 * X1**4
        ENDIF
      ENDIF

C...Threshold factors for c and b sea.
      SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
      XCHM=0D0
      IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
        SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XCHM=XSEA*(1D0-(SCH/SLL)**2)
        ELSE
          XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
        ENDIF
      ENDIF
      XBOT=0D0
      IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
        SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XBOT=XSEA*(1D0-(SBT/SLL)**2)
        ELSE
          XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
        ENDIF
      ENDIF

C...Fill parton distributions.
      XPGA(0)=XGLU
      XPGA(1)=XSEA
      XPGA(2)=XSEA
      XPGA(3)=XSEA
      XPGA(4)=XCHM
      XPGA(5)=XBOT
      XPGA(KFA)=XPGA(KFA)+XVAL
      DO 110 KFL=1,5
        XPGA(-KFL)=XPGA(KFL)
  110 CONTINUE
      VXPGA(KFA)=XVAL
      VXPGA(-KFA)=XVAL

      RETURN
      END


	FUNCTION PR_WPHF  ( powv, howv, group )
C************************************************************************
C* PR_WPHF								*
C*									*
C* This function computes WPHF, the combined wave period and wave       *
C* height in feet, from POWV and HOWV.  A group number is prefixed to   *
C* the combined value to distinguish among wind waves, predominant swell*
C* waves, and secondary swell waves.                                    *
C* The following equation is used:                                      *
C*									*
C*       WPHF = PR_WVPH ( POWV, PR_HGMF ( HOWV ), GROUP )               *
C*									*
C* REAL PR_WPHF  ( POWV, HOWV, GROUP )					*
C*									*
C* Input parameters:							*
C*	POWV		REAL		Wave period in seconds          *
C*	HOWV 		REAL		Wave height in meters    	*
C*	GROUP		REAL		Wave group number               *
C*					  2 = wind waves                *
C*					  4 = predominant swell waves   *
C*					  5 = secondary swell waves     *
C*									*
C* Output parameters:							*
C*	PR_WPHF		REAL		Combined wave period and height *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 2/99	                                        *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	IF ( ( .not. ERMISS ( powv ) ) .and.
     +       ( .not. ERMISS ( howv ) ) .and.
     +       ( .not. ERMISS ( group ) ) ) THEN
	    PR_WPHF = PR_WVPH ( powv, PR_HGMF ( howv ), group )
	  ELSE
	    PR_WPHF = RMISSD
	END IF
C*
	RETURN
	END


! Copyright (c) 2011-2013 Bartosz Szczesny
! LICENSE: The MIT License (MIT)

program tmpcon
    real :: tc, tf

    tc = 30.0
    tf = 9.0 * tc / 5.0 + 32.0

    print *, 'Temp. Conv.'
    print *, 'T[C]=', tc, 'T[F]=', tf

    stop
end


      SUBROUTINE CNVTVXFL(INTEGRIN,REALOUT)

C***********************************************************************
C  Purpose: Properly interpret the bit string that represents a VAX
C  floating point number to obtain the correct floating point number on
C  the target system.
C
C  Method: The bit string that represents the VAX floating point number is
C  passed into the routine as an integer.  Note the bytes have not been
C  swapped.  The sign bit, the bits that represent the exponent or
C  characteristic, and the bits that represent the fraction are picked off
C  using the standard Fortran function IBITS.  The following table show how
C  the bits and what they represent (sign, exponent etc) map to most unix
C  systems.
C
C          byte1       byte2       byte3     byte4
C   VAX    07 06-00    15 14-8     23-16     31-24
C          e1 f7-f1     s e8-e2    f15-f8    f23-f16
C   UNIX   31 30-24    23 22-16    15-08     07-00

C
C  Here f1 stands for the first bit that is used to represent the
C  fraction, f2 for the second bit used to represent the fraction, etc.,
C  e1 represents the first exponent bit, e2 the second, and s represents
C  the sign bit.  A VAX floating point number is represented by :
C
C  floating point number = -1**signbit * fraction * 2 **(EXPONENT-128)
C
C  !!!!!!Note: to save space the vax system assumes the most significant
C              fraction bit is set.  This fact is taken into account when
C              computing the fraction.  Also, as appears to be standard
C              practice, the exponent is biased by a fix number(128 in
C              this case).
C
C  References:
C  1.  Final Interface Specification for the Satellite Data Handling
C  System Communications Network (SDHS-COMNET), 01 February 1988
C  2.  AFGWC/DONS PV-Wave program auto_convert.pro
C  3.  VAX Fortran Reference Manual from the SDHS programmer library
C***********************************************************************

      INTEGER INTEGRIN   !The input integer that contains the bit string
      REAL   REALOUT    !The output floating point number
      INTEGER SIGNBIT  !the sign bit
      INTEGER CHARACTS !the integer representation of the exponent before
                         !it is biased
      REAL*8 M1,M2,M3  ! components of the fraction;M1 is most significant
      REAL*8 FRACTION  ! the fraction portion of the floating point number
      REAL*8 EXPONENT  ! the exponent portion of the floating point number

C***********************************************************************
C  Pick off the sign bit and convert it to an integer (a zero or a one)
C***********************************************************************

      SIGNBIT = IBITS(INTEGRIN,23,1)

C***********************************************************************
C  Pick off the exponent bits (7 bits from one byte, 1 bit from another)
C  convert the two bit strings to their integer representation and add
C  to get the unbiased exponent value
C***********************************************************************

      CHARACTS = IBITS(INTEGRIN,16,7)*2 + IBITS(INTEGRIN,31,1)

C***********************************************************************
C  Bias the exponent
C***********************************************************************

      EXPONENT = DFLOAT (CHARACTS - 128)

C***********************************************************************
C Pick off the bits strings from the three difference bytes that contain
C fraction bits.  Convert the bit strings to the appropriate fraction.
C To account for the fact that the most significant fraction bit is
C assumed to be set, 2**7 is added to the most significant fractional
C component M1.
C***********************************************************************

      M1 = DFLOAT( (IBITS( INTEGRIN,24,7 ) + 2**7 ) )/(2.0D0)**8
      M2 = DFLOAT(IBITS(INTEGRIN,8,8))/(2.0D0)**24
      M3 = DFLOAT(IBITS(INTEGRIN,0,8))/(2.0D0)**16

C***********************************************************************
C  Compute the fraction portion of the floating point number by adding
C  the three fractional components
C***********************************************************************

      FRACTION = M1 +M2 + M3

C***********************************************************************
C  Compute the floating point number according to the defintion of a
C  VAX floating point number.
C***********************************************************************

      REALOUT= FLOAT(1-2*SIGNBIT)*FRACTION*2.0**EXPONENT

C***********************************************************************
C  Since one must assume that the most significant fraction bit is set.
C  Zero in the above computation will be computed as .5 i.e. all fraction
C  bits were zero but the implied bit resulted in the fraction being .5.
C  To ensure zero is properly represented the following code checks for
C  when the fraction is .5 and set the floating point number to zero
C***********************************************************************

      IF(FRACTION .EQ. .5)THEN
        REALOUT=0.0
      ENDIF

      RETURN
      END


(((6 = 2) <=> (2 = 7)) <=> (4 = 6))
(((2 != 3) => ~(5 = 10)) /\ (2 != 8))
(((6 != 5) <=> ~(3 = 6)) /\ (1 != 3))
(((10 != 6) \/ (8 != 7)) => (4 != 8))
(((10 != 1) <=> ~(9 != 8)) => (2 = 10))
(~(4 = 7) => ((4 = 8) \/ (1 = 2)))
((5 = 6) <=> ((10 != 8) /\ (3 = 7)))
(((7 != 5) \/ (8 != 3)) /\ (9 = 8))
(((8 != 7) X ~(6 = 4)) \/ (3 = 5))
(((9 = 6) <=> (8 != 7)) => ~(3 = 2))
(((9 = 7) X (5 != 7)) /\ (4 = 3)) 0