include 'sort_data_module.f90'

program ch2501
    ! Sorting Reals and Integers
    use iso_fortran_env
    use sort_data_module
    implicit none

    integer, parameter :: n = 1000000
    real(real64), allocatable, dimension(:) :: x
    integer(int32), allocatable, dimension(:) :: y
    integer :: allocate_status = 0

    print *, ' Program starts'

    allocate(x(1:n),stat=allocate_status)
    if (allocate_status/=0) then
        print *, ' Allocate failed.'
        print *, ' Program terminates'
        stop 10
    end if
    print *, ' Real allocate complete'
    call random_number(x)
    print *, ' Real array initialised'
    call sort_data(x,n)
    print *, ' Real sort ended'
    print *, ' First 10 reals'
    write(*,100) x(1:10)

    allocate(y(1:n),stat=allocate_status)
    if (allocate_status/=0) then
        print *, ' Allocate failed.'
        print *, ' Program terminates'
        stop 20
    end if
    y = int(x*1000000)
    deallocate(x)
    print *, ' Integer array initialised'
    call sort_data(y,n)
    print *, ' Sort ended'
    print *, ' First 10 integers'
    write(*,110) y(1:10)
    deallocate(y)
    print *, ' Deallocate'
    print *, ' Program terminates'

100 format (5(2x,e14.6))
110 format (5(2x,i10))
end program


program test

    implicit none

    ! =======================
    ! integer
    integer :: largeval
    integer(kind=2) :: shortval
    integer(kind=4) :: longval
    integer(kind=8) :: vlongval
    ! integer(kind=10) :: vvlongval

    ! real
    real :: x, y, z

    ! character
    character(len=40) :: name

    ! bool
    logical :: done

    ! complex
    complex :: cp

    ! constant variable
    integer, parameter :: aa = 1;
    ! =======================
    print *, huge(largeval)
    print *, huge(vlongval)
    ! print *, huge(vvlongval)

    x = 1.3
    y = 4.3
    z = x + y
    print *, z

    name = "aaa"
    print *, name

    done = .true.
    print *, done

    cp = (3.2, 4.4)
    print *, cp

    ! constant variables can NOT be changed
    ! aa = 232
    print *, aa

end program test


PROGRAM F079

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/079/p079_keylog.txt"
    CHARACTER (LEN=5)  :: PASSCODE_ATTEMPT_STR

    CHARACTER (LEN=10) :: PASSCODE

    INTEGER, DIMENSION(0:9) :: PASSCODE_POSITIONS =                            &
                               (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /)

    INTEGER :: INDEX_VAL = 1

    INTEGER :: I, J, DIGIT_1, DIGIT_2, DIGIT_3, SWAP_VAL

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO
        READ(2, '(A)', END=10) PASSCODE_ATTEMPT_STR

        DIGIT_1 = IACHAR(PASSCODE_ATTEMPT_STR(1:1)) - IACHAR('0')
        DIGIT_2 = IACHAR(PASSCODE_ATTEMPT_STR(2:2)) - IACHAR('0')
        DIGIT_3 = IACHAR(PASSCODE_ATTEMPT_STR(3:3)) - IACHAR('0')

        IF (PASSCODE_POSITIONS(DIGIT_1) >= PASSCODE_POSITIONS(DIGIT_2)) THEN
            SWAP_VAL                     = PASSCODE_POSITIONS(DIGIT_1)
            PASSCODE_POSITIONS(DIGIT_1)  = PASSCODE_POSITIONS(DIGIT_2)
            PASSCODE_POSITIONS(DIGIT_2)  = SWAP_VAL
        END IF

        IF (PASSCODE_POSITIONS(DIGIT_2) >= PASSCODE_POSITIONS(DIGIT_3)) THEN
            SWAP_VAL                     = PASSCODE_POSITIONS(DIGIT_2)
            PASSCODE_POSITIONS(DIGIT_2)  = PASSCODE_POSITIONS(DIGIT_3)
            PASSCODE_POSITIONS(DIGIT_3)  = SWAP_VAL
        END IF

    END DO

    10 CLOSE(2)

    DO I = 0, 9

        IF (PASSCODE_POSITIONS(I) == (I + 1)) CYCLE

        DO J = 0, 9

            IF (PASSCODE_POSITIONS(J) == (I + 1)) THEN
                PASSCODE(INDEX_VAL:INDEX_VAL) = ACHAR(J + IACHAR('0'))
                INDEX_VAL = INDEX_VAL + 1
                EXIT
            END IF

        END DO

    END DO

    PRINT ('(A)'), PASSCODE

END PROGRAM F079


! { dg-options "-O2 -g" }

MODULE powell
  INTEGER, PARAMETER :: dp=8
CONTAINS
  SUBROUTINE newuob (n,  bmat,  ndim,  d,  vlag,  w, npt)
    REAL(dp), DIMENSION(ndim, *), INTENT(inout) :: bmat
    REAL(dp), DIMENSION(*), INTENT(inout)    :: d, vlag, w
    REAL(dp) :: sum
    INTEGER, INTENT(in) :: npt
    DO j=1,n
       jp=npt+j
       DO k=1,n
          sum=sum+bmat(jp,k)*d(k)
       END DO
       vlag(jp)=sum
    END DO
  END SUBROUTINE newuob
END MODULE powell


program EP2
    use        test
    use constrained, only: penalty
    use      stats2, only: f, g, h, &
                           c, dc, d2c, &
                           setf, setg, seth, &
                           setc, setdc, setd2c, &
                           subproblem, iteration, armijo, norm, angle, &
                           initstat, printheader, printstat, setmethod
implicit none
    double precision, allocatable :: x(:), x0(:)
    double precision              :: mu, gamma, sigma, theta, eps
    integer                       :: n, m, i
    logical                       :: exist

    ! Chamadas do sistema para criar processos independentes
    ! Útil para matar uma conta específica sem afetar as outras
    interface
       function fork() bind(C)
         use iso_c_binding, only: c_int
         integer(c_int) :: fork
       end function fork

       function wait(i) bind(C)
         use iso_c_binding, only: c_int
         integer(c_int), VALUE :: i
         integer(c_int)        :: wait
       end function wait
    end interface

    gamma = 1e-4
    sigma = 1e-4
    theta = 1e-5
    eps   = 1e-6

    n = 2
    m = 1

    ! Cria arquivo para saída formatada em LaTeX
    inquire(file="aux/output.dat", exist=exist)
    ! if (exist) then
    !     open(57, file="aux/output.dat", status="old", position="append", action="write")
    ! else
    !     open(57, file="aux/output.dat", status="new", action="write")
    ! end if

    allocate(x(n))
    allocate(x0(n))
    x0(1) = 1
    x0(2) = 1
    call printheader()

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! teste 1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(fork() == 0) then
        call initstat(n, m)
        call setmethod("teste 1")
        call setf(testf1)
        call setg(testg1)
        call seth(testh1)
        call setc(c1)
        call setdc(dc1)
        call setd2c(d2c1)

        mu = 10
        open(19, file="aux/teste1.dat", status="unknown", action="write")
        open(38, file="aux/teste1_lagrangean.dat", status="unknown", action="write")
        open(57, file="aux/output.dat", status="unknown", position="append", action="write")
        call penalty(x, x0, n, m, mu, f, g, h, c, dc, d2c, gamma, sigma, theta, eps, subproblem, iteration, armijo, norm, angle)

        call printstat(x, mu)

        deallocate(x)
        deallocate(x0)

        close(19)
        close(38)
        close(57)
        call exit(0)
    end if
    i = wait(i)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! teste 2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(fork() == 0) then
        call initstat(n, m)
        call setmethod("teste 2")
        call setf(testf2)
        call setg(testg2)
        call seth(testh2)
        call setc(c2)
        call setdc(dc2)
        call setd2c(d2c2)

        mu = 10

        open(19, file="aux/teste2.dat", status="unknown", action="write")
        open(38, file="aux/teste2_lagrangean.dat", status="unknown", action="write")
        open(57, file="aux/output.dat", status="unknown", position="append", action="write")
        call penalty(x, x0, n, m, mu, f, g, h, c, dc, d2c, gamma, sigma, theta, eps, subproblem, iteration, armijo, norm, angle)

        call printstat(x, mu)

        deallocate(x)
        deallocate(x0)

        close(19)
        close(38)
        close(57)
        call exit(0)
    end if
    i = wait(i)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! teste 3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(fork() == 0) then
        m = 2
        call initstat(n, m)
        call setmethod("teste 3")
        call setf(testf3)
        call setg(testg3)
        call seth(testh3)
        call setc(c3)
        call setdc(dc3)
        call setd2c(d2c3)

        mu = 10

        open(19, file="aux/teste3.dat", status="unknown", action="write")
        open(38, file="aux/teste3_lagrangean.dat", status="unknown", action="write")
        open(57, file="aux/output.dat", status="unknown", position="append", action="write")
        call penalty(x, x0, n, m, mu, f, g, h, c, dc, d2c, gamma, sigma, theta, eps, subproblem, iteration, armijo, norm, angle)

        call printstat(x, mu)

        deallocate(x)
        deallocate(x0)

        close(19)
        close(38)
        close(57)
        call exit(0)
    end if
    i = wait(i)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! teste 4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(fork() == 0) then
        m = 2
        call initstat(n, m)
        call setmethod("teste 4")
        call setf(testf4)
        call setg(testg4)
        call seth(testh4)
        call setc(c4)
        call setdc(dc4)
        call setd2c(d2c4)

        mu = 10

        open(19, file="aux/teste4.dat", status="unknown", action="write")
        open(38, file="aux/teste4_lagrangean.dat", status="unknown", action="write")
        open(57, file="aux/output.dat", status="unknown", position="append", action="write")
        call penalty(x, x0, n, m, mu, f, g, h, c, dc, d2c, gamma, sigma, theta, eps, subproblem, iteration, armijo, norm, angle)

        call printstat(x, mu)

        deallocate(x)
        deallocate(x0)

        close(19)
        close(38)
        close(57)
        call exit(0)
    end if
    i = wait(i)

    close(57)
end program EP2


program slices
    implicit none
    integer :: i
    integer, dimension(3, 2), target :: A = reshape( [(i, i=1, 6)], [3, 2])
    integer, dimension(:), pointer :: p => null()

    print '(A)', 'original:'
    call print_2d_array(A)

    p => A(2, :)
    call times2(p)
    print '(A)', 'second row x 2:'
    call print_2d_array(A)

    p => A(:, 1)
    call times2(p)
    print '(A)', 'first column x 2:'
    call print_2d_array(A)

    p => A(1:3:2, 2)
    call times2(p)
    print '(A)', 'first and third element of second column x 2:'
    call print_2d_array(A)

contains

    subroutine times2(vector)
        implicit none
        integer, dimension(:), intent(inout) :: vector

        vector = 2*vector
    end subroutine times2

    subroutine print_2d_array(A)
        implicit none
        integer, dimension(:, :), intent(in) :: A
        integer :: row

        do row = 1, size(A, 1)
            print '(*(I4))', A(row, :)
        end do
    end subroutine print_2d_array

end program slices


subroutine main(km, jm, do_srf_mom_flx, do_srf_sen_flx,  do_srf_lat_flx, &
     r, Pr, Rd, Cpd, Lv, eps, nuv, Cd, g, u0, dt, lat, lev, &
     ps, Ts, T, U, V, q,            &
     Tinc, Uinc, Vinc, qinc, theta, srf_lat_flx, srf_sen_flx)

implicit none

! In
integer                             :: km, jm, do_srf_mom_flx
integer                             :: do_srf_sen_flx, do_srf_lat_flx
real, intent(in)                    :: r, Pr, Rd, Cpd, Lv, eps, nuv, Cd, g, u0, dt
real, intent(in), dimension(jm)     :: lat
real, intent(in), dimension(km)     :: lev
real, intent(in), dimension(jm)     :: ps, Ts
real, intent(in), dimension(jm,km)  :: T, U, V, q

! Out
real, intent(out), dimension(jm,km) :: Tinc, Uinc, Vinc, qinc, theta
real, intent(out), dimension(jm)    :: srf_lat_flx, srf_sen_flx

! Local
integer :: k
real                     :: dp, dphi
real, dimension(jm,km-1) :: eta
real, dimension(jm,km)   :: p, Uinc_vert, Uinc_horiz, Vinc_vert, Vinc_horiz
real, dimension(jm)      :: srf_q_flx, srf_T_flx, srf_u_flx, srf_v_flx, cosphi, tanphi

call init(km, jm, Rd, Cpd, g, nuv, lat, lev, T, cosphi, tanphi, dphi, theta, p, dp, eta)

call surface(km, jm, do_srf_mom_flx, do_srf_sen_flx, do_srf_lat_flx, &
     Rd, eps, Cd, u0, ps, Ts, p, T, U, V, q, &
     srf_q_flx, srf_T_flx, srf_u_flx, srf_v_flx)

Uinc_vert=0.
Vinc_vert=0.
call implicit_vertical_diffusion(km, jm,          &
     dt, dp, g, Pr, eta, p, theta, U, V, q, srf_q_flx, srf_T_flx, srf_u_flx, srf_v_flx,  &
     Tinc, Uinc_vert, Vinc_vert, qinc)

Uinc_horiz=0.
call implicit_horizontal_diffusion(km, jm, &
      dt, dphi, r, nuv, cosphi, tanphi, U, &
      Uinc_horiz)

Vinc_horiz=0.
call implicit_horizontal_diffusion(km, jm, &
      dt, dphi, r, nuv, cosphi, tanphi, V, &
      Vinc_horiz)

Uinc        = Uinc_vert + Uinc_horiz
Vinc        = Vinc_vert + Vinc_horiz
Tinc        = Tinc*(p/lev(km)/100.)**(Rd/Cpd)
srf_lat_flx = -Lv*srf_q_flx*1.e-3
srf_sen_flx = -Cpd*srf_T_flx

end subroutine main


!------------------------------------------------------------------------------
! MODULE: math
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
! @description:
!> Module containing recurring math options
!------------------------------------------------------------------------------
MODULE math

USE ISO_FORTRAN_ENV
USE global_std
USE strings

IMPLICIT NONE

REAL(KIND=rk), PARAMETER :: num_zero   = 1.E-9
REAL(KIND=rk), PARAMETER :: sq2        = sqrt(2._rk)
REAL(KIND=rk), PARAMETER :: pi         = 4.D0*DATAN(1.D0)       !acos(-1._rk)
REAL(KIND=rk), PARAMETER :: pihalf     = 4.D0*DATAN(1.D0)/2._rk !acos(-1._rk)
REAL(KIND=rk), PARAMETER :: inv180     = 1._rk/180._rk
REAL(KIND=rk), PARAMETER :: pi_div_180 = acos(-1._rk)/180._rk   ! * deg = rad
REAL(KIND=rk), PARAMETER :: div_180_pi = 180._rk/acos(-1._rk)   ! * rad = deg

!-- Higher dimensional numbers
TYPE duaternion
   REAL (KIND=rk) :: w,x,y,z
END TYPE duaternion
TYPE suaternion
   REAL (KIND=rk) :: w,x,y,z
END TYPE suaternion
INTERFACE zero_thres
   MODULE PROCEDURE zerothres_num
   MODULE PROCEDURE zerothres_OnD
   MODULE PROCEDURE zerothres_TwD
   MODULE PROCEDURE zerothres_ThD
END INTERFACE zero_thres

! INTERFACE eul_2_un_quat
!     MODULE PROCEDURE eul_2_un_quat_rk
!     MODULE PROCEDURE eul_2_un_quat_sk
! END INTERFACE eul_2_un_quat

! INTERFACE check_un_quat
!     MODULE PROCEDURE check_un_quat_rk
!     MODULE PROCEDURE check_un_quat_sk
! END INTERFACE check_un_quat

! INTERFACE quat_norm
!     MODULE PROCEDURE quat_norm_rk
!     MODULE PROCEDURE quat_norm_sk
! END INTERFACE quat_norm

! INTERFACE q_add
!     MODULE PROCEDURE q_add_rk
!     MODULE PROCEDURE q_add_sk
! END INTERFACE q_add

! INTERFACE q_mult
!     MODULE PROCEDURE q_mult_rk
!     MODULE PROCEDURE q_mult_sk
! END INTERFACE q_mult

! INTERFACE q_dvd
!     MODULE PROCEDURE q_dvd_rk
!     MODULE PROCEDURE q_dvd_sk
! END INTERFACE q_dvd

! INTERFACE quat_prod
!     MODULE PROCEDURE quat_prod_rk
!     MODULE PROCEDURE quat_prod_sk
! END INTERFACE quat_prod

! INTERFACE conjugate_quat
!     MODULE PROCEDURE conjugate_quat_rk
!     MODULE PROCEDURE conjugate_quat_sk
! END INTERFACE conjugate_quat

! INTERFACE rotate_point
!     MODULE PROCEDURE rotate_point_rk
!     MODULE PROCEDURE rotate_point_sk
! END INTERFACE rotate_point

! INTERFACE quat_2_rot_mat
!     MODULE PROCEDURE quat_2_rot_mat_rk
!     MODULE PROCEDURE quat_2_rot_mat_sk
! END INTERFACE quat_2_rot_mat

! INTERFACE crpr
!     MODULE PROCEDURE crpr_rk
!     MODULE PROCEDURE crpr_sk
! END INTERFACE crpr

! INTERFACE dist_pnt_pln_by_pnts
!     MODULE PROCEDURE dist_pnt_pln_by_pnts_rk
!     MODULE PROCEDURE dist_pnt_pln_by_pnts_sk
! END INTERFACE dist_pnt_pln_by_pnts

CONTAINS

!------------------------------------------------------------------------------
! SUBROUTINE: transpose_mat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Spatially transpose a R6x6 matrix (2nd rank tensor).
!
!> @param[in] tensor_in Input tensor
!> @param[in] pos_in Requested combination of euler angles.
!> @param[out] tensor_out Output tensor
!------------------------------------------------------------------------------
SUBROUTINE transpose_mat (tensor_in, pos_in, tensor_out)

     REAL(KIND=rk), DIMENSION(6,6), INTENT(IN)  :: tensor_in
     REAL(KIND=rk), DIMENSION(3)  , INTENT(IN)  :: pos_in
     REAL(KIND=rk), DIMENSION(6,6), INTENT(OUT) :: tensor_out

     REAL(KIND=rk)                 :: alpha, phi, eta
     REAL(KIND=rk), DIMENSION(3)   :: n
     REAL(KIND=rk), DIMENSION(3,3) :: aa
     REAL(KIND=rk), DIMENSION(6,6) :: BB

     !------------------------------------------------------------------------------
     !  Degrees as input, radian as output to sin/cos
     !------------------------------------------------------------------------------
     alpha = REAL(pos_in(1)) * pi / 180._rk
     phi   = REAL(pos_in(2)) * pi / 180._rk
     eta   = REAL(pos_in(3)) * pi / 180._rk

     n = [ COS(phi)*SIN(eta), SIN(phi)*SIN(eta), COS(eta) ]

     n = n / SQRT(SUM(n*n))

     aa = rot_alg(n, alpha)

     BB = tra_R6(aa)

     tensor_out = MATMUL(MATMUL(TRANSPOSE(BB), tensor_in), BB)

END SUBROUTINE transpose_mat

!------------------------------------------------------------------------------
! FUNCTION: rot_x
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_x(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ 1._rk ,   0._rk    ,   0._rk     ]
    aa(2,:) = [ 0._rk , cos(angle) , -sin(angle) ]
    aa(3,:) = [ 0._rk , sin(angle) ,  cos(angle) ]

End Function rot_x

!------------------------------------------------------------------------------
! FUNCTION: rot_y
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_y(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ cos(angle), 0._rk,  sin(angle) ]
    aa(2,:) = [   0._rk   , 1._rk,   0._rk     ]
    aa(3,:) = [-sin(angle), 0._rk,  cos(angle) ]

End Function rot_y

!------------------------------------------------------------------------------
! FUNCTION: rot_z
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_z(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ cos(angle), -sin(angle), 0._rk ]
    aa(2,:) = [ sin(angle),  cos(angle), 0._rk ]
    aa(3,:) = [   0._rk   ,   0._rk    , 1._rk ]

End Function rot_z

!------------------------------------------------------------------------------
! FUNCTION: rot_alg
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> last edited : on  05.03.2009
!
!> @param[in]  axis Axis
!> @param[in]  angle Angle
!> @return[out] rr Output transformation matrix
!------------------------------------------------------------------------------
Function rot_alg(axis, angle) Result(rr)

    real(kind=rk), dimension(3), Intent(In) :: axis
    real(kind=rk)              , Intent(In) :: angle
    real(kind=rk), dimension(3, 3) :: rr

    !** normalize rotation axis ***********************************************
    !axis = axis / sqrt(sum(axis*axis))

    !** Setup transformation matrix *******************************************
    rr(1,1) = cos(angle) + axis(1)*axis(1)* (1._8 - cos(angle))
    rr(1,2) = axis(1)*axis(2)* (1._8 - cos(angle)) - axis(3) * sin(angle)
    rr(1,3) = axis(1)*axis(3)* (1._8 - cos(angle)) + axis(2) * sin(angle)

    rr(2,1) = axis(2)*axis(1)* (1._8 - cos(angle)) + axis(3) * sin(angle)
    rr(2,2) = cos(angle) + axis(2)*axis(2)* (1._8 - cos(angle))
    rr(2,3) = axis(2)*axis(3)* (1._8 - cos(angle)) - axis(1) * sin(angle)

    rr(3,1) = axis(3)*axis(1)* (1._8 - cos(angle)) - axis(2) * sin(angle)
    rr(3,2) = axis(3)*axis(2)* (1._8 - cos(angle)) + axis(1) * sin(angle)
    rr(3,3) = cos(angle) + axis(3)*axis(3)* (1._8 - cos(angle))

End Function rot_alg

!------------------------------------------------------------------------------
! FUNCTION: tra_R6
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @brief
!> Transformation matrix for R6x6
!
!> @param[in]  aa Input matrix
!> @return[out] BB Output matrix
!------------------------------------------------------------------------------
Function tra_R6(aa) Result(BB)

    Real(kind=rk), Dimension(3,3), intent(in) :: aa
    Real(kind=rk), Dimension(6,6) :: BB

    BB(1,:) = [ aa(1,1)**2 , aa(1,2)**2 , aa(1,3)**2 , sq2*aa(1,1)*aa(1,2) , sq2*aa(1,1)*aa(1,3), sq2*aa(1,2)*aa(1,3) ]
    BB(2,:) = [ aa(2,1)**2 , aa(2,2)**2 , aa(2,3)**2 , sq2*aa(2,1)*aa(2,2) , sq2*aa(2,1)*aa(2,3), sq2*aa(2,2)*aa(2,3) ]
    BB(3,:) = [ aa(3,1)**2 , aa(3,2)**2 , aa(3,3)**2 , sq2*aa(3,1)*aa(3,2) , sq2*aa(3,1)*aa(3,3), sq2*aa(3,2)*aa(3,3) ]

    BB(4,:) = [ sq2*aa(2,1)*aa(1,1) , sq2*aa(2,2)*aa(1,2) , sq2*aa(2,3)*aa(1,3) , &
        aa(2,1)*aa(1,2)+aa(2,2)*aa(1,1) , aa(2,1)*aa(1,3)+aa(2,3)*aa(1,1) , aa(2,2)*aa(1,3)+aa(2,3)*aa(1,2) ]
    BB(5,:) = [ sq2*aa(1,1)*aa(3,1) , sq2*aa(1,2)*aa(3,2) , sq2*aa(1,3)*aa(3,3) ,  &
        aa(1,1)*aa(3,2)+aa(1,2)*aa(3,1) , aa(1,1)*aa(3,3)+aa(1,3)*aa(3,1) , aa(1,2)*aa(3,3)+aa(1,3)*aa(3,2) ]
    BB(6,:) = [ sq2*aa(2,1)*aa(3,1) , sq2*aa(2,2)*aa(3,2) , sq2*aa(2,3)*aa(3,3) ,  &
        aa(2,1)*aa(3,2)+aa(2,2)*aa(3,1) , aa(2,1)*aa(3,3)+aa(2,3)*aa(3,1) , aa(2,2)*aa(3,3)+aa(2,3)*aa(3,2) ]

End Function tra_R6

!------------------------------------------------------------------------------
! SUBROUTINE: check_sym
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Check the symmetry of an arbitrarily sized matrix.
!
!> @Description
!> Average percentage of deviation of minor diagonals.
!
!> @param[in]  matin Input Matrix
!> @param[out] matout Output Matrix
!------------------------------------------------------------------------------
SUBROUTINE check_sym(matin, sym)

    REAL(KIND=rk), DIMENSION(:,:), INTENT(IN)  :: matin
    REAL(KIND=rk)                , INTENT(OUT) :: sym

    INTEGER(KIND=ik) :: ii, jj
    REAL(KIND=rk) :: cummu, entry_counter

    !------------------------------------------------------------------------------
    ! Calculate the differences to get the information of symmetry
    ! Earlier version...
    !------------------------------------------------------------------------------

    cummu = 0._rk
    ii=1_ik
    entry_counter = 0._rk
    DO WHILE (ii < SIZE(matin, DIM=1))

        jj=2_ik
        DO WHILE (jj <= SIZE(matin, DIM=2))
            cummu = cummu + (matin(ii,jj) /  matin(jj,ii))

            !------------------------------------------------------------------------------
            ! How many entries are averaged?
            !------------------------------------------------------------------------------
            entry_counter = entry_counter + 1._rk

            jj = jj + 1_ik
        END DO

        ii = ii + 1_ik
    END DO

    !------------------------------------------------------------------------------
    ! 1 - sym quotient to compare to 0
    !------------------------------------------------------------------------------
    sym = 1._rk - (cummu / entry_counter)
END SUBROUTINE check_sym

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_num
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets a scalar=0 in case it is less than 10^(-11) by default
!
!> @param[in] num Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_num(num, thres)

    REAL(KIND=rk), INTENT(INOUT) :: num
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    IF (num >= 0._rk) THEN
        IF (num <=  thres_u) num = 0._rk
    ELSE
        IF (num >= -thres_u) num = 0._rk
    END IF

END SUBROUTINE zerothres_num

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_OnD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets a vector=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_OnD(oneD, thres)

    REAL(KIND=rk), DIMENSION(:), INTENT(INOUT) :: oneD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO ii=1, SIZE(oneD)
        IF (oneD(ii) >= 0._rk) THEN
            IF (oneD(ii) <=  thres_u) oneD(ii) = 0._rk
        ELSE
            IF (oneD(ii) >= -thres_u) oneD(ii) = 0._rk
        END IF
    END DO
END SUBROUTINE zerothres_OnD

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_TwD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets an array=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_TwD(TwD, thres)

    REAL(KIND=rk), DIMENSION(:,:), INTENT(INOUT) :: TwD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii, jj

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO jj=1, SIZE(TwD, 2)
    DO ii=1, SIZE(TwD, 1)
        IF (TwD(ii, jj) >= 0._rk) THEN
            IF (TwD(ii, jj) <=  thres_u) TwD(ii, jj) = 0._rk
        ELSE
            IF (TwD(ii, jj) >= -thres_u) TwD(ii, jj) = 0._rk
        END IF
    END DO
    END DO
END SUBROUTINE zerothres_TwD

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_ThD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets an array=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_ThD(ThD, thres)

    REAL(KIND=rk), DIMENSION(:, :, :), INTENT(INOUT) :: ThD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii, jj, kk

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO kk=1, SIZE(ThD, 3)
    DO jj=1, SIZE(ThD, 2)
    DO ii=1, SIZE(ThD, 1)
        IF (ThD(ii, jj, kk) >= 0._rk) THEN
            IF (ThD(ii, jj, kk) <=  thres_u) ThD(ii, jj, kk) = 0._rk
        ELSE
            IF (ThD(ii, jj, kk) >= -thres_u) ThD(ii, jj, kk) = 0._rk
        END IF
    END DO
    END DO
    END DO
END SUBROUTINE zerothres_ThD

!------------------------------------------------------------------------------
! FUNCTION: eul_2_un_quat_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Returns a unit Quaternion based on 3 Euler Angles [radians]
!
!> @description
!> euler_radians(1) -> x-axis -> "alpha"
!> euler_radians(2) -> y-axis -> "beta"
!> euler_radians(3) -> z-axis -> "gamma"
!
!> @param[in] euler_radians Euler radians
!> @return eul_2_un_quat_rk Unit Quaternion
!------------------------------------------------------------------------------
FUNCTION eul_2_un_quat_rk (euler_radians)

    REAL(KIND=rk), DIMENSION(3) :: euler_radians, radians
    TYPE(duaternion) :: eul_2_un_quat_rk

    REAL (KIND=rk) :: ca, cb, cg, sa, sb, sg

    radians = euler_radians * 0.5_rk ! angle/2 to get a quaternion!

    ca = COS(radians(1))
    sa = SIN(radians(1))
    cb = COS(radians(2))
    sb = SIN(radians(2))
    cg = COS(radians(3))
    sg = SIN(radians(3))

    eul_2_un_quat_rk%w = ca * cb * cg + sa * sb * sg
    eul_2_un_quat_rk%x = sa * cb * cg - ca * sb * sg
    eul_2_un_quat_rk%y = ca * sb * cg + sa * cb * sg
    eul_2_un_quat_rk%z = ca * cb * sg - sa * sb * cg

END FUNCTION eul_2_un_quat_rk

!------------------------------------------------------------------------------
! FUNCTION: check_un_quat_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Check whether it is a uni quaternion
!
!> @param[in] quat Quaternion
!> @return check_un_quat_rk True or false
!------------------------------------------------------------------------------
FUNCTION check_un_quat_rk (quat)

    TYPE(duaternion) :: quat
    LOGICAL :: check_un_quat_rk

    REAL(KIND=rk) :: rslt

    rslt = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

    IF (rslt-1_rk <= num_zero) THEN
        check_un_quat_rk = .TRUE.
    ELSE
        check_un_quat_rk = .FALSE.
    END IF

END FUNCTION check_un_quat_rk

!------------------------------------------------------------------------------
! FUNCTION: quat_norm_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion norm
!
!> @param[in] quat Quaternion
!> @return quat_norm_rk Norm of the quaternion
!------------------------------------------------------------------------------
FUNCTION quat_norm_rk (quat)

    TYPE(duaternion) :: quat
    REAL(KIND=rk) :: quat_norm_rk

    quat_norm_rk = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

END FUNCTION quat_norm_rk

!------------------------------------------------------------------------------
! FUNCTION: q_add_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Add a scalar to a quaternion. Also works with negative scalars.
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add_rk Result of the addition
!------------------------------------------------------------------------------
FUNCTION q_add_rk(q1, scalar)

    TYPE(duaternion) :: q1, q_add_rk
    REAL(KIND=rk) :: scalar

    q_add_rk%w = q1%w + scalar
    q_add_rk%x = q1%x + scalar
    q_add_rk%y = q1%y + scalar
    q_add_rk%z = q1%z + scalar

END FUNCTION q_add_rk

!------------------------------------------------------------------------------
! FUNCTION: q_mult_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion multiplication. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the multiplication
!------------------------------------------------------------------------------
FUNCTION q_mult_rk (q1, scalar)

    TYPE(duaternion) :: q1, q_mult_rk
    REAL(KIND=rk) :: scalar

    q_mult_rk%w = q1%w * scalar
    q_mult_rk%x = q1%x * scalar
    q_mult_rk%y = q1%y * scalar
    q_mult_rk%z = q1%z * scalar

END FUNCTION q_mult_rk

!------------------------------------------------------------------------------
! FUNCTION: q_dvd_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the division
!------------------------------------------------------------------------------
FUNCTION q_dvd_rk (q1, scalar)

    TYPE(duaternion) :: q1, q_dvd_rk
    REAL(KIND=rk) :: scalar

    q_dvd_rk%w = q1%w / scalar
    q_dvd_rk%x = q1%x / scalar
    q_dvd_rk%y = q1%y / scalar
    q_dvd_rk%z = q1%z / scalar

END FUNCTION q_dvd_rk

!------------------------------------------------------------------------------
! FUNCTION: quat_prod_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod_rk!
!
!> @param[in] q1 Quaternion
!> @param[in] q2 Quaternion
!> @return quat_prod_rk Result of the quaternion multiplication
!------------------------------------------------------------------------------
FUNCTION quat_prod_rk (q1, q2)

    TYPE(duaternion) :: q1, q2, quat_prod_rk

    quat_prod_rk%w = q1%w*q2%w-q1%x*q2%x-q1%y*q2%y-q1%z*q2%z
    quat_prod_rk%x = q1%w*q2%x+q1%x*q2%w+q1%y*q2%z-q1%z*q2%y
    quat_prod_rk%y = q1%w*q2%y-q1%x*q2%z+q1%y*q2%w+q1%z*q2%x
    quat_prod_rk%z = q1%w*q2%z+q1%x*q2%y-q1%y*q2%x+q1%z*q2%w

END FUNCTION quat_prod_rk

!------------------------------------------------------------------------------
! FUNCTION: conjugate_quat_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Conjugate quaternion.
!
!> @param[in] quat Quaternion
!> @return conjugate_quat_rk Conjugate quaternion
!------------------------------------------------------------------------------
FUNCTION conjugate_quat_rk(quat)

    TYPE(duaternion) :: quat, conjugate_quat_rk

    conjugate_quat_rk%w =   quat%w
    conjugate_quat_rk%x = - quat%x
    conjugate_quat_rk%y = - quat%y
    conjugate_quat_rk%z = - quat%z

END FUNCTION conjugate_quat_rk

!------------------------------------------------------------------------------
! FUNCTION: rotate_point_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Rotate a point with quaternions. Takes a unit quaternion as input
!
!> @param[in] quat Quaternion
!> @param[in] point Point to rotate with quaternion.
!> @return rotate_point_rk Rotated point.
!------------------------------------------------------------------------------
FUNCTION rotate_point_rk(quat, point)

    TYPE(duaternion) :: quat
    REAL(KIND=rk), DIMENSION(3) :: point, rotate_point_rk

    TYPE(duaternion) :: pnt, rtt_pnt

    pnt%w = 0._rk
    pnt%x = point(1)
    pnt%y = point(2)
    pnt%z = point(3)

    rtt_pnt = quat_prod_rk(quat_prod_rk(quat, pnt), conjugate_quat_rk(quat))

    rotate_point_rk(1) = rtt_pnt%x
    rotate_point_rk(2) = rtt_pnt%y
    rotate_point_rk(3) = rtt_pnt%z

END FUNCTION rotate_point_rk

!------------------------------------------------------------------------------
! FUNCTION: quat_2_rot_mat_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion to rotation matrix.
!
!> @param[in] q Quaternion
!> @return quat_2_rot_mat_rk Rotation matrix
!------------------------------------------------------------------------------
FUNCTION quat_2_rot_mat_rk(q)

    TYPE(duaternion) :: q
    REAL(KIND=rk), DIMENSION(3,3) :: quat_2_rot_mat_rk

    quat_2_rot_mat_rk(1,:) = [ q%w**2 + q%x**2 - q%y**2 - q%z**2  , &
        2._rk*q%x*q%y - 2._rk*q%w*q%z , 2._rk*q%x*q%z - 2._rk*q%w*q%y  ]
    quat_2_rot_mat_rk(2,:) = [ 2._rk*q%x*q%y + 2._rk*q%w*q%z , &
        q%w**2 - q%x**2 + q%y**2 + - q%z**2 , 2._rk*q%y*q%z - 2._rk*q%w*q%x ]
    quat_2_rot_mat_rk(3,:) = [ 2._rk*q%x*q%z - 2._rk*q%w*q%y , &
        2._rk*q%y*q%z + 2._rk*q%w*q%x , q%w**2 - q%x**2 - q%y**2 + q%z**2   ]

END FUNCTION quat_2_rot_mat_rk

!------------------------------------------------------------------------------
! FUNCTION: eul_2_un_quat_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Returns a unit Quaternion based on 3 Euler Angles [radians]
!
!> @description
!> euler_radians(1) -> x-axis -> "alpha"
!> euler_radians(2) -> y-axis -> "beta"
!> euler_radians(3) -> z-axis -> "gamma"
!
!> @param[in] euler_radians Euler radians
!> @return eul_2_un_quat_sk Unit Quaternion
!------------------------------------------------------------------------------
FUNCTION eul_2_un_quat_sk (euler_radians)

    REAL(KIND=sk) , DIMENSION(3) :: euler_radians, radians
    TYPE(suaternion) :: eul_2_un_quat_sk

    REAL (KIND=sk) :: ca, cb, cg, sa, sb, sg

    radians = euler_radians * 0.5_rk ! angle/2 to get a quaternion!

    ca = COS(radians(1))
    sa = SIN(radians(1))
    cb = COS(radians(2))
    sb = SIN(radians(2))
    cg = COS(radians(3))
    sg = SIN(radians(3))

    eul_2_un_quat_sk%w = ca * cb * cg + sa * sb * sg
    eul_2_un_quat_sk%x = sa * cb * cg - ca * sb * sg
    eul_2_un_quat_sk%y = ca * sb * cg + sa * cb * sg
    eul_2_un_quat_sk%z = ca * cb * sg - sa * sb * cg

END FUNCTION eul_2_un_quat_sk

!------------------------------------------------------------------------------
! FUNCTION: check_un_quat_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Check whether it is a uni quaternion
!
!> @param[in] quat Quaternion
!> @return check_un_quat_sk True or false
!------------------------------------------------------------------------------
FUNCTION check_un_quat_sk (quat)

    TYPE(suaternion) :: quat
    LOGICAL :: check_un_quat_sk

    REAL(KIND=sk) :: rslt

    rslt = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

    IF (rslt-1_rk <= num_zero) THEN
        check_un_quat_sk = .TRUE.
    ELSE
        check_un_quat_sk = .FALSE.
    END IF

END FUNCTION check_un_quat_sk

!------------------------------------------------------------------------------
! FUNCTION: quat_norm_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion norm
!
!> @param[in] quat Quaternion
!> @return quat_norm_sk Norm of the quaternion
!------------------------------------------------------------------------------
FUNCTION quat_norm_sk (quat)

    TYPE(suaternion) :: quat
    REAL(KIND=sk) :: quat_norm_sk

    quat_norm_sk = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

END FUNCTION quat_norm_sk

!------------------------------------------------------------------------------
! FUNCTION: q_add_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Add a scalar to a quaternion. Also works with negative scalars.
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add_sk Result of the addition
!------------------------------------------------------------------------------
FUNCTION q_add_sk(q1, scalar)

    TYPE(suaternion) :: q1, q_add_sk
    REAL(KIND=sk) :: scalar

    q_add_sk%w = q1%w + scalar
    q_add_sk%x = q1%x + scalar
    q_add_sk%y = q1%y + scalar
    q_add_sk%z = q1%z + scalar

END FUNCTION q_add_sk

!------------------------------------------------------------------------------
! FUNCTION: q_mult_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion multiplication. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the multiplication
!------------------------------------------------------------------------------
FUNCTION q_mult_sk (q1, scalar)

    TYPE(suaternion) :: q1, q_mult_sk
    REAL(KIND=sk) :: scalar

    q_mult_sk%w = q1%w * scalar
    q_mult_sk%x = q1%x * scalar
    q_mult_sk%y = q1%y * scalar
    q_mult_sk%z = q1%z * scalar

END FUNCTION q_mult_sk

!------------------------------------------------------------------------------
! FUNCTION: q_dvd_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the division
!------------------------------------------------------------------------------
FUNCTION q_dvd_sk (q1, scalar)

    TYPE(suaternion) :: q1, q_dvd_sk
    REAL(KIND=sk) :: scalar

    q_dvd_sk%w = q1%w / scalar
    q_dvd_sk%x = q1%x / scalar
    q_dvd_sk%y = q1%y / scalar
    q_dvd_sk%z = q1%z / scalar

END FUNCTION q_dvd_sk

!------------------------------------------------------------------------------
! FUNCTION: quat_prod_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod_sk!
!
!> @param[in] q1 Quaternion
!> @param[in] q2 Quaternion
!> @return quat_prod_sk Result of the quaternion multiplication
!------------------------------------------------------------------------------
FUNCTION quat_prod_sk (q1, q2)

    TYPE(suaternion) :: q1, q2, quat_prod_sk

    quat_prod_sk%w = q1%w*q2%w-q1%x*q2%x-q1%y*q2%y-q1%z*q2%z
    quat_prod_sk%x = q1%w*q2%x+q1%x*q2%w+q1%y*q2%z-q1%z*q2%y
    quat_prod_sk%y = q1%w*q2%y-q1%x*q2%z+q1%y*q2%w+q1%z*q2%x
    quat_prod_sk%z = q1%w*q2%z+q1%x*q2%y-q1%y*q2%x+q1%z*q2%w

END FUNCTION quat_prod_sk

!------------------------------------------------------------------------------
! FUNCTION: conjugate_quat_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Conjugate quaternion.
!
!> @param[in] quat Quaternion
!> @return conjugate_quat_sk Conjugate quaternion
!------------------------------------------------------------------------------
FUNCTION conjugate_quat_sk(quat)

    TYPE(suaternion) :: quat, conjugate_quat_sk

    conjugate_quat_sk%w =   quat%w
    conjugate_quat_sk%x = - quat%x
    conjugate_quat_sk%y = - quat%y
    conjugate_quat_sk%z = - quat%z

END FUNCTION conjugate_quat_sk

!------------------------------------------------------------------------------
! FUNCTION: rotate_point_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Rotate a point with quaternions. Takes a unit quaternion as input
!
!> @param[in] quat Quaternion
!> @param[in] point Point to rotate with quaternion.
!> @return rotate_point_sk Rotated point.
!------------------------------------------------------------------------------
FUNCTION rotate_point_sk(quat, point)

    TYPE(suaternion) :: quat
    REAL(KIND=sk), DIMENSION(3) :: point, rotate_point_sk

    TYPE(suaternion) :: pnt, rtt_pnt

    pnt%w = 0._rk
    pnt%x = point(1)
    pnt%y = point(2)
    pnt%z = point(3)

    rtt_pnt = quat_prod_sk(quat_prod_sk(quat, pnt), conjugate_quat_sk(quat))

    rotate_point_sk(1) = rtt_pnt%x
    rotate_point_sk(2) = rtt_pnt%y
    rotate_point_sk(3) = rtt_pnt%z

END FUNCTION rotate_point_sk

!------------------------------------------------------------------------------
! FUNCTION: quat_2_rot_mat_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion to rotation matrix.
!
!> @param[in] q Quaternion
!> @return quat_2_rot_mat_sk Rotation matrix
!------------------------------------------------------------------------------
FUNCTION quat_2_rot_mat_sk(q)

    TYPE(suaternion) :: q
    REAL(KIND=rk), DIMENSION(3,3) :: quat_2_rot_mat_sk

    quat_2_rot_mat_sk(1,:) = [ q%w**2 + q%x**2 - q%y**2 - q%z**2  , &
        2._rk*q%x*q%y - 2._rk*q%w*q%z , 2._rk*q%x*q%z - 2._rk*q%w*q%y  ]
    quat_2_rot_mat_sk(2,:) = [ 2._rk*q%x*q%y + 2._rk*q%w*q%z , &
        q%w**2 - q%x**2 + q%y**2 + - q%z**2 , 2._rk*q%y*q%z - 2._rk*q%w*q%x ]
    quat_2_rot_mat_sk(3,:) = [ 2._rk*q%x*q%z - 2._rk*q%w*q%y , &
        2._rk*q%y*q%z + 2._rk*q%w*q%x , q%w**2 - q%x**2 - q%y**2 + q%z**2   ]

END FUNCTION quat_2_rot_mat_sk

!------------------------------------------------------------------------------
! FUNCTION: crpr_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Cross product of two vectors
!
!> @param[in] a Vector
!> @param[in] b Vector
!> @return crpr_rk Cross product
!------------------------------------------------------------------------------
FUNCTION crpr_rk(a, b)

    REAL(KIND=rk), DIMENSION(3) :: crpr_rk,a,b

    crpr_rk(1) = a(2) * b(3) - a(3) * b(2)
    crpr_rk(2) = a(3) * b(1) - a(1) * b(3)
    crpr_rk(3) = a(1) * b(2) - a(2) * b(1)

END FUNCTION crpr_rk

!------------------------------------------------------------------------------
! FUNCTION: crpr_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Cross product of two vectors
!
!> @param[in] a Vector
!> @param[in] b Vector
!> @return crpr_sk Cross product
!------------------------------------------------------------------------------
FUNCTION crpr_sk(a, b)

    REAL(KIND=sk), DIMENSION(3) :: crpr_sk,a,b

    crpr_sk(1) = a(2) * b(3) - a(3) * b(2)
    crpr_sk(2) = a(3) * b(1) - a(1) * b(3)
    crpr_sk(3) = a(1) * b(2) - a(2) * b(1)

END FUNCTION crpr_sk

!------------------------------------------------------------------------------
! FUNCTION: dist_pnt_pln_by_pnts_rk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Calculates the distance of a point to a plane, given by three points.
!> https://www.mathepower.com/ebenengleichungen.php :-)
!
!> @param[in] pp1 Point 1 of the plane
!> @param[in] pp2 Point 2 of the plane
!> @param[in] pp3 Point 3 of the plane
!> @param[in] p Point
!> @return[out] di Distance
!------------------------------------------------------------------------------
FUNCTION dist_pnt_pln_by_pnts_rk(pp1, pp2, pp3, p) Result(di)

REAL(KIND=rk), dimension(3), Intent(IN) :: pp1, pp2, pp3, p
REAL(KIND=rk), dimension(3) :: nn, unitv
REAL(KIND=rk):: di, magni

!------------------------------------------------------------------------------
! The normal to the plane
!------------------------------------------------------------------------------
nn = crpr_rk(pp1-pp3, pp1-pp2)

!------------------------------------------------------------------------------
! Magnitude of the normal to the plane
!------------------------------------------------------------------------------
magni = SQRT(DOT_PRODUCT(nn, nn))

!------------------------------------------------------------------------------
! Unit vector
!------------------------------------------------------------------------------
unitv = nn / magni

di = DOT_PRODUCT(unitv, [p(1)-pp1(1), p(2)-pp1(2), p(3)-pp1(3)])

END FUNCTION dist_pnt_pln_by_pnts_rk

!------------------------------------------------------------------------------
! FUNCTION: dist_pnt_pln_by_pnts_sk
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Calculates the distance of a point to a plane, given by three points.
!> https://www.mathepower.com/ebenengleichungen.php :-)
!
!> @param[in] pp1 Point 1 of the plane
!> @param[in] pp2 Point 2 of the plane
!> @param[in] pp3 Point 3 of the plane
!> @param[in] p Point
!> @return[out] di Distance
!------------------------------------------------------------------------------
FUNCTION dist_pnt_pln_by_pnts_sk(pp1, pp2, pp3, p) Result(di)

REAL(KIND=sk), dimension(3), Intent(IN) :: pp1, pp2, pp3, p
REAL(KIND=sk), dimension(3) :: nn, unitv
REAL(KIND=sk):: di, magni

!------------------------------------------------------------------------------
! The normal to the plane
!------------------------------------------------------------------------------
nn = crpr_sk(pp1-pp3, pp1-pp2)

!------------------------------------------------------------------------------
! Magnitude of the normal to the plane
!------------------------------------------------------------------------------
magni = SQRT(DOT_PRODUCT(nn, nn))

!------------------------------------------------------------------------------
! Unit vector
!------------------------------------------------------------------------------
unitv = nn / magni

di = DOT_PRODUCT(unitv, [p(1)-pp1(1), p(2)-pp1(2), p(3)-pp1(3)])

END FUNCTION dist_pnt_pln_by_pnts_sk

END MODULE math


MODULE ReadEnvironmentBell

  ! mbp 12/2018, based on much older subroutine

  USE BellhopMod
  USE MathConstants
  USE sspmod
  USE AttenMod
  USE FatalError

  IMPLICIT NONE

CONTAINS
  SUBROUTINE ReadEnvironment( FileRoot, ThreeD )

    ! Routine to read in and echo all the input data
    ! Note that default values of SSP, DENSITY, Attenuation will not work

    USE anglemod
    USE SourceReceiverPositions

    REAL      (KIND=8), PARAMETER   :: c0 = 1500.0
    LOGICAL,            INTENT(IN ) :: ThreeD
    CHARACTER (LEN=80), INTENT(IN ) :: FileRoot
    INTEGER            :: NPts, NMedia, iostat
    REAL               :: ZMin, ZMax
    REAL      (KIND=8) :: x( 2 ), c, cimag, gradc( 2 ), crr, crz, czz, rho, sigma, Depth
    CHARACTER (LEN= 2) :: AttenUnit
    CHARACTER (LEN=10) :: PlotType

    WRITE( PRTFile, * ) 'BELLHOP/BELLHOP3D'
    WRITE( PRTFile, * )

    ! Open the environmental file
    OPEN( UNIT = ENVFile, FILE = TRIM( FileRoot ) // '.env', STATUS = 'OLD', IOSTAT = iostat, ACTION = 'READ' )
    IF ( IOSTAT /= 0 ) THEN   ! successful open?
       WRITE( PRTFile, * ) 'ENVFile = ', TRIM( FileRoot ) // '.env'
       CALL ERROUT( 'BELLHOP - READIN', 'Unable to open the environmental file' )
    END IF

    ! Prepend model name to title
    IF ( ThreeD ) THEN
       Title( 1 : 11 ) = 'BELLHOP3D- '
       READ(  ENVFile, * ) Title( 12 : 80 )
    ELSE
       Title( 1 :  9 ) = 'BELLHOP- '
       READ(  ENVFile, * ) Title( 10 : 80 )
    END IF

    WRITE( PRTFile, * ) Title

    READ(  ENVFile, *    ) freq
    WRITE( PRTFile, '('' frequency = '', G11.4, '' Hz'', / )' ) freq

    READ(  ENVFile, * ) NMedia
    WRITE( PRTFile, * ) 'Dummy parameter NMedia = ', NMedia
    IF ( NMedia /= 1 ) CALL ERROUT( 'READIN', &
         'Only one medium or layer is allowed in BELLHOP; sediment layers must be handled using a reflection coefficient' )

    CALL ReadTopOpt( Bdry%Top%HS%Opt, Bdry%Top%HS%BC, AttenUnit, FileRoot )

    ! *** Top BC ***

    IF ( Bdry%Top%HS%BC == 'A' ) WRITE( PRTFile, "( //, '   z (m)     alphaR (m/s)   betaR  rho (g/cm^3)  alphaI     betaI', / )" )

    CALL TopBot( freq, AttenUnit, Bdry%Top%HS )

    ! ****** Read in ocean SSP data ******

    READ(  ENVFile, * ) NPts, Sigma, Bdry%Bot%HS%Depth
    WRITE( PRTFile, * )
    WRITE( PRTFile, FMT = "( ' Depth = ', F10.2, ' m' )" ) Bdry%Bot%HS%Depth

    IF ( Bdry%Top%HS%Opt( 1 : 1 ) == 'A' ) THEN
       WRITE( PRTFile, * ) 'Analytic SSP option'
       ! following is hokey, should be set in Analytic routine
       SSP%NPts = 2
       SSP%z( 1 ) = 0.0
       SSP%z( 2 ) = Bdry%Bot%HS%Depth
    ELSE
       x = [ 0.0D0, Bdry%Bot%HS%Depth ]   ! tells SSP Depth to read to
       CALL EvaluateSSP( x, c, cimag, gradc, crr, crz, czz, rho, freq, 'INI' )
    ENDIF

    Bdry%Top%HS%Depth = SSP%z( 1 )   ! Depth of top boundary is taken from first SSP point
    ! bottom depth should perhaps be set the same way?

    ! *** Bottom BC ***
    Bdry%Bot%HS%Opt = '  '   ! initialize to blanks
    READ(  ENVFile, * ) Bdry%Bot%HS%Opt, Sigma
    WRITE( PRTFile, * )
    WRITE( PRTFile, FMT = "(33X, '( RMS roughness = ', G10.3, ' )' )" ) Sigma

    SELECT CASE ( Bdry%Bot%HS%Opt( 2 : 2 ) )
    CASE ( '~', '*' )
       WRITE( PRTFile, * ) '    Bathymetry file selected'
    CASE( '-', '_', ' ' )
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown bottom option letter in second position' )
    END SELECT

    Bdry%Bot%HS%BC = Bdry%Bot%HS%Opt( 1 : 1 )
    CALL TopBot( freq, AttenUnit, Bdry%Bot%HS )

    ! *** source and receiver locations ***

    CALL ReadSxSy( ThreeD )     ! Read source/receiver x-y coordinates

    ZMin = SNGL( Bdry%Top%HS%Depth )
    ZMax = SNGL( Bdry%Bot%HS%Depth )
    ! CALL ReadSzRz( ZMin + 100 * SPACING( ZMin ), ZMax - 100 * SPACING( ZMax ) )   ! not sure why I had this
    CALL ReadSzRz( ZMin, ZMax )
    CALL ReadRcvrRanges
    IF ( ThreeD ) CALL ReadRcvrBearings
    CALL ReadfreqVec( freq,  Bdry%Top%HS%Opt( 6:6 ) )
    CALL ReadRunType( Beam%RunType, PlotType )

    Depth = Zmax - Zmin   ! water depth
    CALL ReadRayElevationAngles( freq, Depth, Bdry%Top%HS%Opt, Beam%RunType )
    IF ( ThreeD ) CALL ReadRayBearingAngles(   freq, Bdry%Top%HS%Opt, Beam%RunType )

    WRITE( PRTFile, * )
    WRITE( PRTFile, * ) '__________________________________________________________________________'
    WRITE( PRTFile, * )

    ! Limits for tracing beams

    IF ( ThreeD ) THEN
       READ(  ENVFile, * ) Beam%deltas, Beam%Box%x, Beam%Box%y, Beam%Box%z
       Beam%Box%x = 1000.0 * Beam%Box%x   ! convert km to m
       Beam%Box%y = 1000.0 * Beam%Box%y   ! convert km to m

       IF ( Beam%deltas == 0.0 ) Beam%deltas = ( Bdry%Bot%HS%Depth - Bdry%Top%HS%Depth ) / 10.0   ! Automatic step size selection
       ! WRITE( PRTFile, '('' frequency = '', G11.4, '' Hz'', / )' ) freq

       WRITE( PRTFile, * )
       WRITE( PRTFile, fmt = '(  '' Step length,       deltas = '', G11.4, '' m'' )' ) Beam%deltas
       WRITE( PRTFile, * )
       WRITE( PRTFile, fmt = '(  '' Maximum ray x-range, Box%x = '', G11.4, '' m'' )' ) Beam%Box%x
       WRITE( PRTFile, fmt = '(  '' Maximum ray y-range, Box%y = '', G11.4, '' m'' )' ) Beam%Box%y
       WRITE( PRTFile, fmt = '(  '' Maximum ray z-range, Box%z = '', G11.4, '' m'' )' ) Beam%Box%z
    ELSE
       READ(  ENVFile, * ) Beam%deltas, Beam%Box%z, Beam%Box%r

       WRITE( PRTFile, * )
       WRITE( PRTFile, fmt = '(  '' Step length,       deltas = '', G11.4, '' m'' )' ) Beam%deltas
       WRITE( PRTFile, * )
       WRITE( PRTFile, fmt = '(  '' Maximum ray depth, Box%z  = '', G11.4, '' m'' )' ) Beam%Box%z
       WRITE( PRTFile, fmt = '(  '' Maximum ray range, Box%r  = '', G11.4, ''km'' )' ) Beam%Box%r

       Beam%Box%r = 1000.0 * Beam%Box%r   ! convert km to m
    END IF

    ! *** Beam characteristics ***
       Beam%Type( 4 : 4 ) = Beam%RunType( 7 : 7 )   ! selects beam shift option

       SELECT CASE ( Beam%Type( 4 : 4 ) )
       CASE ( 'S' )
          WRITE( PRTFile, * ) 'Beam shift in effect'
       CASE DEFAULT
          WRITE( PRTFile, * ) 'No beam shift in effect'
       END SELECT

       IF ( Beam%RunType( 1 : 1 ) /= 'R' ) THEN   ! no worry about the beam type if this is a ray trace run

       ! Beam%Type( 1 : 1 ) is
       !   'G' or '^' Geometric hat beams in Cartesian coordinates
       !   'g' Geometric hat beams in ray-centered coordinates
       !   'B' Geometric Gaussian beams in Cartesian coordinates
       !   'b' Geometric Gaussian beams in ray-centered coordinates
       !   'S' Simple Gaussian beams
       !   'C' Cerveny Gaussian beams in Cartesian coordinates
       !   'R' Cerveny Gaussian beams in Ray-centered coordinates
       ! Beam%Type( 2 : 2 ) controls the setting of the beam width
       !   'F' space Filling
       !   'M' minimum width
       !   'W' WKB beams
       ! Beam%Type( 3 : 3 ) controls curvature changes on boundary reflections
       !   'D' Double
       !   'S' Single
       !   'Z' Zero
       ! Beam%Type( 4 : 4 ) selects whether beam shifts are implemented on boundary reflection
       !   'S' yes
       !   'N' no

       ! Curvature change can cause overflow in grazing case
       ! Suppress by setting BeamType( 3 : 3 ) = 'Z'

       Beam%Type( 1 : 1 ) = Beam%RunType( 2 : 2 )
       SELECT CASE ( Beam%Type( 1 : 1 ) )
       CASE ( 'G', 'g' , '^', 'B', 'b', 'S' )   ! geometric hat beams, geometric Gaussian beams, or simple Gaussian beams
       CASE ( 'R', 'C' )   ! Cerveny Gaussian Beams; read extra lines to specify the beam options
          READ(  ENVFile, * ) Beam%Type( 2 : 3 ), Beam%epsMultiplier, Beam%rLoop
          WRITE( PRTFile, * )
          WRITE( PRTFile, * )
          WRITE( PRTFile, * ) 'Type of beam = ', Beam%Type( 1 : 1 )

          SELECT CASE ( Beam%Type( 3 : 3 ) )
          CASE ( 'D' )
             WRITE( PRTFile, * ) 'Curvature doubling invoked'
          CASE ( 'Z' )
             WRITE( PRTFile, * ) 'Curvature zeroing invoked'
          CASE ( 'S' )
             WRITE( PRTFile, * ) 'Standard curvature condition'
          CASE DEFAULT
             CALL ERROUT( 'READIN', 'Unknown curvature condition' )
          END SELECT

          WRITE( PRTFile, * ) 'Epsilon multiplier', Beam%epsMultiplier
          WRITE( PRTFile, * ) 'Range for choosing beam width', Beam%rLoop

          ! Images, windows
          READ(  ENVFile, * ) Beam%Nimage, Beam%iBeamWindow, Beam%Component
          WRITE( PRTFile, * )
          WRITE( PRTFile, * ) 'Number of images, Nimage  = ', Beam%Nimage
          WRITE( PRTFile, * ) 'Beam windowing parameter  = ', Beam%iBeamWindow
          WRITE( PRTFile, * ) 'Component                 = ', Beam%Component
       CASE DEFAULT
          CALL ERROUT( 'READIN', 'Unknown beam type (second letter of run type)' )
       END SELECT
    END IF

    WRITE( PRTFile, * )
    CLOSE( ENVFile )

  END SUBROUTINE ReadEnvironment

  !**********************************************************************!

  SUBROUTINE ReadTopOpt( TopOpt, BC, AttenUnit, FileRoot )

    CHARACTER (LEN= 6), INTENT( OUT ) :: TopOpt
    CHARACTER (LEN= 1), INTENT( OUT ) :: BC                     ! Boundary condition type
    CHARACTER (LEN= 2), INTENT( OUT ) :: AttenUnit
    CHARACTER (LEN=80), INTENT( IN  ) :: FileRoot
    INTEGER            :: iostat

    TopOpt = '      '   ! initialize to blanks
    READ(  ENVFile, * ) TopOpt
    WRITE( PRTFile, * )

    SSP%Type  = TopOpt( 1 : 1 )
    BC        = TopOpt( 2 : 2 )
    AttenUnit = TopOpt( 3 : 4 )
    SSP%AttenUnit = AttenUnit

    ! SSP approximation options

    SELECT CASE ( SSP%Type )
    CASE ( 'N' )
       WRITE( PRTFile, * ) '    N2-linear approximation to SSP'
    CASE ( 'C' )
       WRITE( PRTFile, * ) '    C-linear approximation to SSP'
    CASE ( 'P' )
       WRITE( PRTFile, * ) '    PCHIP approximation to SSP'
    CASE ( 'S' )
       WRITE( PRTFile, * ) '    Spline approximation to SSP'
    CASE ( 'Q' )
       WRITE( PRTFile, * ) '    Quad approximation to SSP'
       OPEN ( FILE = TRIM( FileRoot ) // '.ssp', UNIT = SSPFile, FORM = 'FORMATTED', STATUS = 'OLD', IOSTAT = iostat )
       IF ( IOSTAT /= 0 ) THEN   ! successful open?
          WRITE( PRTFile, * ) 'SSPFile = ', TRIM( FileRoot ) // '.ssp'
          CALL ERROUT( 'BELLHOP - READIN', 'Unable to open the SSP file' )
       END IF
    CASE ( 'H' )
       WRITE( PRTFile, * ) '    Hexahedral approximation to SSP'
       OPEN ( FILE = TRIM( FileRoot ) // '.ssp', UNIT = SSPFile, FORM = 'FORMATTED', STATUS = 'OLD', IOSTAT = iostat )
       IF ( IOSTAT /= 0 ) THEN   ! successful open?
          WRITE( PRTFile, * ) 'SSPFile = ', TRIM( FileRoot ) // '.ssp'
          CALL ERROUT( 'BELLHOP - READIN', 'Unable to open the SSP file' )
       END IF
    CASE ( 'A' )
       WRITE( PRTFile, * ) '    Analytic SSP option'
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown option for SSP approximation' )
    END SELECT

    ! Attenuation options

    SELECT CASE ( AttenUnit( 1 : 1 ) )
    CASE ( 'N' )
       WRITE( PRTFile, * ) '    Attenuation units: nepers/m'
    CASE ( 'F' )
       WRITE( PRTFile, * ) '    Attenuation units: dB/mkHz'
    CASE ( 'M' )
       WRITE( PRTFile, * ) '    Attenuation units: dB/m'
    CASE ( 'W' )
       WRITE( PRTFile, * ) '    Attenuation units: dB/wavelength'
    CASE ( 'Q' )
       WRITE( PRTFile, * ) '    Attenuation units: Q'
    CASE ( 'L' )
       WRITE( PRTFile, * ) '    Attenuation units: Loss parameter'
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown attenuation units' )
    END SELECT

    ! optional addition of volume attenuation using standard formulas

    SELECT CASE ( AttenUnit( 2 : 2 ) )
    CASE ( 'T' )
       WRITE( PRTFile, * ) '    THORP volume attenuation added'
    CASE ( 'F' )
       WRITE( PRTFile, * ) '    Francois-Garrison volume attenuation added'
       READ(  ENVFile, * ) T, Salinity, pH, z_bar
       WRITE( PRTFile, "( ' T = ', G11.4, 'degrees   S = ', G11.4, ' psu   pH = ', G11.4, ' z_bar = ', G11.4, ' m' )" ) &
            T, Salinity, pH, z_bar
    CASE ( 'B' )
       WRITE( PRTFile, * ) '    Biological attenaution'
       READ( ENVFile, *  ) NBioLayers
       WRITE( PRTFile, * ) '      Number of Bio Layers = ', NBioLayers

       DO iBio = 1, NBioLayers
          READ( ENVFile, *  ) bio( iBio )%Z1, bio( iBio )%Z2, bio( iBio )%f0, bio( iBio )%Q, bio( iBio )%a0
          WRITE( PRTFile, * ) '      Top    of layer = ', bio( iBio )%Z1, ' m'
          WRITE( PRTFile, * ) '      Bottom of layer = ', bio( iBio )%Z2, ' m'
          WRITE( PRTFile, * ) '      Resonance frequency = ', bio( iBio )%f0, ' Hz'
          WRITE( PRTFile, * ) '      Q  = ', bio( iBio )%Q
          WRITE( PRTFile, * ) '      a0 = ', bio( iBio )%a0
       END DO
    CASE ( ' ' )
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown top option letter in fourth position' )
    END SELECT

    SELECT CASE ( TopOpt( 5 : 5 ) )
    CASE ( '~', '*' )
       WRITE( PRTFile, * ) '    Altimetry file selected'
    CASE ( '-', '_', ' ' )
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown top option letter in fifth position' )
    END SELECT

    SELECT CASE ( TopOpt( 6 : 6 ) )
    CASE ( 'I' )
       WRITE( PRTFile, * ) '    Development options enabled'
    CASE ( ' ' )
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown top option letter in sixth position' )
    END SELECT

  END SUBROUTINE ReadTopOpt

  !**********************************************************************!

  SUBROUTINE ReadRunType( RunType, PlotType )

    ! Read the RunType variable and echo with explanatory information to the print file

    USE SourceReceiverPositions

    CHARACTER (LEN= 7), INTENT( OUT ) :: RunType
    CHARACTER (LEN=10), INTENT( OUT ) :: PlotType

    READ(  ENVFile, * ) RunType
    WRITE( PRTFile, * )

    SELECT CASE ( RunType( 1 : 1 ) )
    CASE ( 'R' )
       WRITE( PRTFile, * ) 'Ray trace run'
    CASE ( 'E' )
       WRITE( PRTFile, * ) 'Eigenray trace run'
    CASE ( 'I' )
       WRITE( PRTFile, * ) 'Incoherent TL calculation'
    CASE ( 'S' )
       WRITE( PRTFile, * ) 'Semi-coherent TL calculation'
    CASE ( 'C' )
       WRITE( PRTFile, * ) 'Coherent TL calculation'
    CASE ( 'A' )
       WRITE( PRTFile, * ) 'Arrivals calculation, ASCII  file output'
    CASE ( 'a' )
       WRITE( PRTFile, * ) 'Arrivals calculation, binary file output'
    CASE DEFAULT
       CALL ERROUT( 'READIN', 'Unknown RunType selected' )
    END SELECT

    SELECT CASE ( RunType( 2 : 2 ) )
    CASE ( 'C' )
       WRITE( PRTFile, * ) 'Cartesian beams'
    CASE ( 'R' )
       WRITE( PRTFile, * ) 'Ray centered beams'
    CASE ( 'S' )
       WRITE( PRTFile, * ) 'Simple gaussian beams'
    CASE ( 'b' )
       WRITE( PRTFile, * ) 'Geometric gaussian beams in ray-centered coordinates'
    CASE ( 'B' )
       WRITE( PRTFile, * ) 'Geometric gaussian beams in Cartesian coordinates'
    CASE ( 'g' )
       WRITE( PRTFile, * ) 'Geometric hat beams in ray-centered coordinates'
    CASE DEFAULT
       RunType( 2 : 2 ) = 'G'
       WRITE( PRTFile, * ) 'Geometric hat beams in Cartesian coordinates'
    END SELECT

    SELECT CASE ( RunType( 4 : 4 ) )
    CASE ( 'R' )
       WRITE( PRTFile, * ) 'Point source (cylindrical coordinates)'
    CASE ( 'X' )
       WRITE( PRTFile, * ) 'Line source (Cartesian coordinates)'
    CASE DEFAULT
       RunType( 4 : 4 ) = 'R'
       WRITE( PRTFile, * ) 'Point source (cylindrical coordinates)'
    END SELECT

    SELECT CASE ( RunType( 5 : 5 ) )
    CASE ( 'R' )
       WRITE( PRTFile, * ) 'Rectilinear receiver grid: Receivers at ( Rr( ir ), Rz( ir ) ) )'
       PlotType = 'rectilin  '
    CASE ( 'I' )
       WRITE( PRTFile, * ) 'Irregular grid: Receivers at Rr( : ) x Rz( : )'
       IF ( Pos%NRz /= Pos%NRr ) CALL ERROUT( 'READIN', 'Irregular grid option selected with NRz not equal to Nr' )
       PlotType = 'irregular '
    CASE DEFAULT
       WRITE( PRTFile, * ) 'Rectilinear receiver grid: Receivers at Rr( : ) x Rz( : )'
       RunType( 5 : 5 ) = 'R'
       PlotType = 'rectilin  '
    END SELECT

    SELECT CASE ( RunType( 6 : 6 ) )
    CASE ( '2' )
       WRITE( PRTFile, * ) 'N x 2D calculation (neglects horizontal refraction)'
    CASE ( '3' )
       WRITE( PRTFile, * ) '3D calculation'
    CASE DEFAULT
       RunType( 6 : 6 ) = '2'
    END SELECT

  END SUBROUTINE ReadRunType

  !**********************************************************************!

  SUBROUTINE TopBot( freq, AttenUnit, HS )

    ! Handles top and bottom boundary conditions

    REAL     (KIND=8), INTENT( IN    ) :: freq               ! frequency
    CHARACTER (LEN=2), INTENT( IN    ) :: AttenUnit
    TYPE( HSInfo ),    INTENT( INOUT ) :: HS
    REAL     (KIND=8) :: Mz, vr, alpha2_f          ! values related to grain size

    ! Echo to PRTFile user's choice of boundary condition

    SELECT CASE ( HS%BC )
    CASE ( 'V' )
       WRITE( PRTFile, * ) '    VACUUM'
    CASE ( 'R' )
       WRITE( PRTFile, * ) '    Perfectly RIGID'
    CASE ( 'A' )
       WRITE( PRTFile, * ) '    ACOUSTO-ELASTIC half-space'
    CASE ( 'G' )
       WRITE( PRTFile, * ) '    Grain size to define half-space'
    CASE ( 'F' )
       WRITE( PRTFile, * ) '    FILE used for reflection loss'
    CASE ( 'W' )
       WRITE( PRTFile, * ) '    Writing an IRC file'
    CASE ( 'P' )
       WRITE( PRTFile, * ) '    reading PRECALCULATED IRC'
    CASE DEFAULT
       CALL ERROUT( 'TopBot', 'Unknown boundary condition type' )
    END SELECT

    ! ****** Read in BC parameters depending on particular choice ******

    HS%cp  = 0.0
    HS%cs  = 0.0
    HS%rho = 0.0

    SELECT CASE ( HS%BC )
    CASE ( 'A' )                  ! *** Half-space properties ***
       zTemp = 0.0
       READ(  ENVFile, *    ) zTemp, alphaR, betaR, rhoR, alphaI, betaI
       WRITE( PRTFile, FMT = "( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4 )" ) &
            zTemp, alphaR, betaR, rhoR, alphaI, betaI

       ! dummy parameters for a layer with a general power law for attenuation
       ! these are not in play because the AttenUnit for this is not allowed yet
       !freq0         = freq
       betaPowerLaw  = 1.0
       ft            = 1000.0

       HS%cp  = CRCI( zTemp, alphaR, alphaI, freq, freq, AttenUnit, betaPowerLaw, ft )
       HS%cs  = CRCI( zTemp, betaR,  betaI,  freq, freq, AttenUnit, betaPowerLaw, ft )

       HS%rho = rhoR
    CASE ( 'G' )                  ! *** Grain size (formulas from UW-APL HF Handbook)

       ! These formulas are from the UW-APL Handbook
       ! The code is taken from older Matlab and is unnecesarily verbose
       ! vr   is the sound speed ratio
       ! rhor is the density ratio
       READ(  ENVFile, *    ) zTemp, Mz
       WRITE( PRTFile, FMT = "( F10.2, 3X, F10.2 )" ) zTemp, Mz

       IF ( Mz >= -1 .AND. Mz < 1 ) THEN
          vr   = 0.002709 * Mz ** 2 - 0.056452 * Mz + 1.2778
          rhor = 0.007797 * Mz ** 2 - 0.17057  * Mz + 2.3139
       ELSE IF ( Mz >= 1 .AND. Mz < 5.3 ) THEN
          vr   = -0.0014881 * Mz ** 3 + 0.0213937 * Mz ** 2 - 0.1382798 * Mz + 1.3425
          rhor = -0.0165406 * Mz ** 3 + 0.2290201 * Mz ** 2 - 1.1069031 * Mz + 3.0455
       ELSE
          vr   = -0.0024324 * Mz + 1.0019
          rhor = -0.0012973 * Mz + 1.1565
       END IF

       IF ( Mz >= -1 .AND. Mz < 0 ) THEN
          alpha2_f = 0.4556
       ELSE IF ( Mz >= 0 .AND. Mz < 2.6 ) THEN
          alpha2_f = 0.4556 + 0.0245 * Mz
       ELSE IF( Mz >= 2.6 .AND. Mz < 4.5 ) THEN
          alpha2_f = 0.1978 + 0.1245 * Mz
       ELSE IF( Mz >= 4.5 .AND. Mz < 6.0 ) THEN
          alpha2_f = 8.0399 - 2.5228 * Mz + 0.20098 * Mz ** 2
       ELSE IF( Mz >= 6.0 .AND. Mz < 9.5 ) THEN
          alpha2_f = 0.9431 - 0.2041 * Mz + 0.0117 * Mz ** 2
       ELSE
          alpha2_f =  0.0601
       END IF

       ! AttenUnit = 'L'   ! loss parameter
!!! following uses a reference sound speed of 1500 ???
!!! should be sound speed in the water, just above the sediment
       ! the term vr / 1000 converts vr to units of m per ms
       alphaR = vr * 1500.0
       alphaI = alpha2_f * ( vr / 1000 ) * 1500.0 * log( 10.0 ) / ( 40.0 * pi )   ! loss parameter Sect. IV., Eq. (4) of handbook

       HS%cp  = CRCI( zTemp, alphaR, alphaI, freq, freq, 'L ', betaPowerLaw, ft )
       HS%cs  = 0.0
       HS%rho = rhoR
       WRITE( PRTFile, FMT = "( 'Converted sound speed =', 2F10.2, 3X, 'density = ', F10.2, 3X, 'loss parm = ', F10.4 )" ) &
            HS%cp, rhor, alphaI

    END SELECT

  END SUBROUTINE TopBot

  ! **********************************************************************!

  SUBROUTINE OpenOutputFiles( FileRoot, ThreeD )
    ! Write appropriate header information

    USE SourceReceiverPositions
    USE angleMod
    USE bdryMod
    USE RWSHDFile

    LOGICAL,            INTENT( IN ) :: ThreeD
    CHARACTER (LEN=80), INTENT( IN ) :: FileRoot
    REAL               :: atten
    CHARACTER (LEN=10) :: PlotType

    SELECT CASE ( Beam%RunType( 1 : 1 ) )
    CASE ( 'R', 'E' )   ! Ray trace or Eigenrays
       OPEN ( FILE = TRIM( FileRoot ) // '.ray', UNIT = RAYFile, FORM = 'FORMATTED' )
       WRITE( RAYFile, * ) '''', Title( 1 : 50 ), ''''
       WRITE( RAYFile, * ) freq
       WRITE( RAYFile, * ) Pos%NSx, Pos%NSy, Pos%NSz
       WRITE( RAYFile, * ) Angles%Nalpha, Angles%Nbeta
       WRITE( RAYFile, * ) Bdry%Top%HS%Depth
       WRITE( RAYFile, * ) Bdry%Bot%HS%Depth

       IF ( ThreeD ) THEN
          WRITE( RAYFile, * ) '''xyz'''
       ELSE
          WRITE( RAYFile, * ) '''rz'''
       END IF

    CASE ( 'A' )        ! arrival file in ascii format
       OPEN ( FILE = TRIM( FileRoot ) // '.arr', UNIT = ARRFile, FORM = 'FORMATTED' )

       IF ( ThreeD ) THEN
          WRITE( ARRFile, * ) '''3D'''
       ELSE
          WRITE( ARRFile, * ) '''2D'''
       END IF

       WRITE( ARRFile, * ) freq

       ! write source locations

       IF ( ThreeD ) THEN
          WRITE( ARRFile, * ) Pos%NSx,    Pos%Sx(    1 : Pos%NSx )
          WRITE( ARRFile, * ) Pos%NSy,    Pos%Sy(    1 : Pos%NSy )
          WRITE( ARRFile, * ) Pos%NSz,    Pos%Sz(    1 : Pos%NSz )
       ELSE
          WRITE( ARRFile, * ) Pos%NSz,    Pos%Sz(    1 : Pos%NSz )
       END IF

       ! write receiver locations

       WRITE( ARRFile, *    ) Pos%NRz,    Pos%Rz(    1 : Pos%NRz )
       WRITE( ARRFile, *    ) Pos%NRr,    Pos%Rr(    1 : Pos%NRr )
       IF ( ThreeD ) THEN
          WRITE( ARRFile, * ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta )
       END IF

    CASE ( 'a' )        ! arrival file in binary format
       OPEN ( FILE = TRIM( FileRoot ) // '.arr', UNIT = ARRFile, FORM = 'UNFORMATTED' )

       IF ( ThreeD ) THEN
          WRITE( ARRFile ) '''3D'''
       ELSE
          WRITE( ARRFile ) '''2D'''
       END IF

       WRITE( ARRFile    ) SNGL( freq )

       ! write source locations

       IF ( ThreeD ) THEN
          WRITE( ARRFile    ) Pos%NSx,    Pos%Sx(    1 : Pos%NSx )
          WRITE( ARRFile    ) Pos%NSy,    Pos%Sy(    1 : Pos%NSy )
          WRITE( ARRFile    ) Pos%NSz,    Pos%Sz(    1 : Pos%NSz )
       ELSE
          WRITE( ARRFile    ) Pos%NSz,    Pos%Sz(    1 : Pos%NSz )
       END IF

       ! write receiver locations

       WRITE( ARRFile       ) Pos%NRz,    Pos%Rz(    1 : Pos%NRz )
       WRITE( ARRFile       ) Pos%NRr,    Pos%Rr(    1 : Pos%NRr )
       IF ( ThreeD ) THEN
          WRITE( ARRFile    ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta )
       END IF

    CASE DEFAULT
       atten = 0.0

       ! following to set PlotType has alread been done in READIN if that was used for input
       SELECT CASE ( Beam%RunType( 5 : 5 ) )
       CASE ( 'R' )
          PlotType = 'rectilin  '
       CASE ( 'I' )
          PlotType = 'irregular '
       CASE DEFAULT
          PlotType = 'rectilin  '
       END SELECT

       CALL WriteHeader( TRIM( FileRoot ) // '.shd', Title, REAL( freq ), atten, PlotType )
    END SELECT

  END SUBROUTINE OpenOutputFiles

END MODULE ReadEnvironmentBell