! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module mod_quaternions
  !! author: MDG
  !! version: 1.0
  !! date: 01/03/20
  !!
  !! Quaternion and Quaternion Array arithmetic class
  !!
  !! Quaternions are defined with the scalar part in position 1, and the vector part in positions 2:4.
  !!
  !! There are two class definitions in this file, one for single quaternions, the other for
  !! quaternion array operations (some using OpenMP threads). The program MODQuaternionsTest.f90
  !! can be used as part of ctest to run a test program on this module.

use mod_global
use mod_kinds
use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
                                          stdout=>output_unit, &
                                          stderr=>error_unit

IMPLICIT NONE
  private

! following are used to define the quaternion symmetry operators
    real(kind=dbl), public, parameter  :: sq22=0.7071067811865475244D0 ! sqrt(2)/2
    real(kind=dbl), public, parameter  :: sq32=0.8660254037844386467D0 ! sqrt(3)/2
    real(kind=dbl), public, parameter  :: half=0.5D0                   ! 1/2

! We define the rotational crystal symmetry operators in terms of quaternions (q0, q1,q2,q3) with q0 the scalar part;
! these are used in the dictmod EBSD dictionary indexing module, and are defined with respect to the standard cartesian
! reference frame.  Note that these are not defined as Quaternion_T type, just as arrays of 4-component doubles.
    real(kind=dbl), public, dimension(4,152) :: SYM_Qsymop = reshape( (/ &
                      1.D0, 0.D0, 0.D0, 0.D0, &       ! 1: identity operator
                      0.D0, 1.D0, 0.D0, 0.D0, &       ! 2: 180@[100]
                      0.D0, 0.D0, 1.D0, 0.D0, &       ! 3: 180@[010]
                      0.D0, 0.D0, 0.D0, 1.D0, &       ! 4: 180@[001]
                      sq22, sq22, 0.D0, 0.D0, &       ! 5: 90@[100]
                      sq22, 0.D0, sq22, 0.D0, &       ! 6: 90@[010]
                      sq22, 0.D0, 0.D0, sq22, &       ! 7: 90@[001]
                      sq22,-sq22, 0.D0, 0.D0, &       ! 8: 270@[100]
                      sq22, 0.D0,-sq22, 0.D0, &       ! 9: 270@[010]
                      sq22, 0.D0, 0.D0,-sq22, &       !10: 270@[001]
                      0.D0, sq22, sq22, 0.D0, &       !11: 180@[110]
                      0.D0,-sq22, sq22, 0.D0, &       !12: 180@[-110]
                      0.D0, 0.D0, sq22, sq22, &       !13: 180@[011]
                      0.D0, 0.D0,-sq22, sq22, &       !14: 180@[0-11]
                      0.D0, sq22, 0.D0, sq22, &       !15: 180@[101]
                      0.D0,-sq22, 0.D0, sq22, &       !16: 180@[-101]
                      half, half, half, half, &       !17: 120@[111]
                      half,-half,-half,-half, &       !18: 120@[-1-1-1]
                      half, half,-half, half, &       !19: 120@[1-11]
                      half,-half, half,-half, &       !20: 120@[-11-1]
                      half,-half, half, half, &       !21: 120@[-111]
                      half, half,-half,-half, &       !22: 120@[1-1-1]
                      half,-half,-half, half, &       !23: 120@[-1-11]
                      half, half, half,-half, &       !24: 120@[11-1]
                      sq32, 0.D0, 0.D0, half, &       !25:  60@[001] (hexagonal/trigonal operators start here)
                      half, 0.D0, 0.D0, sq32, &       !26: 120@[001]
                      0.D0, 0.D0, 0.D0, 1.D0, &       !27: 180@[001] (duplicate from above, but useful to keep it here)
                     -half, 0.D0, 0.D0, sq32, &       !28: 240@[001]
                     -sq32, 0.D0, 0.D0, half, &       !29: 300@[001]
                      0.D0, 1.D0, 0.D0, 0.D0, &       !30: 180@[100]
                      0.D0, sq32, half, 0.D0, &       !31: 180@[xxx]
                      0.D0, half, sq32, 0.D0, &       !32: 180@[xxx]
                      0.D0, 0.D0, 1.D0, 0.D0, &       !33: 180@[010]
                      0.D0,-half, sq32, 0.D0, &       !34: 180@[xxx]
                      0.D0,-sq32, half, 0.D0, &       !35: 180@[xxx]
                      1.0000000000000000D0, 0.00000000000000000D0, 0.00000000000000000D0, 0.00000000000000000D0, & ! icosahedral operators
                      0.0000000000000000D0, 0.68819093704223555D0, 0.50000000000000000D0, 0.52573108673095648D0, &
                      0.0000000000000000D0,-0.26286554336547824D0, 0.80901700258254916D0, 0.52573108673095648D0, &
                      0.0000000000000000D0,-0.85065078735351463D0, 0.00000000000000000D0, 0.52573108673095648D0, &
                      0.0000000000000000D0,-0.26286554336547824D0,-0.80901700258254916D0, 0.52573108673095648D0, &
                      0.0000000000000000D0, 0.68819093704223555D0,-0.50000000000000000D0, 0.52573108673095648D0, &
                      0.0000000000000000D0, 0.52573108673095648D0, 0.00000000000000000D0, 0.85065078735351463D0, &
                      0.0000000000000000D0, 0.16245985031127913D0, 0.50000000000000000D0, 0.85065078735351463D0, &
                      0.0000000000000000D0,-0.42532539367675731D0, 0.30901700258254972D0, 0.85065078735351463D0, &
                      0.0000000000000000D0,-0.42532539367675731D0,-0.30901700258254972D0, 0.85065078735351463D0, &
                      0.0000000000000000D0, 0.16245985031127913D0,-0.50000000000000000D0, 0.85065078735351463D0, &
                      0.0000000000000000D0, 0.95105654001235851D0,-0.30901700258254972D0, 0.00000000000000000D0, &
                      0.0000000000000000D0, 0.95105654001235851D0, 0.30901700258254972D0, 0.00000000000000000D0, &
                      0.0000000000000000D0, 0.58778524398803644D0, 0.80901700258254916D0, 0.00000000000000000D0, &
                      0.0000000000000000D0, 0.00000000000000000D0, 1.00000000000000000D0, 0.00000000000000000D0, &
                      0.0000000000000000D0,-0.58778524398803644D0, 0.80901700258254916D0, 0.00000000000000000D0, &
                     0.50000000000000000D0, 0.42532540417601997D0, 0.30901699437494742D0, 0.68819096193209561D0, &
                     0.50000000000000000D0,-0.42532540417601997D0,-0.30901699437494742D0,-0.68819096193209561D0, &
                     0.50000000000000000D0,-0.16245984737382999D0, 0.50000000000000000D0, 0.68819096193209561D0, &
                     0.50000000000000000D0, 0.16245984737382999D0,-0.50000000000000000D0,-0.68819096193209561D0, &
                     0.50000000000000000D0,-0.52573108874869778D0, 0.00000000000000000D0, 0.68819096193209561D0, &
                     0.50000000000000000D0, 0.52573108874869778D0, 0.00000000000000000D0,-0.68819096193209561D0, &
                     0.50000000000000000D0,-0.16245984737382999D0,-0.50000000000000000D0, 0.68819096193209561D0, &
                     0.50000000000000000D0, 0.16245984737382999D0, 0.50000000000000000D0,-0.68819096193209561D0, &
                     0.50000000000000000D0, 0.42532539174817890D0,-0.30901700049082287D0, 0.68819096193209561D0, &
                     0.50000000000000000D0,-0.42532539174817890D0, 0.30901700049082287D0,-0.68819096193209561D0, &
                     0.50000000000000000D0,-0.85065078349635781D0, 0.00000000000000000D0, 0.16245984737382999D0, &
                     0.50000000000000000D0, 0.85065078349635781D0, 0.00000000000000000D0,-0.16245984737382999D0, &
                     0.50000000000000000D0,-0.68819096193209561D0,-0.50000000000000000D0,-0.16245984737382999D0, &
                     0.50000000000000000D0, 0.68819096193209561D0, 0.50000000000000000D0, 0.16245984737382999D0, &
                     0.50000000000000000D0,-0.26286554437434889D0,-0.80901695670145712D0, 0.16245984737382999D0, &
                     0.50000000000000000D0, 0.26286554437434889D0, 0.80901695670145712D0,-0.16245984737382999D0, &
                     0.50000000000000000D0, 0.26286554437434889D0,-0.80901695670145712D0,-0.16245984737382999D0, &
                     0.50000000000000000D0,-0.26286554437434889D0, 0.80901695670145712D0, 0.16245984737382999D0, &
                     0.50000000000000000D0, 0.68819096193209561D0,-0.50000000000000000D0, 0.16245984737382999D0, &
                     0.50000000000000000D0,-0.68819096193209561D0, 0.50000000000000000D0,-0.16245984737382999D0, &
                     0.80901700537708732D0, 0.00000000000000000D0, 0.00000000000000000D0, 0.58778523714932640D0, &
                     0.30901702997862029D0, 0.00000000000000000D0, 0.00000000000000000D0, 0.95105650472681824D0, &
                     0.80901700537708732D0, 0.00000000000000000D0, 0.00000000000000000D0,-0.58778523714932640D0, &
                     0.30901702997862029D0, 0.00000000000000000D0, 0.00000000000000000D0,-0.95105650472681824D0, &
                     0.80901700537708732D0, 0.52573109227969150D0, 0.00000000000000000D0, 0.26286554613984575D0, &
                     0.30901702997862029D0, 0.85065078781948245D0, 0.00000000000000000D0, 0.42532539390974122D0, &
                     0.80901700537708732D0,-0.52573109227969150D0, 0.00000000000000000D0,-0.26286554613984575D0, &
                     0.30901702997862029D0,-0.85065078781948245D0, 0.00000000000000000D0,-0.42532539390974122D0, &
                     0.80901700537708732D0, 0.16245984550474032D0, 0.50000000000000000D0, 0.26286554613984575D0, &
                     0.30901702997862029D0, 0.26286555540853851D0, 0.80901696456355054D0, 0.42532539390974122D0, &
                     0.80901700537708732D0,-0.16245984550474032D0,-0.50000000000000000D0,-0.26286554613984575D0, &
                     0.30901702997862029D0,-0.26286555540853851D0,-0.80901696456355054D0,-0.42532539390974122D0, &
                     0.80901700537708732D0,-0.42532540916195122D0, 0.30901697149092866D0, 0.26286554613984575D0, &
                     0.30901702997862029D0,-0.68819097766197224D0, 0.50000000000000000D0, 0.42532539390974122D0, &
                     0.80901700537708732D0, 0.42532540916195122D0,-0.30901697149092866D0,-0.26286554613984575D0, &
                     0.30901702997862029D0, 0.68819097766197224D0,-0.50000000000000000D0,-0.42532539390974122D0, &
                     0.80901700537708732D0,-0.42532540916195122D0,-0.30901697149092866D0, 0.26286554613984575D0, &
                     0.30901702997862029D0,-0.68819097766197224D0,-0.50000000000000000D0, 0.42532539390974122D0, &
                     0.80901700537708732D0, 0.42532540916195122D0, 0.30901697149092866D0,-0.26286554613984575D0, &
                     0.30901702997862029D0, 0.68819097766197224D0, 0.50000000000000000D0,-0.42532539390974122D0, &
                     0.80901700537708732D0, 0.16245984550474032D0,-0.50000000000000000D0, 0.26286554613984575D0, &
                     0.30901702997862029D0, 0.26286555540853851D0,-0.80901696456355054D0, 0.42532539390974122D0, &
                     0.80901700537708732D0,-0.16245984550474032D0, 0.50000000000000000D0,-0.26286554613984575D0, &
                     0.30901702997862029D0,-0.26286555540853851D0, 0.80901696456355054D0,-0.42532539390974122D0, &

                     ! octagonal QC group 822
                     0.923879532511287D0, 0.D0, 0.D0, 0.38268343236509D0, &       ! 45@[001]
                     0.707106781186547D0, 0.D0, 0.D0, 0.707106781186547D0, &      ! 90@[001]
                     0.38268343236509D0, 0.D0, 0.D0, 0.923879532511287D0, &       ! 135@[001]
                     0.D0, 0.D0, 0.D0, 1.D0, &                                    ! 180@[001]
                    -0.382683432365090D0, 0.D0, 0.D0, 0.923879532511287D0, &     ! 225@[001]
                    -0.707106781186547D0, 0.0D0, 0.0D0, 0.707106781186548D0, &   ! 270@[001]
                    -0.923879532511287D0, 0.0D0, 0.0D0, 0.382683432365090D0, &   ! 315@[001]
                     ! all 2 fold rotation axes
                     0.D0, 1.D0, 0.D0, 0.D0, &                                    ! 180@[100]
                     0.D0, 0.923879532511287D0, 0.38268343236509D0, 0.D0, &       ! 180@[cos(pi/8) sin(pi/8) 0]
                     0.0D0, 0.923879532511287D0, -0.382683432365090D0, 0.0D0, &
                     0.0D0, 0.707106781186548D0, -0.707106781186547D0, 0.0D0, &
                     0.0D0, 0.382683432365090D0, -0.923879532511287D0, 0.0D0, &
                     0.0D0, 0.0D0, -1.0D0, 0.0D0, &
                     0.0D0, -0.382683432365090D0, -0.923879532511287D0, 0.0D0, &
                     0.0D0, -0.707106781186547D0, -0.707106781186548D0, 0.0D0, &

                     ! decagonal QC group 1022
                     0.951056516295154D0, 0.0D0, 0.0D0, 0.309016994374947D0, &    ! 36@[001]
                     0.809016994374947D0, 0.0D0, 0.0D0, 0.587785252292473D0, &    ! 72@[001]
                     0.587785252292473D0, 0.0D0, 0.0D0, 0.809016994374947D0, &    ! 108@[001]
                     0.309016994374947D0, 0.0D0, 0.0D0, 0.951056516295154D0, &    ! 144@[001]
                     0.0D0, 0.0D0, 0.0D0, 1.0D0, &                                ! 180@[001]
                    -0.309016994374947D0, 0.0D0, 0.0D0, 0.951056516295154D0, &    ! 216@[001]
                    -0.587785252292473D0, 0.0D0, 0.0D0, 0.809016994374947D0, &    ! 252@[001]
                    -0.809016994374947D0, 0.0D0, 0.0D0, 0.587785252292473D0, &    ! 288@[001]
                    -0.951056516295154D0, 0.0D0, 0.0D0, 0.309016994374948D0, &    ! 324@[001]
                    ! all 2-fold rotation axis
                     0.D0, 1.D0, 0.D0, 0.D0, &                                    ! 180@[100]
                     0.D0, 0.951056516295154D0, 0.309016994374947D0, 0.D0,   &    ! 180@[cos(pi/10) sin(pi/10) 0]
                     0.0D0, 0.951056516295154D0, -0.309016994374947D0, 0.0D0, &
                     0.0D0, 0.809016994374947D0, -0.587785252292473D0, 0.0D0, &
                     0.0D0, 0.587785252292473D0, -0.809016994374947D0, 0.0D0, &
                     0.0D0, 0.309016994374947D0, -0.951056516295154D0, 0.0D0, &
                     0.0D0, 0.0D0, -1.0D0, 0.0D0, &
                     0.0D0, -0.309016994374947D0, -0.951056516295154D0, 0.0D0, &
                     0.0D0, -0.587785252292473D0, -0.809016994374947D0, 0.0D0, &
                     0.0D0, -0.809016994374947D0, -0.587785252292473D0, 0.0D0, &

                     ! dodecagonal QC group 1222
                     0.965925826289068D0, 0.0D0, 0.0D0, 0.258819045102521D0, &    ! 30@[001]
                     0.866025403784439D0, 0.0D0, 0.0D0, 0.5D0, &                  ! 60@[001]
                     0.707106781186548D0, 0.0D0, 0.0D0, 0.707106781186547D0, &    ! 90@[001]
                     0.5D0, 0.0D0, 0.0D0, 0.866025403784439D0, &                  ! 120@[001]
                     0.258819045102521D0, 0.0D0, 0.0D0, 0.965925826289068D0, &    ! 150@[001]
                     0.0D0, 0.0D0, 0.0D0, 1.0D0, &                                    ! 180@[001]
                    -0.258819045102521D0, 0.0D0, 0.0D0, 0.965925826289068D0, &      ! 210@[001]
                    -0.5D0, 0.0D0, 0.0D0, 0.866025403784439D0, &                  ! 240@[001]
                    -0.707106781186547D0, 0.0D0, 0.0D0, 0.707106781186548D0, &    ! 270@[001]
                    -0.866025403784439D0, 0.0D0, 0.0D0, 0.5D0, &                  ! 300@[001]
                    -0.965925826289068D0, 0.0D0, 0.0D0, 0.258819045102521D0, &    ! 330@[001]
                    ! all 2-fold rotation axes
                    0.0D0, 1.0D0, 0.0D0, 0.0D0, &                                    ! 180@[100]
                    0.0D0, 0.965925826289068D0, 0.258819045102521D0, 0.0D0, &      ! 180@[cos(pi/12) sin(pi/12) 0]
                    0.0D0, 0.965925826289068D0, -0.258819045102521D0, 0.0D0, &
                    0.0D0, 0.866025403784439D0, -0.5D0, 0.0D0, &
                    0.0D0, 0.707106781186548D0, -0.707106781186547D0, 0.0D0, &
                    0.0D0, 0.5D0, -0.866025403784439D0, 0.0D0, &
                    0.0D0, 0.258819045102521D0, -0.965925826289068D0, 0.0D0, &
                    0.0D0, 0.0D0, -1.0D0, 0.0D0, &
                    0.0D0, -0.258819045102521D0, -0.965925826289068D0, 0.0D0, &
                    0.0D0, -0.5D0, -0.866025403784439D0, 0.0D0, &
                    0.0D0, -0.707106781186547D0, -0.707106781186548D0, 0.0D0, &
                    0.0D0, -0.866025403784439D0, -0.5D0, 0.0D0 &
                    /), (/4,152/) )
!DEC$ ATTRIBUTES DLLEXPORT :: SYM_Qsymop

! we overload the conjg, cabs, and .eq. intrinsics
    intrinsic :: conjg, cabs
    public :: conjg, cabs

    interface conjg
      procedure quatconjg
    end interface conjg

    interface cabs
      procedure quatnorm
    end interface cabs

    interface operator(.eq.)
      procedure quatsequal
    end interface

! definition of the quaternion class
  type, public :: Quaternion_T
    !! Quaternion Class definition
    private
      real(kind=sgl), dimension(4) :: q
       !! single precision quaternion
      real(kind=dbl), dimension(4) :: qd
       !! double precision quaternion
      character(1)                 :: s
       !! precision indicator ('s' or 'd')
      real(kind=sgl), dimension(3,3)  :: mu
       !! simplectic transformation array single precision
      real(kind=dbl), dimension(3,3)  :: mud
       !! simplectic transformation array double precision

    contains
    private
! quaternion IO routines
      procedure, pass(self) :: quatprint
      procedure, pass(self) :: getquats
      procedure, pass(self) :: getquatd
      procedure, pass(self) :: setquats
      procedure, pass(self) :: setquatd
      procedure, pass(self) :: setsimplectics
      procedure, pass(self) :: setsimplecticd
! quaternion arithmetic routines
      procedure, pass(self) :: quatflip
      procedure, pass(self) :: quatpos
      procedure, pass(self) :: quatadd
      procedure, pass(self) :: quatsubtract
      procedure, pass(self) :: quatmult
      procedure, pass(self) :: quatsmult
      procedure, pass(self) :: quatsmultd
      procedure, pass(self) :: quatdiv
      procedure, pass(self) :: quatsdiv
      procedure, pass(self) :: quatsdivd
      procedure, pass(self) :: quatconjg
      procedure, pass(self) :: quatnorm
      procedure, pass(self) :: quatnormalize
! quaternion-based transformations
      procedure, pass(self) :: quatLp
      procedure, pass(self) :: quatLpd
      procedure, pass(self) :: quat2simplectic
      procedure, pass(self) :: quat2simplecticd
      procedure, pass(self) :: simplectic2quat
      procedure, pass(self) :: simplectic2quatd
! routines with two or more input quaternions
      procedure, pass(self) :: quatinnerproduct
      procedure, pass(self) :: quatangle
      procedure, pass(self) :: quatslerp
! miscellaneous routines
      procedure, pass(self), public :: quatsequal

      generic, public :: quat_print => quatprint
      generic, public :: quat_flip => quatflip
      generic, public :: quat_pos => quatpos
      generic, public :: get_quats => getquats
      generic, public :: get_quatd => getquatd
      generic, public :: set_quats => setquats
      generic, public :: set_quatd => setquatd
      generic, public :: set_simplectic => setsimplectics, setsimplecticd
      generic, public :: quat_norm => quatnorm
      generic, public :: operator(+) => quatadd
      generic, public :: operator(-) => quatsubtract
      generic, public :: operator(*) => quatmult
      generic, public :: operator(*) => quatsmult, quatsmultd
      generic, public :: operator(/) => quatdiv
      generic, public :: operator(/) => quatsdiv, quatsdivd
      generic, public :: quat_normalize => quatnormalize
      generic, public :: quat_Lp => quatLp, quatLpd
      generic, public :: quat_to_simplectic => quat2simplectic, quat2simplecticd
      generic, public :: simplectic_to_quat => simplectic2quat, simplectic2quatd
      generic, public :: quat_innerproduct => quatinnerproduct
      generic, public :: quat_angle => quatangle
      generic, public :: quat_slerp => quatslerp

  end type Quaternion_T

! the constructor routines for these classes
  interface Quaternion_T
    module procedure Quaternion_constructor
  end interface Quaternion_T

contains

!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
! We begin with the functions/subroutines that are public in the
! two classes and pair up functions for individual and quaternion
! arrays for easier module maintenance.
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------

!--------------------------------------------------------------------------
type(Quaternion_T) function Quaternion_constructor( q, qd ) result(Quat)
!DEC$ ATTRIBUTES DLLEXPORT :: Quaternion_constructor
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! constructor for the Quaternion Class

IMPLICIT NONE

  real(kind=sgl), INTENT(IN), OPTIONAL      :: q(4)
  real(kind=dbl), INTENT(IN), OPTIONAL      :: qd(4)

! fill in one or the other quaternion
  if ((.not.present(q)).and.(.not.present(qd))) then
    Quat % q = (/ 0.0, 0.0, 0.0, 0.0 /)
    Quat % qd = (/ 0.D0, 0.D0, 0.D0, 0.D0 /)
    Quat % s = 's'
  else
      if (present(q)) then
        Quat % q = q
        Quat % qd = (/ 0.D0, 0.D0, 0.D0, 0.D0 /)
        Quat % s = 's'
      end if

      if (present(qd)) then
        Quat % q = (/ 0.0, 0.0, 0.0, 0.0 /)
        Quat % qd = qd
        Quat % s = 'd'
      end if
  end if

end function Quaternion_constructor

!--------------------------------------------------------------------------
subroutine Quaternion_destructor(self)
!DEC$ ATTRIBUTES DLLEXPORT :: Quaternion_destructor
!! author: MDG
!! version: 1.0
!! date: 02/02/20
!!
!! destructor for the Quaternion_T Class

IMPLICIT NONE

type(Quaternion_T), INTENT(INOUT)     :: self

call reportDestructor('Quaternion_T')

end subroutine Quaternion_destructor

!--------------------------------------------------------------------------
recursive subroutine quatprint(self)
!DEC$ ATTRIBUTES DLLEXPORT :: quatprint
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! print a quaternion

use mod_io

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion

  type(IO_T)                        :: Message

  if (self%s.eq.'s') then
    call Message % WriteValue('', self%q, 4, frm="('(',4f12.6,'); precision: '$)")
    call Message % WriteValue('',self%s)
  else
    call Message % WriteValue('', self%qd, 4, frm="('(',4f20.14,'); precision: '$)")
    call Message % WriteValue('',self%s)
  end if

end subroutine quatprint

!--------------------------------------------------------------------------
recursive function getquats(self) result(qs)
!DEC$ ATTRIBUTES DLLEXPORT :: getquats
  !! author: MDG
  !! version: 1.0
  !! date: 01/22/20
  !!
  !! return a quaternion

IMPLICIT NONE

class(Quaternion_T),intent(in)    :: self
 !! input quaternion
real(kind=sgl)                    :: qs(4)

qs = self%q

end function getquats

!--------------------------------------------------------------------------
recursive function getquatd(self) result(qd)
!DEC$ ATTRIBUTES DLLEXPORT :: getquatd
  !! author: MDG
  !! version: 1.0
  !! date: 01/22/20
  !!
  !! return a quaternion

IMPLICIT NONE

class(Quaternion_T),intent(in)    :: self
 !! input quaternion
real(kind=dbl)                    :: qd(4)

qd = self%qd

end function getquatd

!--------------------------------------------------------------------------
recursive subroutine setquats(self, qs)
!DEC$ ATTRIBUTES DLLEXPORT :: setquats
  !! author: MDG
  !! version: 1.0
  !! date: 02/18/20
  !!
  !! set a quaternion

IMPLICIT NONE

class(Quaternion_T),intent(inout)    :: self
real(kind=sgl),intent(in)            :: qs(4)
 !! input quaternion

self%q = qs
self%s = 's'

end subroutine setquats

!--------------------------------------------------------------------------
recursive subroutine setquatd(self, qd)
!DEC$ ATTRIBUTES DLLEXPORT :: setquatd
  !! author: MDG
  !! version: 1.0
  !! date: 01/22/20
  !!
  !! set a quaternion

IMPLICIT NONE

class(Quaternion_T),intent(inout)    :: self
real(kind=dbl),intent(in)            :: qd(4)
 !! input quaternion

self%qd = qd
self%s = 'd'

end subroutine setquatd

!--------------------------------------------------------------------------
recursive subroutine setsimplectics(self, mu1, mu2, mu3)
!DEC$ ATTRIBUTES DLLEXPORT :: setsimplectics
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! set the simplectic transformation array

IMPLICIT NONE

class(Quaternion_T),intent(inout)    :: self
real(kind=sgl),intent(in)            :: mu1(3)
real(kind=sgl),intent(in)            :: mu2(3)
real(kind=sgl),intent(in)            :: mu3(3)

self%mu(1,1:3) = mu1
self%mu(2,1:3) = mu2
self%mu(3,1:3) = mu3

end subroutine setsimplectics

!--------------------------------------------------------------------------
recursive subroutine setsimplecticd(self, mu1, mu2, mu3)
!DEC$ ATTRIBUTES DLLEXPORT :: setsimplecticd
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! set the simplectic transformation array

IMPLICIT NONE

class(Quaternion_T),intent(inout)    :: self
real(kind=dbl),intent(in)            :: mu1(3)
real(kind=dbl),intent(in)            :: mu2(3)
real(kind=dbl),intent(in)            :: mu3(3)

self%mud(1,1:3) = mu1
self%mud(2,1:3) = mu2
self%mud(3,1:3) = mu3

end subroutine setsimplecticd

!--------------------------------------------------------------------------
pure recursive subroutine quatflip(self)
!DEC$ ATTRIBUTES DLLEXPORT :: quatflip
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! change the sign of the complete quaternion

IMPLICIT NONE

class(Quaternion_T),intent(inout) :: self

if (self%s.eq.'s') then
  self%q = -self%q
else
  self%qd = -self%qd
end if

end subroutine quatflip

!--------------------------------------------------------------------------
pure recursive subroutine quatpos(self)
!DEC$ ATTRIBUTES DLLEXPORT :: quatpos
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! convert a quaternion to one with a positive scalar part, if it is negative

IMPLICIT NONE

class(Quaternion_T),intent(inout) :: self

if (self%s.eq.'s') then
  if (self%q(1).lt.0.0) self%q = -self%q
else
  if (self%qd(1).lt.0.D0) self%qd = -self%qd
end if

end subroutine quatpos

!--------------------------------------------------------------------------
pure recursive function quatadd(self, y) result(qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatadd
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion addition (single/double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in) :: self, y
  type(Quaternion_T)             :: qres

  if (self%s.eq.'s') then
    qres%q = self%q + y%q
    qres%s = 's'
  else
    qres%qd = self%qd + y%qd
    qres%s = 'd'
  end if

end function quatadd

!--------------------------------------------------------------------------
recursive function quatsubtract(self, y) result(qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsubtract
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion subtraction (single/double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in) :: self, y
  type(Quaternion_T)             :: qres

  if (self%s.eq.'s') then
    qres%q = self%q - y%q
    qres%s = 's'
  else
    qres%qd = self%qd - y%qd
    qres%s = 'd'
  end if

end function quatsubtract

!--------------------------------------------------------------------------
pure recursive function quatmult(self, y) result(qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatmult
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion multiplication   (single/double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in) :: self, y
   !! input quaternions
  type(Quaternion_T)             :: qres
   !! output quaternion

! the following is a way to reduce the number of multiplications
! needs to be tested and merged with epsijk approach
!
! QuatMul(QUAT *q1, QUAT *q2, QUAT *res){
! float A, B, C, D, E, F, G, H;
! A = (q1->w + q1->x)*(q2->w + q2->x);
! B = (q1->z - q1->y)*(q2->y - q2->z);
! C = (q1->w - q1->x)*(q2->y + q2->z);
! D = (q1->y + q1->z)*(q2->w - q2->x);
! E = (q1->x + q1->z)*(q2->x + q2->y);
! F = (q1->x - q1->z)*(q2->x - q2->y);
! G = (q1->w + q1->y)*(q2->w - q2->z);
! H = (q1->w - q1->y)*(q2->w + q2->z);
! res->w = B + (-E - F + G + H) /2;
! res->x = A - (E + F + G + H)/2;
! res->y = C + (E - F + G - H)/2;
! res->z = D + (E - F - G + H)/2;
! }

  if (self%s.eq.'s') then
    qres%q = (/ self%q(1)*y%q(1) - self%q(2)*y%q(2) -          ( self%q(3)*y%q(3) + self%q(4)*y%q(4) ), &
                self%q(1)*y%q(2) + self%q(2)*y%q(1) + epsijk * ( self%q(3)*y%q(4) - self%q(4)*y%q(3) ), &
                self%q(1)*y%q(3) + self%q(3)*y%q(1) + epsijk * ( self%q(4)*y%q(2) - self%q(2)*y%q(4) ), &
                self%q(1)*y%q(4) + self%q(4)*y%q(1) + epsijk * ( self%q(2)*y%q(3) - self%q(3)*y%q(2) ) /)
    qres%s = 's'
  else
    qres%qd = (/ self%qd(1)*y%qd(1) - self%qd(2)*y%qd(2) -           ( self%qd(3)*y%qd(3) + self%qd(4)*y%qd(4) ), &
                 self%qd(1)*y%qd(2) + self%qd(2)*y%qd(1) + epsijkd * ( self%qd(3)*y%qd(4) - self%qd(4)*y%qd(3) ), &
                 self%qd(1)*y%qd(3) + self%qd(3)*y%qd(1) + epsijkd * ( self%qd(4)*y%qd(2) - self%qd(2)*y%qd(4) ), &
                 self%qd(1)*y%qd(4) + self%qd(4)*y%qd(1) + epsijkd * ( self%qd(2)*y%qd(3) - self%qd(3)*y%qd(2) ) /)
    qres%s = 'd'
  end if

end function quatmult

!--------------------------------------------------------------------------
pure recursive function quatsmult(self, s) result(qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsmult
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! scalar quaternion multiplication   (single precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)   :: self
   !! input quaternion
  real(kind=sgl), INTENT(IN)       :: s
   !! scalar input
  type(Quaternion_T)               :: qres
   !! output quaternion

  qres%q = (/ s*self%q(1), s*self%q(2), s*self%q(3), s*self%q(4) /)
  qres%s = 's'

end function quatsmult

!--------------------------------------------------------------------------
pure recursive function quatsmultd(self, s) result(qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsmultd
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! scalar quaternion multiplication   (double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)   :: self
   !! input quaternion
  real(kind=dbl), INTENT(IN)       :: s
   !! scalar input
  type(Quaternion_T)               :: qres
   !! output quaternion

  qres%qd = (/ s*self%qd(1), s*self%qd(2), s*self%qd(3), s*self%qd(4) /)
  qres%s = 'd'

end function quatsmultd

!--------------------------------------------------------------------------
pure recursive function quatconjg(self) result (qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatconjg
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion conjugation (extends intrinsic routine conjg)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion
  type(Quaternion_T)                :: qres
   !! output quaternion

  if (self%s.eq.'s') then
    qres%q = (/ self%q(1), -self%q(2), -self%q(3), -self%q(4) /)
    qres%s = 's'
  else
    qres%qd = (/ self%qd(1), -self%qd(2), -self%qd(3), -self%qd(4) /)
    qres%s = 'd'
  end if

end function quatconjg

!--------------------------------------------------------------------------
pure recursive function quatnorm(self) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatnorm
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion norm (extends intrinsic routine abs)

IMPLICIT NONE

  class(Quaternion_T),intent(in) :: self
   !! input quaternion
  real(kind=dbl)                 :: res
   !! output norm

  real(kind=sgl)                 :: n
  real(kind=dbl)                 :: nd, resd

  if (self%s.eq.'s') then
    n = self%q(1)**2 + self%q(2)**2 + self%q(3)**2 + self%q(4)**2
    resd = dsqrt( dble(n) )
    res = dble(sngl(resd))
  else
    nd = self%qd(1)**2 + self%qd(2)**2 + self%qd(3)**2 + self%qd(4)**2
    res = dsqrt( nd )
  end if

end function quatnorm

!--------------------------------------------------------------------------
recursive subroutine quatnormalize(self)
!DEC$ ATTRIBUTES DLLEXPORT :: quatnormalize
  !! author: MDG
  !! version: 1.0
  !! date: 01/07/20
  !!
  !! normalize the input quaternion

IMPLICIT NONE

  class(Quaternion_T),intent(inout) :: self
   !! input quaternion

  type(Quaternion_T)                :: q
  real(kind=sgl)                    :: n
  real(kind=dbl)                    :: nd

  if (self%s.eq.'s') then
    n = self%q(1)**2 + self%q(2)**2 + self%q(3)**2 + self%q(4)**2
    n = sqrt( n )
    q = self%quatsdiv(n)
    self%q = q%q
  else
    nd = self%qd(1)**2 + self%qd(2)**2 + self%qd(3)**2 + self%qd(4)**2
    nd = sqrt( nd )
    q = self%quatsdivd(nd)
    self%qd = q%qd
  end if

end subroutine quatnormalize

!--------------------------------------------------------------------------
recursive function quatdiv(self, y) result (qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatdiv
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion division (single/double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self, y
   !! input quaternions
  type(Quaternion_T)                :: qres
   !! output quaternion

  type(Quaternion_T)                :: p, cy
  real(kind=sgl)                    :: q
  real(kind=dbl)                    :: qd

  if (self%s.eq.'s') then
      q = quatnorm(y)
      cy = quatconjg(y)
      p = quatsdiv( cy, q*q )
      qres = quatmult(self,p)
      qres%s = 's'
  else
      qd = quatnorm(y)
      cy = quatconjg(y)
      p = quatsdivd( cy, qd*qd )
      qres = quatmult(self,p)
      qres%s = 'd'
  end if

end function quatdiv

!--------------------------------------------------------------------------
recursive function quatsdiv(self, s) result (qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsdiv
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion division (single precision)

use mod_io

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion (numerator)
  real(kind=sgl), INTENT(IN)        :: s
   !! input quaternion (denominator)

  type(Quaternion_T)                :: qres
  type(IO_T)                        :: Message

  if (s.ne.0.0) then
      qres%q = (/ self%q(1)/s, self%q(2)/s, self%q(3)/s, self%q(4)/s /)
      qres%s = 's'
  else
    call Message % printWarning('quatsdiv', (/ 'Attempting to divide quaternion by zero; skipping operation ...' /) )
    qres = self
  end if

end function quatsdiv

!--------------------------------------------------------------------------
recursive function quatsdivd(self, s) result (qres)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsdivd
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion division (doubgle precision)

use mod_io

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion (numerator)
  real(kind=dbl), INTENT(IN)        :: s
   !! input quaternion (denominator)

  type(Quaternion_T)                :: qres
  type(IO_T)                        :: Message

  if (s.ne.0.0) then
    qres%qd = (/ self%qd(1)/s, self%qd(2)/s, self%qd(3)/s, self%qd(4)/s /)
    qres%s = 'd'
  else
    call Message % printWarning('quatsdivd', (/ 'Attempting to divide quaternion by zero; skipping operation ...' /) )
    qres = self
  end if

end function quatsdivd

!--------------------------------------------------------------------------
pure recursive function quatinnerproduct(self, y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatinnerproduct
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion inner product (single precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self, y
   !! input quaternions
  real(kind=dbl)                    :: res
   !! inner product

  if (self%s.eq.'s') then
    res = dble(self%q(1) * y%q(1) + self%q(2) * y%q(2) + self%q(3) * y%q(3) + self%q(4) * y%q(4))
  else
    res = self%qd(1) * y%qd(1) + self%qd(2) * y%qd(2) + self%qd(3) * y%qd(3) + self%qd(4) * y%qd(4)
  end if

end function quatinnerproduct

!--------------------------------------------------------------------------!
pure recursive function quatangle(self, y) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatangle
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! interquaternion angle   (single/double precision)
  !! this only has meaning for a unit quaternion, so we test first and return -10000.0
  !! if either of the quaternions is not a unit quaternion.

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self, y
   !! input quaternions
  real(kind=dbl)                    :: res
   !! angle (radians)

  real(kind=sgl)                    :: q, nself, ny
  real(kind=dbl)                    :: qd, nselfd, nyd

  if (self%s.eq.'s') then
      nself = self%quatnorm()
      ny = y%quatnorm()
      q = self%quat_innerproduct(y)
      res = dble(acos( q/(nself * ny) ))
  else
      nselfd = self%quatnorm()
      nyd = y%quatnorm()
      qd = self%quat_innerproduct(y)
      res = dacos( qd/(nselfd * nyd) )
  end if

end function quatangle

!--------------------------------------------------------------------------!
recursive function quatLp(self, v) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatLp
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! actively rotate a unit vector by a unit quaternion, L_p = p v p* (single precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion
  real(kind=sgl),intent(in)         :: v(3)
   !! input vector to be rotated
  real(kind=sgl)                    :: res(3)
   !! output vector

  type(Quaternion_T)                :: qv, rqv, cq

  qv%q = (/ 0.0, v(1), v(2), v(3) /)
  qv%s = 's'
  cq = quatconjg(self)
  rqv = quatmult(self, quatmult(qv, cq) )
  res(1:3) = rqv%q(2:4)

end function quatLp

!--------------------------------------------------------------------------!
! pure recursive function quatLpd(self, v) result (res)
recursive function quatLpd(self, v) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatLpd
  !! author: MDG
  !! version: 1.0
  !! date: 01/03/20
  !!
  !! actively rotate a unit vector by a unit quaternion, L_p = p v p* (double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion
  real(kind=dbl),intent(in)         :: v(3)
   !! input vector to be rotated
  real(kind=dbl)                    :: res(3)
   !! output vector

  type(Quaternion_T)                :: qv, rqv, cq

  qv%qd = (/ 0.D0, v(1), v(2), v(3) /)
  qv%s = 'd'
  cq = quatconjg(self)
  rqv = quatmult(self, quatmult(qv, cq) )
  res(1:3) = rqv%qd(2:4)

end function quatLpd

!--------------------------------------------------------------------------!
recursive function quatLpd_vecarray(self, N, v) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatLpd_vecarray
  !! author: MDG
  !! version: 1.0
  !! date: 06/02/21
  !!
  !! actively rotate an array of unit vectors by a unit quaternion, L_p = p v p* (double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
   !! input quaternion
  integer(kind=irg),intent(in)      :: N
  real(kind=dbl),intent(in)         :: v(3, N)
   !! input vector to be rotated
  real(kind=dbl)                    :: res(3, N)
   !! output vector

  type(Quaternion_T)                :: qv, rqv, cq
  integer(kind=irg)                 :: i

  do i=1,N
    qv%qd = (/ 0.D0, v(1, i), v(2, i), v(3, i) /)
    qv%s = 'd'
    cq = quatconjg(self)
    rqv = quatmult(self, quatmult(qv, cq) )
    res(1:3, i) = rqv%qd(2:4)
  end do

end function quatLpd_vecarray

!--------------------------------------------------------------------------!
recursive subroutine quat2simplectic(self, c1, c2)
!DEC$ ATTRIBUTES DLLEXPORT :: quat2simplectic
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! split a quaternion into two complex numbers (single precision)
  !! Note: the simplectic transformation array has to be set first !

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
  complex(kind=sgl),INTENT(INOUT)   :: c1
  complex(kind=sgl),INTENT(INOUT)   :: c2

  real(kind=sgl)                    :: v(3)

  v = self%q(2:4)

! simplex part
  c1 = cmplx(self%q(1), DOT_PRODUCT(v,self%mu(1,1:3)))

! perplex part
  c2 = cmplx(DOT_PRODUCT(v,self%mu(2,1:3)), DOT_PRODUCT(v,self%mu(3,1:3)))

end subroutine quat2simplectic

!--------------------------------------------------------------------------!
recursive subroutine quat2simplecticd(self, c1, c2)
!DEC$ ATTRIBUTES DLLEXPORT :: quat2simplecticd
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! split a quaternion into two complex numbers (double precision)
  !! Note: the simplectic transformation array has to be set first !

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self
  complex(kind=dbl),INTENT(INOUT)   :: c1
  complex(kind=dbl),INTENT(INOUT)   :: c2

  real(kind=dbl)                    :: v(3)

  v = self%qd(2:4)

! simplex part
  c1 = cmplx(self%qd(1), DOT_PRODUCT(v,self%mud(1,1:3)))

! perplex part
  c2 = cmplx(DOT_PRODUCT(v,self%mud(2,1:3)), DOT_PRODUCT(v,self%mud(3,1:3)))

end subroutine quat2simplecticd

!--------------------------------------------------------------------------!
recursive subroutine simplectic2quat(self, c1, c2)
!DEC$ ATTRIBUTES DLLEXPORT :: simplectic2quat
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! perform an inverse simplectic transformation (single precision)
  !! Note: the simplectic transformation array has to be set first !

use, intrinsic :: iso_c_binding

IMPLICIT NONE

  class(Quaternion_T),INTENT(INOUT) :: self
  complex(kind=sgl),INTENT(INOUT)   :: c1
  complex(kind=sgl),INTENT(INOUT)   :: c2

  real(kind=sgl)                    :: xyz(3)

  xyz = (/ aimag(c1), real(c2), aimag(c2) /)

  self%q = (/ real(c1), DOT_PRODUCT(xyz, self%mu(1:3,1)), DOT_PRODUCT(xyz, self%mu(1:3,2)), DOT_PRODUCT(xyz, self%mu(1:3,3)) /)

end subroutine simplectic2quat

!--------------------------------------------------------------------------!
recursive subroutine simplectic2quatd(self, c1, c2)
!DEC$ ATTRIBUTES DLLEXPORT :: simplectic2quatd
  !! author: MDG
  !! version: 1.0
  !! date: 11/22/21
  !!
  !! perform an inverse simplectic transformation (double precision)
  !! Note: the simplectic transformation array has to be set first !

IMPLICIT NONE

  class(Quaternion_T),INTENT(INOUT) :: self
  complex(kind=dbl),INTENT(IN)      :: c1
  complex(kind=dbl),INTENT(IN)      :: c2

  real(kind=dbl)                    :: xyz(3)

  xyz = (/ aimag(c1), real(c2), aimag(c2) /)

  self%qd = (/ dble(c1), DOT_PRODUCT(xyz, self%mu(1:3,1)), DOT_PRODUCT(xyz, self%mu(1:3,2)), DOT_PRODUCT(xyz, self%mu(1:3,3)) /)

end subroutine simplectic2quatd

!--------------------------------------------------------------------------!
! pure recursive function quatslerp(self, qb, n) result(res)
recursive function quatslerp(self, qb, n) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatslerp
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! return an array of interpolated quaternions

IMPLICIT NONE

  class(Quaternion_T),intent(in)         :: self   ! = qa
   !! input quaternion (start)
  class(Quaternion_T),intent(in)         :: qb
   !! input quaternion (end)
  integer(kind=irg),intent(in)           :: n
   !! number of steps in the interpolation
  type(Quaternion_T)                     :: res(n)
   !! output interpolated quaternion list

  type(Quaternion_T)                     :: cqa
  real(kind=sgl)                         :: theta, phi, dphi, s
  real(kind=dbl)                         :: thetad, phid, dphid, sd
  integer(kind=irg)                      :: i

  if (self%s.eq.'s') then
      do i=1,n
        res(i)%q = (/ 0.0, 0.0, 0.0, 0.0 /)
        res(i)%s = 's'
      end do
      cqa = quatconjg(self)
      theta = acos( quatinnerproduct(qb, cqa ))
      if (theta.ne.0.0) then
        s = 1.0/sin(theta)
        dphi = theta/real(n-1)

        do i=1,n
          phi = real(i-1)*dphi
          res(i) = quatsmult(self, sin(theta-phi)*s ) + quatsmult(qb, sin(phi)*s )
        end do
      else
        do i=1,n
          res(i) = self
        end do
      end if
  else
      do i=1,n
        res(i)%qd = (/ 0.D0, 0.D0, 0.D0, 0.D0 /)
        res(i)%s = 'd'
      end do
      cqa = quatconjg(self)
      thetad = acos( quatinnerproduct(qb, cqa ))
      if (thetad.ne.0.D0) then
        sd = 1.D0/sin(theta)
        dphi = theta/dble(n-1)

        do i=1,n
          phi = dble(i-1)*dphi
          res(i) = quatsmultd(self, sin(theta-phi)*sd ) + quatsmultd(qb, sin(phi)*sd )
        end do
      else
        do i=1,n
          res(i) = self
        end do
      end if
  end if

end function quatslerp

!--------------------------------------------------------------------------
recursive function quatsequal(self, qb) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: quatsequal
  !! author: MDG
  !! version: 1.0
  !! date: 01/06/20
  !!
  !! quaternion comparison (double precision)

IMPLICIT NONE

  class(Quaternion_T),intent(in)    :: self, qb
   !! input quaternions
  logical                           :: res

  type(Quaternion_T)                :: diff

  real(kind=sgl)                    :: d, eps=1.0e-7
  real(kind=dbl)                    :: dd, epsd=1.0e-12

  res = .TRUE.
  diff = self - qb

  if (self%s.eq.'s') then
    d = maxval( abs( diff%q(:) ) )
    if (d.gt.eps) res = .FALSE.
  else
    dd = maxval( abs( diff%qd(:) ) )
    if (dd.gt.epsd) res = .FALSE.
  end if

end function quatsequal

end module mod_quaternions


! Filtering functions
module filter_module

  implicit none

  public :: filter

contains

  ! ------------------------------------------------------------------------------
  !> Multidimensional filter kernel given filtering weights
  ! ------------------------------------------------------------------------------
  subroutine filter(lo,  hi,&
                    Q,   Qlo,   Qhi,&
                    Qh,  Qhlo,  Qhhi,&
                    ng,&
                    w,&
                    nstart,&
                    ncnt,&
                    ncomp) bind(C, name = "filter")

    use amrex_constants_module

    implicit none

    integer, intent(in) :: lo  (3), hi  (3)
    integer, intent(in) :: Qlo (3), Qhi (3)
    integer, intent(in) :: Qhlo(3), Qhhi(3)
    integer, intent(in) :: ng ! (2*ng+1) filter points
    integer, intent(in) :: nstart
    integer, intent(in) :: ncnt
    integer, intent(in) :: ncomp

    double precision, intent (in   ) :: Q (  Qlo  (1):Qhi  (1),   Qlo  (2): Qhi  (2), Qlo  (3): Qhi  (3), ncomp)
    double precision, intent (inout) :: Qh(  Qhlo (1):Qhhi (1),   Qhlo (2): Qhhi (2), Qhlo (3): Qhhi (3), ncomp)
    double precision, intent (in   ) :: w(-ng:ng)

    integer :: i, j, k, nc, l, m, n

    do nc=nstart, nstart+ncnt-1

       do n = -ng, ng
          do k=lo(3),hi(3)
             do m = -ng, ng
                do j=lo(2),hi(2)
                   do l = -ng, ng
                      do i=lo(1),hi(1)
                         Qh(i,j,k,nc) = Qh(i,j,k,nc) + w(l) * w(m) * w(n) * Q(i+l,j+m,k+n,nc)
                      end do
                   end do
                end do
             end do
          end do
       end do

    end do

  end subroutine filter

end module filter_module


subroutine guardarResultados(saveASmatlab,saveAstxt,sl)
use debugstuff
use resultVars, only : allpoints,nPts
use sourcevars, only: PSV,SH,currentiFte,nfuentes,Po
use modelVars, only: NFREC,NPTSTIME,dfrec,t_vec,Uo
use glovars, only: z0,pi
implicit none
integer :: ip,i,comp
character(LEN=100) :: yax
logical, intent(in) :: saveASmatlab,saveAstxt,sl
real :: t0
complex*16, dimension(NPTSTIME) :: S
complex*16, dimension(:,:,:), allocatable :: ShR
character(LEN=32)  :: name
character(LEN=100) :: titleN
character(LEN=3),dimension(8) :: cname

!    W_to_t  guarda la respuesta en frecuencia y tiempo en los formatos indicados
   allocate(t_vec(NPTSTIME))
   allocate(Uo(NPTSTIME))
   call system("mkdir out")
   call chdir("out")
   CALL getcwd(yax)
      write(6,'(a,/,a)') 'Saving files At:',TRIM(yax)
   call system('rm *.m *.txt')

   if (sl) allocate(ShR(nPts,8,NPTSTIME))

   do currentiFte=1,nFuentes
      call sourceAmplitudeFunction
      if (sl) ShR = 0; cname(1:8) = ''
      ! para la correción del tiempo inicial de la señal
      t0 = Po(currentiFte)%t0
      t_vec(1:NPTSTIME) = z0
      t_vec(1) = exp(cmplx(0.0,-0.01* dfrec * t0*(2*pi),8))
      do i = 2,nfrec+1
        t_vec(i) = exp(cmplx(0.0,-(i-1)* dfrec * t0*(2*pi),8))
      end do!
      do i = NPTSTIME-NFREC+2,NPTSTIME
        t_vec(i) = exp(cmplx(0.0,-(i-NPTSTIME-1)* dfrec * t0*(2*pi),8))
      end do

      if (PSV) then
        do iP = 1,nPts
        !#< r ____________   W   _________________________________________ !#>
          write(yAx,'(a)') '$u_3$ [m]'
!         print*,ip,"---------------------",allpoints(iP)%resp(:,currentiFte)%W; print*," "
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%W,'w--',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,3,:) = S; cname(3) = '_w_'
        !#< r ____________   U   _________________________________________ !#>
          write(yAx,'(a)') '$u_1$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%U,'u--',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,1,:) = S; cname(1) = '_u_'
        !#< r ____________   sxx   _________________________________________ !#>
          write(yAx,'(a)') '$\sigma_{xx}$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%sxx,'sxx',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,4,:) = S; cname(4) = 'sxx'
        !#< r ____________   szx   _________________________________________ !#>
          write(yAx,'(a)') '$\sigma_{zx}$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%szx,'szx',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,5,:) = S; cname(5) = 'szx'
        !#< r ____________   szz   _________________________________________ !#>
          write(yAx,'(a)') '$\sigma_{zz}$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%szz,'szz',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,6,:) = S; cname(6) = 'szz'
        end do
      end if !psv
      if (SH) then
        do iP = 1,nPts
          !#< r ____________   V   _________________________________________ !#>
          write(yAx,'(a)') '$u_2$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%V,'v--',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,2,:) = S; cname(2) = '_v_'
          write(yAx,'(a)') '$\sigma_{xy}$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%sxy,'sxy',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,7,:) = S; cname(7) = 'sxy'
          write(yAx,'(a)') '$\sigma_{zy}$ [m]'
          call W_to_t(S,allpoints(iP)%resp(:,currentiFte)%szy,'szy',yax,iP,&
                    allpoints(iP)%center%x,&
                    allpoints(iP)%center%z,currentiFte,saveASmatlab,saveAstxt)
          if (sl) shR(iP,8,:) = S; cname(8) = 'szy'
!          call W_to_t(allpoints(iP)%resp(:,currentiFte)%Ty,'Ty-',yax,iP,&
!                    allpoints(iP)%center%x,&
!                    allpoints(iP)%center%z,saveASmatlab,saveAstxt)
        end do !ip
      end if !sh

      if (sl) then
      do comp=1,8
       if (cname(comp) .eq. '') cycle
       write(titleN,'(a,I0,a,a,a)') 'In_',currentiFte,'_',cname(comp),'.m'
       OPEN(3555,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
       !write(name,'(a,I0,a,I0)') 'inci_',currentiFte,'_',comp
        write(name,'(a)') 'var'
       call scripToMatlabMNmatrixZ(nPts,NPTSTIME,shR(:,comp,:),name,3555)
       close(3555)
      end do
      end if
    end do !insidencia
end subroutine guardarResultados

subroutine W_to_t(Sout,W,nombre,yax,iP,x_i,z_i,currentiFte,saveASmatlab,saveAstxt)
      use modelVars, only : NFREC, NPTSTIME, OMEI, &
                            t_vec, dt,Uo
      use glovars, only : z0
      use resultvars, only : allpoints
      use sourceVars, only : Po
      use wavelets
      use debugStuff
      implicit none
      complex*16, dimension(Nfrec+1), intent(in) :: W !espectro
      character(LEN=3)   :: nombre ! del componente
      character(LEN=100) :: titleN,yAx, CTIT ! texto para grafica
      integer ,intent(in) :: iP ! indice del receptor
      real*8, intent(in) :: x_i,z_i ! coordenadas del receptor
      integer, intent(in) :: currentiFte ! indice de la incidencia actual
      logical, intent(in) :: saveASmatlab,saveAstxt

      character(LEN=32)  :: name
      complex*16, dimension(NPTSTIME) :: S,Sout
      integer :: i,n_maxtime

      write(CTIT,'(a,F7.2,a,F7.2,a)')'(', x_i,' , ',z_i,')'

      S = z0
      S(1:nfrec+1)= W(1:nfrec+1:+1)
      S(NPTSTIME-NFREC+2:NPTSTIME) = conjg(W(nfrec:2:-1))

      ! (0) espectro sin corregir
      if (saveAstxt .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_rawfrec_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].txt'
        write(name,'(a,I0,a,a,I0)') 'rawf_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3201,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3201,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call showMNmatrixZ(int(nfrec +1),1,S(1:int(nfrec +1)),name,3201)
        close (3201)
       end if
!        call plotXYcomp(S(1:int(nfrec)),real(DFREC,4), &
!         int(nfrec),titleN, 'frec[hz] ',yAx, CTIT ,1200,800,0.0)
       if (saveASmatlab .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_rawfrec_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].m'
        write(name,'(a,I0,a,a,I0)') 'rawf_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3202,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3202,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call scripToMatlabMNmatrixZ(int(nfrec +1),1,S(1:int(nfrec +1)),name,3202)
        close (3202)
       end if

      !(1) señal en tiempo

!     if(ip.eq.3) then
!     print*,"*******"
!     DO i=1,NPTSTIME
!     print*,i,S(i),t_vec(i)
!     end do
!     end if

      S = S * t_vec ! t0 tiempo inicial
      S = S * Uo ! conv con fucion de amplitud
      S = FFTW(NPTSTIME,S,+1,1/(NPTSTIME*dt)) !backward (pasar al tiempo)

      ! (2) remover efecto de la frecuencia imaginaria (método DWN)
      !  La frecuencia imaginaria se utiliza como un amortiguamiento artificial
      !  que tiene el efecto de atenuar la amplitud de los arrivos de las
      !  fuentes periódicas en el espacio
      !  (surgen de truncar y discretizar una integral infinita)
      S = S * exp(- OMEI * Dt*((/(i,i=0, NPTSTIME-1)/))) !

      ! tiempo maximo para graficar
         n_maxtime = int(Po(currentiFte)%maxtime/dt)
         if(Po(currentiFte)%maxtime .lt. dt) n_maxtime = 2*nfrec
         if(Po(currentiFte)%maxtime .gt. NPTSTIME * real(dt,4)) n_maxtime = NPTSTIME
         S(n_maxtime+1: NPTSTIME) = z0;
         Sout = S

      !  (3) GRAFICAR en el tiempo
      if (saveAstxt .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_sism_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].txt'
        write(name,'(a,I0,a,a,I0)') 'Sism_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3203,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3203,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call showMNmatrixZ(NPTSTIME,1,S(1:int(NPTSTIME)),name,3203)
        close (3203)
       end if

       if (saveASmatlab .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_sism_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].m'
        write(name,'(a,I0,a,a,I0)') 'Sism_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3204,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3204,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call scripToMatlabMNmatrixZ(NPTSTIME,1,S(1:int(NPTSTIME)),name,3204)
        close (3204)
       end if

      !  (4) espectro correcto
!       ! tapper ?

        ! fft
        S = FFTW(NPTSTIME,S(1:int(NPTSTIME)),-1,dt) !forward

        if (saveAstxt .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_f_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].txt'
        write(name,'(a,I0,a,a,I0)') 'f_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3205,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3205,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call showMNmatrixZ(int(NPTSTIME/2+1),1,S(1:int(NPTSTIME/2+1)),name,3205)
        close (3205)
       end if

       if (saveASmatlab .eqv. .true.) then
        write(titleN,'(I0,a,I0,a,a,a,I0,a,I0,a,I0,a,I0,a)') &
               iP,'_in_',currentiFte,'_f_',nombre,'[', &
               int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
               int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].m'
        write(name,'(a,I0,a,a,I0)') 'f_IP',iP,trim(nombre),'_in_',currentiFte
        OPEN(3206,FILE=trim(titleN),FORM="FORMATTED",ACTION='WRITE')
        write(3206,'(a,a,/,a,EN26.9,a,EN26.9,a,/,a)') '%',yAx, &
         '%(', allpoints(iP)%center%x,',',allpoints(iP)%center%z,')','%% '
        call scripToMatlabMNmatrixZ(int(NPTSTIME/2+1),1,S(1:int(NPTSTIME/2+1)),name,3206)
        close (3206)
       end if

!     ! grafica logaritmica
!           write(titleN,'(a,a,I0,a,I0,a,I0,a,I0,a,I0,a)') &
!              'fL_',nombre,iP,'[', &
!              int(x_i),'.',abs(int((x_i-int(x_i))*10)),';', &
!              int(z_i),'.',abs(int((z_i-int(z_i))*10)),'].pdf'
!           logflag = 'logx     '
!           write(xAx,'(a)') "frec[Hz]"
!           call plotSpectrum(S(1: NPTSTIME/2),real(DFREC,4), NPTSTIME/2, NPTSTIME/2, &
!               titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))

end subroutine W_to_t

subroutine sourceAmplitudeFunction
      use wavelets !las funciones: ricke
      use modelVars, only : Dt,Uo,dt!,maxtime
      use modelVars, only : nfrec, NPTSTIME,OMEI!DFREC
      use gloVars, only : ve => verbose,Ur,Ui,z0,Printnum
      use sourceVars, only:Po,iFte=>currentiFte
      !use ploteo10pesos
      implicit none
      integer  :: i,nval
!      character(LEN=9)          :: logflag
!      character(LEN=100)        :: titleN,xAx,yAx,CTIT

!      CHARACTER(len=32) :: arg
      logical :: inquire, lexist!, argumA
      real*8 :: val1,val2
      complex*16, dimension(NPTSTIME) :: S
      !complex*16 :: FFTW!(NPTSTIME)
      integer :: n_maxtime
!      argumA = .false.
!      CALL get_command_argument(1, arg)
!      IF (LEN_TRIM(arg) .ne. 0) then
!        if (trim(arg) .eq. '-a') then
!        iFte = 1
!        ve = 6
!        argumA = .true.
!        end if
!      end if

       n_maxtime = int(Po(iFte)%maxtime/dt)
       if(Po(iFte)%maxtime .lt. dt) n_maxtime = 2*nfrec
       if(Po(iFte)%maxtime .gt. NPTSTIME * real(dt,4)) n_maxtime = NPTSTIME

      ! grafica del factor de correción
      S = exp(- OMEI * Dt*((/(i,i=0, NPTSTIME-1)/)))
!      write(titleN,'(a)') 'x-LevantonDWN.pdf'
!      write(CTIT,'(a)') 'exp(-omei t)'
!      write(xAx,'(a)') 't[sec]'
!      write(yAx,'(a)') ''
!        call plotXYcomp(S(1:n_maxtime),real(Dt,4), &
!         int(n_maxtime),titleN,xAx,yAx, CTIT ,1200,800,0.0)

!     real :: factor
      ! Amplitude function of incident wave
      ! prepare the signal we will use as incident wave amplitude.
      ! el tamaño del ricker es 2*NFREC porque incluirá el conjugado

! 153
      Uo(:)=z0

      if(Po(iFte)%ampfunction .eq. 1) then
        call ricker(Uo(:),Po(iFte)%Ts,Po(iFte)%Tp) ! Ricker wavelet saved on Uo
!          if (ve .ge. 1) then
!            write(Printnum,'(a)')'   Incident wave amplitude function: Ricker'
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-t.pdf'
!            write(CTIT,'(a)') 'WaveAmplitude of Ricker wavelet'
!            xAx = 'time[sec]'
!            write(yAx,'(a)') 'amplitude'
!            call plotXYcomp(Uo(1:n_maxtime),real(Dt,4), &
!                 n_maxtime,titleN,xAx,yAx,CTIT,1200,800,0.0)
!          end if
        ! forward
        Uo(:) = FFTW(NPTSTIME,Uo(:),-1,Dt)
        Uo(1) = 0
!          if (ve .ge. 1) then
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-f.pdf'
!            xAx = 'frec[Hz] '
!            write(yAx,'(a)') 'amplitude'
!!           logflag = 'logx     '
!!           logflag = 'none     '
!            call plotXYcomp(Uo(:),real(DFREC,4), &
!                 size(Uo(:)),titleN,xAx,yAx,CTIT,1200,800,0.0)
!!           call plotSpectrum(Uo(:,iFte),real(DFREC,4), size(Uo(:,iFte)),int(size(Uo(:,iFte))/2), &
!!           titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))
!          end if
     !********************************************************************************
      elseif(Po(iFte)%ampfunction .eq. 2) then ! Gaussian
        call gaussian(Uo(:),NPTSTIME,Po(iFte)%sigGaus)
!          if (ve .ge. 1) then
!           write(Printnum,'(a)')'   Incident wave amplitude function: Gaussian'
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-f.pdf'
!            write(CTIT,'(a)') 'WaveAmplitude of Gaussian wavelet'
!            write(xAx,'(a)') 'frec[Hz] '
!            write(yAx,'(a)') 'amplitude'
!!           call plotXYcomp(Uo(:,iFte),real(DFREC,4), &
!!                n_maxtime,titleN,xAx,yAx,CTIT,1200,800,0.0)
!!           print*,Uo(:,iFte)
!            call plotXYcomp(Uo(:),real(DFREC,4), &
!                 size(Uo(:)),titleN,xAx,yAx,CTIT,1200,800,0.0)
!!           call plotSpectrum(Uo(:,iFte),real(DFREC,4), size(Uo(:,iFte)),int(size(Uo(:,iFte))/2), &
!!           titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))
!          end if
      elseif(Po(iFte)%ampfunction .gt. 20) then ! GaussianCúbico
        call gaussian(Uo(:),NPTSTIME,Po(iFte)%sigGaus) !shift =  int((int(sigGaus) - sigGaus) * 1000)
        if (int((int(Po(iFte)%sigGaus) - Po(iFte)%sigGaus) * 1000) .gt. 0) &
        write(Printnum,'(a,I0)')'   One sided Gaussian filter with shift in points:',&
         int((int(Po(iFte)%sigGaus) - Po(iFte)%sigGaus) * 1000)
        Uo(:) = Uo(:) ** (Po(iFte)%ampfunction-20)
!          if (ve .ge. 1) then
!           write(Printnum,'(a,I0)')'   Incident wave amplitude function: Gaussian ',int((Po(iFte)%ampfunction-20))
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-f.pdf'
!            write(CTIT,'(a,I0,a)') 'WaveAmplitude of Gaussian',int((Po(iFte)%ampfunction-20)),' wavelet'
!            write(xAx,'(a)') 'frec[Hz] '
!            write(yAx,'(a)') 'amplitude'
!!           call plotXYcomp(Uo(:,iFte),real(DFREC,4), &
!!                n_maxtime,titleN,xAx,yAx,CTIT,1200,800,0.0)
!!           print*,Uo(:,iFte)
!            call plotXYcomp(Uo(:),real(DFREC,4), &
!                 size(Uo(:)),titleN,xAx,yAx,CTIT,1200,800,0.0)
!!           call plotSpectrum(Uo(:,iFte),real(DFREC,4), size(Uo(:,iFte)),int(size(Uo(:,iFte))/2), &
!!           titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))
!          end if
      elseif(Po(iFte)%ampfunction .eq. 3) then ! inDispl.txt
     !********************************************************************************
!        CALL chdir("..")
!        CALL chdir("ins")
        inquire(file="inAmplitude.txt",exist=lexist)
        if (lexist) then
        OPEN(77,FILE="inAmplitude.txt",FORM="FORMATTED")
        else
        write(6,'(a)') 'There is a missing input file. '
        stop 'Check "inAmplitude.txt" on this directory'
        end if
        READ(77,*)
        READ(77,*) inquire
        READ(77,*) nval
        if (nval .gt. NPTSTIME) then
        print*, "**** warning inAmplitude trimmed to ", NPTSTIME
        nval = NPTSTIME
        end if
        Uo(:) = 0
        if ( inquire) then
        do i = 1,nval
        READ(77,*) val1
        Uo(i) = UR * val1
        end do
        close(77)
!          if (ve .ge. 1) then
!            CALL chdir("..")
!            call chdir(trim(adjustl(rutaOut)))
!            write(Printnum,'(a)')'   Incident wave amplitude function from file'
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-t.pdf'
!            write(CTIT,'(a)') 'WaveAmplitude'
!            xAx = 'time[sec]'
!            write(yAx,'(a)') 'amplitude'
!            call plotXYcomp(Uo(1:NPTSTIME),real(Dt,4), &
!                 n_maxtime,titleN,xAx,yAx,CTIT,1200,800,0.0)
!          end if

        ! forward
        Uo(:) = FFTW(NPTSTIME,Uo(:),-1,Dt)

!          if (ve .ge. 1) then
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-f.pdf'
!            xAx = 'frec[Hz] '
!            write(yAx,'(a)') 'amplitude'
!            logflag = 'logx     '
!!           logflag = 'none     '
!            call plotSpectrum(Uo(:),real(DFREC,4), size(Uo(:)),int(size(Uo(:))/2), &
!            titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))
!            CALL chdir("..")
!            CALL chdir("ins")
!          end if
        else
        do i = 1,nval
        READ(77,*) val1, val2
        Uo(i) = UR * val1 + UI * val2
        end do
!        if (ve .ge. 1) then
!            CALL chdir("..")
!            call chdir(trim(adjustl(rutaOut)))
!            write(titleN,'(a,I0,a)') 'x-amp',iFte,'-f.pdf'
!            xAx = 'frec[Hz] '
!            write(yAx,'(a)') 'amplitude'
!            logflag = 'logx     '
!!           logflag = 'none     '
!            call plotSpectrum(Uo(:),real(DFREC,4), size(Uo(:)),int(size(Uo(:))/2), &
!            titleN,xAx,yAx,logflag,1200,800,real(DFREC*(NFREC+1),4))
!            CALL chdir("..")
!            CALL chdir("ins")
!          end if
        close(77)
        end if

!        CALL chdir("..")
!        call chdir(trim(adjustl(rutaOut)))

      else  ! DIRAC -----------------------------------------
       if (ve .ge. 1) write(Printnum,'(a)')'   Incident wave amplitude function: Dirac delta'
        Uo(:)=UR
      end if !tipoPulso
      Uo(:) = Uo(:)*Po(iFte)%Escala !escala de la señal
!      write(Printnum,'(a)') &
!       "---------------------------------------------------------------------------------"
!      if (argumA .eqv. .true.) then
!      if (iFte .eq. nfuentes) then
!      stop "argumento -a"
!      else
!      iFte = iFte + 1
!      go to 153
!      end if
!      end if
end subroutine sourceAmplitudeFunction


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program AK135_vals

use global_1d_models

implicit none

character(len=50) :: arg
character(len=50),parameter :: fmt='(3f7.3,f6.1,f6.1)'
character(len=50),parameter :: fmt2='(3f7.3,f6.1,f6.2,f7.1)'
character(len=50),parameter :: hdr='#    vp     vs    rho     P     g'
real(8) :: depth,vp,vs,rho,P,g
integer :: iostatus

if (command_argument_count() > 1) then
   write(0,'(a)') '  Usage: ak135 [depth / km]'
   write(0,'(a)') '     or: reads series of depths from stdin'
   stop
endif

!  Use the argument on the command line
if (command_argument_count() == 1) then
   call get_command_argument(1,arg)
   read(arg,*) depth
   call ak135(depth,vp=vp,vs=vs,rho=rho)
   P = pressure(depth,model='AK135')
   g = gravity(depth,model='AK135')
   write(*,'(a)') hdr
   write(*,fmt) vp,vs,rho,P,g
   stop
endif

iostatus = 0
write(*,'(2a)') trim(hdr),'  depth'
do while (iostatus == 0)
   read(*,*,iostat=iostatus) depth
   if (iostatus /= 0) stop
   call ak135(depth,vp=vp,vs=vs,rho=rho)
   P = pressure(depth,model='AK135')
   g = gravity(depth,model='AK135')
   write(*,fmt2) vp,vs,rho,P,g,depth
enddo

end program AK135_vals


!!# MODULE: SUBROUTINE <SUB_levQuadratureReflect>
MODULE SUB_levQuadratureReflect

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS

!!## EXTERNAL PROCEDURES
USE FUN_Reverse                                !!((04-A-FUN_Reverse.f90))
USE FUN_SIZEa                                  !!((06-B-FUN_SIZEa.f90))
USE SUB_aQuadratureReflect                     !!((05-B-SUB_aQuadratureReflect.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE levQuadratureReflect
 MODULE PROCEDURE levQuadratureReflect_Rsp
 MODULE PROCEDURE levQuadratureReflect_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: levQuadratureReflect

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: levQuadratureReflect_Rsp
PURE SUBROUTINE levQuadratureReflect_Rsp( xa,xp,wa,wp )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_levQuadratureReflect.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_levQuadratureReflect.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: levQuadratureReflect_Rdp
PURE SUBROUTINE levQuadratureReflect_Rdp( xa,xp,wa,wp )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_levQuadratureReflect.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_levQuadratureReflect.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


C     Exemple de la section 3.1.4 du rapport sur les dependances

C     Version F90 avec motifs. La semantique est un peu differente
C     puisqu'il y a un effet de bord dans f() et que f() est appele
C     moins souvent que dans la version f77.

C     A compiler avec f90

      program cas314_f90

      real X(0:159), Y(0:11)

      do i1 = 0, 39
            X(4*i1:4*i1+3) = f()
      enddo

      print *, X

      do i2 = 0, 11
         Y(i2) = g(X(i2+10:i2+19))
      enddo

c     Valeurs attendues: 72, avec comme increments la suite (+3, +3, +2, +2)*
C     72.0 75.0 78.0 80.0 82.0 85.0 88.0 90.0 92.0 95.0 98.0 100.0
      print *, Y

      end

      function f()
c      static c
      data c /3./
      c = c + 1.
      f = c
      end

      function g(z)
      real z(0:9)

      print *, 'z(0)=', z(0)

      g = 0.
      do i = 0, 9
         g = g + z(i)
      enddo
      end


! { dg-do run }
!
! PR fortran/53389
!
! The program was leaking memory before due to
! realloc on assignment and nested functions.
!
module foo
  implicit none
  contains

  function filler(array, val)
    real, dimension(:), intent(in):: array
    real, dimension(size(array)):: filler
    real, intent(in):: val

    filler=val

  end function filler
end module

program test
  use foo
  implicit none

  real, dimension(:), allocatable:: x, y
  integer, parameter:: N=1000 !*1000
  integer:: i

!  allocate( x(N) )
  allocate( y(N) )
  y=0.0

  do i=1, N
!    print *,i
    x=filler(filler(y, real(2*i)), real(i))
    y=y+x
  end do

end program test


module mod_quaternions

   type quaternion
      real :: a, b, c, d
   end type quaternion

   interface operator(+)
      module procedure sum_qt
   end interface

contains

   function sum_qt(x, y)
      type(quaternion)             :: sum_qt
      type(quaternion), intent(in) :: x, y
      sum_qt%a = x%a + y%a
      sum_qt%b = x%b + y%b
      sum_qt%c = x%c + y%c
      sum_qt%d = x%d + y%d
   end function sum_qt

end module mod_quaternions

program main

   use mod_quaternions

   implicit none

   type(quaternion) :: x = quaternion(1.0, 2.0, 3.0, 4.0)
   type(quaternion) :: y = quaternion(5.0, 6.0, 7.0, 8.0)
   type(quaternion) :: z

   z = x + y

   print *, z%a, z%b, z%c, z%d

end program


      SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute a rank-revealing RQ factorization of a real general
C     M-by-N matrix  A,  which may be rank-deficient, and estimate its
C     effective rank using incremental condition estimation.
C
C     The routine uses a truncated RQ factorization with row pivoting:
C                                   [ R11 R12 ]
C        P * A = R * Q,  where  R = [         ],
C                                   [  0  R22 ]
C     with R22 defined as the largest trailing upper triangular
C     submatrix whose estimated condition number is less than 1/RCOND.
C     The order of R22, RANK, is the effective rank of A.  Condition
C     estimation is performed during the RQ factorization process.
C     Matrix R11 is full (but of small norm), or empty.
C
C     MB03PY  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             ( LDA, N )
C             On entry, the leading M-by-N part of this array must
C             contain the given matrix A.
C             On exit, the upper triangle of the subarray
C             A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper
C             triangular matrix R22;  the remaining elements in the last
C             RANK  rows, with the array TAU, represent the orthogonal
C             matrix Q as a product of  RANK  elementary reflectors
C             (see METHOD).  The first  M-RANK  rows contain the result
C             of the RQ factorization process used.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest trailing triangular
C             submatrix R22 in the RQ factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             0 <= RCOND <= 1.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e., the order of
C             the submatrix R22.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(2): smallest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
C                      if RANK < MIN( M, N ), or of
C                      R(M-RANK+1:M,N-RANK+1:N), otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the trailing rows were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(M-RANK+1:M,N-RANK+1:N).
C
C     JPVT    (output) INTEGER array, dimension ( M )
C             If JPVT(i) = k, then the i-th row of P*A was the k-th row
C             of A.
C
C     TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
C             The trailing  RANK  elements of TAU contain the scalar
C             factors of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( 3*M-1 )
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
C     METHOD
C
C     The routine computes a truncated RQ factorization with row
C     pivoting of A,  P * A = R * Q,  with  R  defined above, and,
C     during this process, finds the largest trailing submatrix whose
C     estimated condition number is less than 1/RCOND, taking the
C     possible positive value of SVLMAX into account.  This is performed
C     using an adaptation of the LAPACK incremental condition estimation
C     scheme and a slightly modified rank decision test.  The
C     factorization process stops when  RANK  has been determined.
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
C     in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth row of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Bischof, C.H. and P. Tang.
C         Generalizing Incremental Condition Estimation.
C         LAPACK Working Notes 32, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-132,
C         May 1991.
C
C     [2] Bischof, C.H. and P. Tang.
C         Robust Incremental Condition Estimation.
C         LAPACK Working Notes 33, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-133,
C         May 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001,
C     Jan. 2009.
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C
C     KEYWORDS
C
C     Eigenvalue problem, matrix operations, orthogonal transformation,
C     singular values.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * )
C     .. Local Scalars ..
      INTEGER            I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI,
     $                   PVT
      DOUBLE PRECISION   AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN,
     $                   SMINPR, TEMP, TEMP2, TOLZ
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DNRM2
      EXTERNAL           DLAMCH, DNRM2, IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP,
     $                   XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN
         INFO = -5
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -6
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03PY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         RANK = 0
         SVAL( 1 ) = ZERO
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
         RETURN
      END IF
C
      TOLZ  = SQRT( DLAMCH( 'Epsilon' ) )
      ISMIN = M
      ISMAX = ISMIN + M
      JWORK = ISMAX + 1
C
C     Initialize partial row norms and pivoting vector. The first m
C     elements of DWORK store the exact row norms. The already used
C     trailing part is then overwritten by the condition estimator.
C
      DO 10 I = 1, M
         DWORK( I ) = DNRM2( N, A( I, 1 ), LDA )
         DWORK( M+I ) = DWORK( I )
         JPVT( I ) = I
   10 CONTINUE
C
C     Compute factorization and determine RANK using incremental
C     condition estimation.
C
      RANK = 0
C
   20 CONTINUE
      IF( RANK.LT.K ) THEN
         I = K - RANK
C
C        Determine ith pivot row and swap if necessary.
C
         MKI = M - RANK
         NKI = N - RANK
         PVT = IDAMAX( MKI, DWORK, 1 )
C
         IF( PVT.NE.MKI ) THEN
            CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( MKI )
            JPVT( MKI ) = ITEMP
            DWORK( PVT )   = DWORK( MKI )
            DWORK( M+PVT ) = DWORK( M+MKI )
         END IF
C
         IF( NKI.GT.1 ) THEN
C
C           Save A(m-k+i,n-k+i) and generate elementary reflector H(i)
C           to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n).
C
            AII = A( MKI, NKI )
            CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I )
     $                 )
         END IF
C
         IF( RANK.EQ.0 ) THEN
C
C           Initialize; exit if matrix is zero (RANK = 0).
C
            SMAX = ABS( A( M, N ) )
            IF ( SMAX.EQ.ZERO ) THEN
               SVAL( 1 ) = ZERO
               SVAL( 2 ) = ZERO
               SVAL( 3 ) = ZERO
               RETURN
            END IF
            SMIN = SMAX
            SMAXPR = SMAX
            SMINPR = SMIN
            C1 = ONE
            C2 = ONE
         ELSE
C
C           One step of incremental condition estimation.
C
            CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 )
            CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN,
     $                   DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 )
            CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX,
     $                   DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 )
         END IF
C
         IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
            IF( SVLMAX*RCOND.LE.SMINPR ) THEN
               IF( SMAXPR*RCOND.LE.SMINPR ) THEN
C
                  IF( MKI.GT.1 ) THEN
C
C                    Continue factorization, as rank is at least RANK.
C                    Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right.
C
                     AII = A( MKI, NKI )
                     A( MKI, NKI ) = ONE
                     CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA,
     $                           TAU( I ), A, LDA, DWORK( JWORK ) )
                     A( MKI, NKI ) = AII
C
C                    Update partial row norms.
C
                     DO 30 J = 1, MKI - 1
                        IF( DWORK( J ).NE.ZERO ) THEN
                           TEMP = ABS( A( J, NKI ) ) / DWORK( J )
                           TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ),
     $                                 ZERO )
                           TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2
                           IF( TEMP2.LE.TOLZ ) THEN
                              DWORK( J )   = DNRM2( NKI-1, A( J, 1 ),
     $                                              LDA )
                              DWORK( M+J ) = DWORK( J )
                           ELSE
                              DWORK( J ) = DWORK( J )*SQRT( TEMP )
                           END IF
                        END IF
   30                CONTINUE
C
                  END IF
C
                  DO 40 I = 1, RANK
                     DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 )
                     DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 )
   40             CONTINUE
C
                  IF( RANK.GT.0 ) THEN
                     ISMIN = ISMIN - 1
                     ISMAX = ISMAX - 1
                  END IF
                  DWORK( ISMIN ) = C1
                  DWORK( ISMAX ) = C2
                  SMIN = SMINPR
                  SMAX = SMAXPR
                  RANK = RANK + 1
                  GO TO 20
               END IF
            END IF
         END IF
      END IF
C
C     Restore the changed part of the (M-RANK)-th row and set SVAL.
C
      IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN
         CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA )
         A( MKI, NKI ) = AII
      END IF
      SVAL( 1 ) = SMAX
      SVAL( 2 ) = SMIN
      SVAL( 3 ) = SMINPR
C
      RETURN
C *** Last line of MB03PY ***
      END


!===============================================================================
program CIJ_thom_st_prog
!===============================================================================
!  Program form of the CIJ_thom_st routine in anisotropy_ajn module

   use anisotropy_ajn, only: CIJ_thom_st

   implicit none

   real(8) :: ecs(6,6)
   real(8) :: vp,vs,rho,delst,eps,gam
   integer :: i
   character(len=250) :: arg

   if (command_argument_count() /= 6) then
      write(0,'(a)') 'Usage:  CIJ_thom_st [vp] [vs] [rho] [delta] [epsilon] [gamma]',&
                     '  Rotationally symmetric about 3-axis (vertical)'
      write(0,'(a)') '  Sends 36 elastic constants to stdout (density-normalised).'
      stop
   endif

   call get_command_argument(1,arg) ;  read(arg,*) vp
   call get_command_argument(2,arg) ;  read(arg,*) vs
   call get_command_argument(3,arg) ;  read(arg,*) rho
   call get_command_argument(4,arg) ;  read(arg,*) delst
   call get_command_argument(5,arg) ;  read(arg,*) eps
   call get_command_argument(6,arg) ;  read(arg,*) gam

   ecs = CIJ_thom_st(vp,vs,rho,eps,gam,delst)

   write(*,*) ecs/rho

end program CIJ_thom_st_prog
!-------------------------------------------------------------------------------


      DOUBLE PRECISION FUNCTION PHO_GLUSPL(Zmin)
C*********************************************************************
C
C     calculate quark - antiquark light cone momentum fractions
C     according to Altarelli-Parisi g->q aq splitting function
C     (symmetric z interval assumed)
C
C     input: ZMIN    minimal Z value allowed,
C                    1-ZMIN maximal Z value allowed
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION ALEXP , DEPS , DT_RNDM , xi , zmax , Zmin ,
     &                 zminl , zz
      SAVE

      PARAMETER (ALEXP=0.3333333333D0,DEPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'

      IF ( Zmin.GE.0.5D0 ) THEN
         IF ( IDEb(69).GT.2 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,E12.4)')
     &            'PHO_GLUSPL: ZMIN>=0.5' , Zmin
         END IF
         zz = 0.D0
         GOTO 100
      ELSE IF ( Zmin.LE.0.D0 ) THEN
         IF ( IDEb(69).GT.2 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,E12.4)')
     &            'PHO_GLUSPL: ZMIN<=0' , Zmin
         END IF
         zminl = DEPS
      ELSE
         zminl = Zmin
      END IF

      zmax = 1.D0 - zminl
      xi = DT_RNDM(zmax)
      zz = ((1.D0-xi)*zminl**3+xi*zmax**3)**ALEXP
      IF ( DT_RNDM(zz).LT.0.5D0 ) zz = 1.D0 - zz

 100  IF ( IDEb(69).GE.10 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2E12.4)')
     &         'PHO_GLUSPL: ZMIN,Z ' , Zmin , zz
      END IF
      PHO_GLUSPL = zz
      END FUNCTION


      DOUBLE PRECISION FUNCTION alngam(x)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION ALNGAM(X)
C                 double precision LN of the GAMma function
C
C
C                              Function
C
C
C     Returns the natural logarithm of GAMMA(X).
C
C
C                              Arguments
C
C
C     X --> value at which scaled log gamma is to be returned
C                    X is DOUBLE PRECISION
C
C
C                              Method
C
C
C     If X .le. 6.0, then use recursion to get X below 3
C     then apply rational approximation number 5236 of
C     Hart et al, Computer Approximations, John Wiley and
C     Sons, NY, 1968.
C
C     If X .gt. 6.0, then use recursion to get X to at least 12 and
C     then use formula 5423 of the same source.
C
C**********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION hln2pi
      PARAMETER (hln2pi=0.91893853320467274178D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION offset,prod,xx
      INTEGER i,n
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION coef(5),scoefd(4),scoefn(9)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION devlpl
      EXTERNAL devlpl
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC log,dble,int
C     ..
C     .. Data statements ..
      DATA scoefn(1)/0.62003838007127258804D2/,
     +     scoefn(2)/0.36036772530024836321D2/,
     +     scoefn(3)/0.20782472531792126786D2/,
     +     scoefn(4)/0.6338067999387272343D1/,
     +     scoefn(5)/0.215994312846059073D1/,
     +     scoefn(6)/0.3980671310203570498D0/,
     +     scoefn(7)/0.1093115956710439502D0/,
     +     scoefn(8)/0.92381945590275995D-2/,
     +     scoefn(9)/0.29737866448101651D-2/
      DATA scoefd(1)/0.62003838007126989331D2/,
     +     scoefd(2)/0.9822521104713994894D1/,
     +     scoefd(3)/-0.8906016659497461257D1/,
     +     scoefd(4)/0.1000000000000000000D1/
      DATA coef(1)/0.83333333333333023564D-1/,
     +     coef(2)/-0.27777777768818808D-2/,
     +     coef(3)/0.79365006754279D-3/,coef(4)/-0.594997310889D-3/,
     +     coef(5)/0.8065880899D-3/
C     ..
C     .. Executable Statements ..
      IF (.NOT. (x.LE.6.0D0)) GO TO 70
      prod = 1.0D0
      xx = x
      IF (.NOT. (x.GT.3.0D0)) GO TO 30
   10 IF (.NOT. (xx.GT.3.0D0)) GO TO 20
      xx = xx - 1.0D0
      prod = prod*xx
      GO TO 10

   20 CONTINUE
   30 IF (.NOT. (x.LT.2.0D0)) GO TO 60
   40 IF (.NOT. (xx.LT.2.0D0)) GO TO 50
      prod = prod/xx
      xx = xx + 1.0D0
      GO TO 40

   50 CONTINUE
   60 alngam = devlpl(scoefn,9,xx-2.0D0)/devlpl(scoefd,4,xx-2.0D0)
C
C
C     COMPUTE RATIONAL APPROXIMATION TO GAMMA(X)
C
C
      alngam = alngam*prod
      alngam = log(alngam)
      GO TO 110

   70 offset = hln2pi
C
C
C     IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET
C
C
      IF ((x.GT.12.0D0)) GO TO 90
      n = int(12.0D0-x)
      IF (.NOT. (n.GT.0)) GO TO 90
      prod = 1.0D0
      DO 80,i = 1,n
          prod = prod* (x+dble(i-1))
   80 CONTINUE
      offset = offset - log(prod)
      xx = x + dble(n)
      GO TO 100

   90 xx = x
C
C
C     COMPUTE POWER SERIES
C
C
  100 alngam = devlpl(coef,5,1.0D0/ (xx**2))/xx
      alngam = alngam + offset + (xx-0.5D0)*log(xx) - xx
  110 RETURN

      END


!
!     -------------------------------------------------------------
!      S I X J 5
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | J/2  K/2  L/2 |                                            *
!     | M/2  N/2  1/2 |             [B.M.X. 75]                    *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                             March 1995   *
!
      SUBROUTINE SIXJ5(J, K, L, M, N, ITIK, SI)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:06:26  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
      INTEGER  :: K
      INTEGER  :: L
      INTEGER  :: M
      INTEGER  :: N
      INTEGER , INTENT(IN) :: ITIK
      REAL(DOUBLE) , INTENT(OUT) :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I1
      REAL(DOUBLE) :: AS, A, B, C, AKA
!-----------------------------------------------
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(J,K,L,M,N,1) == 0) RETURN
      ENDIF
      I1 = (J + K + L)/2
      AS = DBLE(I1)
      A = DBLE(L)
      B = DBLE(K)
      C = DBLE(J)
      AKA = ONE
      IF (MOD(I1,2) /= 0) AKA = -AKA
      IF (K < M) THEN
         IF (J < N) THEN
!              M > K,  J < N.
            SI = -AKA*DSQRT((AS + TWO)*(AS - A + ONE)/((B + ONE)*(B + TWO)*(C&
                + ONE)*(C + TWO)))
         ELSE IF (J > N) THEN
!              M > K,  J > N.
            SI = AKA*DSQRT((AS - C + ONE)*(AS - B)/((B + ONE)*(B + TWO)*C*(C + &
               ONE)))
         ENDIF
      ELSE IF (K > M) THEN
         IF (J < N) THEN
!             M < K,  J < N.
            SI = AKA*DSQRT((AS - C)*(AS - B + ONE)/(B*(B + ONE)*(C + ONE)*(C + &
               TWO)))
         ELSE IF (J > N) THEN
!             M < K,  J > N.
            SI = AKA*DSQRT((AS + ONE)*(AS - A)/(B*(B + ONE)*C*(C + ONE)))
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE SIXJ5