module math
  use global_variables
  implicit none

  public :: Bvgd, Levmar, Diag, Svd
  private :: Write_info, Triu, Norm, Pinv, Qr

  interface Diag
     module procedure Diag_ele, Diag_mat
  end interface

contains

  function Bvgd(alt, mu1, mu2, s1, s2, rho) result(c)
    ! Bivariate Gaussian distribution
    implicit none
    real(DP), dimension(:), intent(in) :: alt
    real(DP), intent(in) :: mu1, mu2, s1, s2, rho
    real(DP), dimension(size(alt), size(alt)) :: c
    real(DP) :: d1, d2, apu1, apu2
    integer :: i, j, n
    n = size(alt)
    apu1 = 1.0/(2.0*PI*s1*s2*sqrt(1.0-rho**2))
    apu2 = -1.0/(2.0*(1.0-rho**2))
    do i = 1, n
       do j = 1, n
          d1 = alt(i) - mu1
          d2 = alt(j) - mu2
          C(i, j) = apu1*exp(apu2*((d1/s1)**2+(d2/s2)**2-(2.0*rho*d1*d2)/(s1*s2)))
       end do
    end do
  end function Bvgd

  function Norm(x) result(valu)
    ! L2-norm
    implicit none
    real(DP), dimension(:), intent(in) :: x
    real(DP) :: valu
    valu = sqrt(sum(x**2))
  end function Norm

  function Pinv(a) result(ai)
    ! Pseudo-inversion using SVD
    implicit none
    real(DP), dimension (:,:), intent(in) :: a
    real(DP), dimension(size(a,2), size(a,1)) :: ai
    real(DP), dimension(size(a,1), size(a,2)) :: u
    real(DP), dimension(size(a,2), size(a,2)) :: s, v
    integer :: r, nite
    real(DP), dimension(size(a,2)) :: d
    real(DP), parameter :: TOL = 1e-4
    real(DP), dimension(:,:), allocatable :: d2
    call Svd(a, u, s, v, nite)
    d = Diag(s)
    r = count(mask = d > TOL) ! take the singular values > tol
    allocate(d2(r,r))
    d2 = Diag(1.0 / d(1:r))
    ai = matmul(matmul(v(:,1:r), d2),transpose(u(:,1:r)))
    deallocate(d2)
  end function Pinv

  subroutine Svd(a, u, s, v, nite)
    ! Singular value decomposition
    implicit none
    real(DP), dimension(:,:), intent(in) :: a
    real(DP), dimension(size(a,1), size(a,2)), intent(out) :: u
    real(DP), dimension(size(a,2), size(a,2)), intent(out) :: s, v
    integer, intent(out) :: nite
    real(DP), dimension(size(a,1), size(a,2)) :: q1
    real(DP), dimension(size(a,1), size(a,1)) :: u1
    real(DP), dimension(size(a,2), size(a,2)) :: q, e
    real(DP), dimension(size(a,2)) :: f
    real(DP), parameter :: EPS = 1e-4
    real(DP) :: err
    integer :: n
    ! init u,v,u1
    u = 0.0
    v = 0.0
    u1 = 0.0
    forall (n=1:size(a,1)) u1(n,n) = 1.0
    forall (n=1:size(a,2)) v(n,n) = 1.0
    ! initial state:
    call Qr(a, q1, s)
    U = matmul(u1, q1)
    call Qr(transpose(s), q, s)
    v = matmul(v, q)
    ! iterate while converged:
    nite = 1
    do
       call Qr(transpose(s), q, s)
       u = matmul(u, q)
       call Qr(transpose(s), q, s)
       v = matmul(v, q)
       ! check the error:
       e = Triu(s)
       f = Diag(s)
       err = Norm(reshape(e, [size(e,1)*size(e,2)])) / Norm(f)
       nite = nite + 1
       if (err < EPS) exit
    end do
  end subroutine Svd

  function Diag_ele(A) result(v)
    ! Diagonal elements
    implicit none
    real(DP), dimension(:,:), intent(in) :: a
    real(DP), dimension(:), allocatable :: v
    integer :: i, n
    n = minval([size(a,1), size(a,2)])
    allocate(v(n))
    forall(i=1:n) v(i) = a(i,i)
  end function Diag_ele

  function Diag_mat(v) result(a)
    ! Diagonal matrix
    implicit none
    real(DP), dimension(:), intent(in) :: v
    real(DP), dimension(size(v), size(v)) :: a
    integer :: i
    a = 0.0
    forall(i=1:size(v)) a(i,i) = v(i)
  end function Diag_mat

  function Triu(a) result(au)
    ! Upper triangular part
    implicit none
    real(DP), dimension(:,:), intent(in) :: a
    real(DP), dimension(size(a,1), size(a,2)) :: au
    integer :: n, m, i, j
    au = 0.0
    m = size(a,1)
    n = size(a,2)
    do i = 1, m
       do j = i+1, n
          if (i+1 <= n) au(i,j) = a(i,j)
       end do
    end do
  end function Triu

  subroutine Qr(a,q,r)
    ! Modified Gram-Schmidt process
    implicit none
    real(DP), dimension(:,:), intent(in) :: a
    real(DP), dimension(size(a,1), size(a,2)), intent(out) :: q
    real(DP), dimension(size(a,2), size(a,2)), intent(out) :: r
    real(DP), dimension(size(a,1), size(a,2)) :: a0
    integer :: k,n
    n = size(a,2)
    q = 0.0
    r = 0.0
    a0 = a
    do k = 1, n
       r(k,k) = Norm(a0(:,k))
       q(:,k) = a0(:,k) / r(k,k)
       r(k,k+1:n) = matmul(q(:,k), a0(:,k+1:n))
       a0(:,k+1:n) = a0(:,k+1:n) - matmul(q(:,k:k), r(k:k,k+1:n))
    end do
  end subroutine Qr

  subroutine Levmar(Resfun, Jacfun, theta, cmat, r, rss, data)
    ! Levenberq-Marquardt optimization of "theta" parameters
    implicit none
    real(DP), dimension(:), intent(inout) :: theta
    real(DP), dimension(:,:), allocatable, intent(out) :: cmat
    real(DP), intent(out) :: rss
    type(obs), intent(in) :: data
    real(DP), dimension(data%nobs+size(theta)), intent(out) :: r
    real(DP), dimension(data%nobs+size(theta), size(theta)) :: j
    real(DP), dimension(size(theta), size(theta)) :: jj, jj_mod
    real(DP), dimension(size(theta)) :: h, jr
    real(DP) :: rssold, lam
    real(DP), parameter :: ABSTOL = 1e-6 ! convergence tolerance
    integer :: ite
    ! this kind of interface is needed when
    ! passing functions as arguments
    interface
       function Resfun(data, theta) result(r)
         use global_variables
         implicit none
         type(obs), intent(in) :: data
         real(DP), dimension(:), intent(in) :: theta
         real(DP), dimension(data%nobs) :: r
       end function Resfun
       function Jacfun(data, theta) result(j)
         use global_variables
         implicit none
         type(obs), intent(in) :: data
         real(DP), dimension(:), intent(in) :: theta
         real(DP), dimension(data%nobs, size(theta)) :: j
       end function Jacfun
    end interface
    ite = 0
    ! initial nudge factor
    lam = 1e-3
    ! initial residuals
    r = Resfun(data, theta)
    rss = sum(r**2) / (size(r) - size(theta))
    call Write_info(rss, ite, lam, .true.)
    ! iterate while converged
    do
       ite = ite + 1
       rssold = rss
       j = Jacfun(data, theta)
       jj = matmul(transpose(j), j)
       do
          jj_mod = (jj + lam*Diag(Diag(jj)))
          jr = matmul(transpose(j), r)
          h = matmul(Pinv(jj_mod), jr)
          r = Resfun(data, theta+h)
          rss = sum(r**2) / (size(r) - size(theta))
          ! increase lam until rss decreases
          if (rss >= rssold) lam = lam*10.0
          if (abs((rss-rssold)/(rss+0.1)) < abstol) exit
          if (rss < rssold) exit
       end do
       call Write_info(rss,ite,lam)
       theta = theta+h
       if (abs((rss-rssold)/(rss+0.1)) < abstol) exit
       lam = lam/10.0
    end do
    ! estimate of the error covariance at the optimum
    cmat = Pinv(jj)*rss
  end subroutine Levmar

  subroutine Write_info(rss, ite, lam, isfirst)
    ! Write some info about LM-iteration
    implicit none
    real(DP), intent(in) :: rss, lam
    integer, intent(in) :: ite
    logical, optional, intent(in) :: isfirst
    character(len=*), parameter :: FORM = '(4x,i2,4x,f12.7,4x,es8.1)'
    if (present(isfirst) .and. isfirst) then
       write(*,*) '----------------------------------'
       write(*,'(1x,a9,5x,a3,10x,a3)') 'Iteration', 'RSS', 'lam'
       write(*,*) '----------------------------------'
       write(*,FORM) ite, rss, lam
    else
       write(*,FORM) ite, rss, lam
    end if
  end subroutine Write_info

end module math


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE CONVERGENCE_TEST_VECTOR(V_APPROX, V_EXACT, O_RESULT)

        REAL*8 V_APPROX(6), V_EXACT(6)
        REAL*8 O_RESULT(2)

!       SUMMARY:
!
!       This routine computes the convergence of two vectors. It
!       accepts two inputs, the vector for which you want the result,
!       and the vector you want to compare it to. The result
!       contains the absolute and relative errors between the two vectos.
!
!       VARIABLES:
!
!       NAME             TYPE            DESCRIPTION
!
!       V_APPROX(6)      Input(REAL*8)   The vector for which you want
!                                        to calculate the error values.
!
!       V_EXACT(6)       Input(REAL*8)   The vector which that target
!                                        vector is supposed to be
!                                        compared to.
!
!       O_RESULT(2)      Output(REAL*8)  The output containing error
!                                        values. O_RESULT(1) holds the
!                                        Absolute Error, and O_RESULT(2)
!                                        hold the Relative Error.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        INTEGER I
        REAL*8 V_DIFF(3)
        REAL*8 MOD_DIFF, MOD_EXACT

        DO I=1,3
            V_DIFF(I)=V_APPROX(I)-V_EXACT(I)
          !  write(*,*) 'Vec diff', V_APPROX(I), V_EXACT(I), v_diff(i)
        END DO

        DO I=1,2
            O_RESULT(I)=0.0D0
        END DO

C
C       Get two-norm of the vector. (Modulus)
C
        CALL GET_VEC_MOD(V_DIFF, MOD_DIFF)

        CALL GET_VEC_MOD(V_EXACT, MOD_EXACT)

C
C       Calc absolute error.
C
        O_RESULT(1)= ABS(MOD_DIFF)

C
C       Calc relative error.
C
        O_RESULT(2)= ABS(MOD_DIFF/MOD_EXACT)

        RETURN
        END SUBROUTINE


! { dg-do run }
! { dg-options "-O" }
! Test the fix for PR31011 in which the length of the array sections
! with stride other than unity were incorrectly calculated.
!
! Contributed by <terry@chem.gu.se>
!
program PotentialMatrix
 implicit none
 real(kind=8),dimension(2),parameter::v2=(/1,2/)
 real(kind=8),dimension(4),parameter::v4=(/1,2,3,4/)
 if (any (v2*v4(1:3:2) .ne. (/1,6/))) call abort ()
 if (any (v2*v4(3:1:-2) .ne. (/3,2/))) call abort ()
end


      subroutine non_linear18

C     Check polynomial analysis: power is more precisely analyzed than
C     multiply!

      continue

      k = n**2 + n

      k = n**2 - n

      k = n*n + n

      k = n*n - n

      end


SUBROUTINE setprob()
    IMPLICIT NONE

    INTEGER iunit
    CHARACTER(len=25) fname

    DOUBLE PRECISION pi, pi2
    COMMON /compi/ pi, pi2

    DOUBLE PRECISION :: grav, dry_tolerance, sea_level
    COMMON /common_swe/ grav, dry_tolerance, sea_level

    DOUBLE PRECISION :: alpha, breaking
    COMMON /common_dispersive/ alpha, breaking

    DOUBLE PRECISION :: a,b,h0
    COMMON /common_initheight/ a,b,h0

    pi = 4.d0*atan(1.d0)
    pi2 = 2*pi

    iunit = 10
    fname = 'setprob.data'
    call opendatafile(iunit, fname)
    read(10,*) grav
    read(10,*) dry_tolerance
    read(10,*) sea_level

    !! Lannes method
    read(10,*) breaking
    read(10,*) alpha

    !! Initial conditions
    read(10,*) a
    read(10,*) b
    read(10,*) h0
    close(10);

end subroutine setprob


#include "Config.fpp"

module mod_trianglew_signal

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_trianglew_signal'
 !
 !          Purpose:
 !                   Triangle Wave Signal
 !                   approximated by Fourier Series.
 !
 !
 !          History:
 !                        Date: 22-08-2017
 !                        Time: 07:25 GMT+2
 !           Modified:
 !                    Bernard Gingold on: 11-03-2018, 13:13 GMT+2
 !                   1) Refactoring to Fortran 2003 standard.
 !                   2) Removing unnecessary type-bound members
 !                   3) Adding computational subroutines (additive noise)
 !                   4) Removing unnecessary destructor,copy and initialization subroutines.
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

    use module_kinds ,       only : I32P, R64P
    use mod_code_timing
    use mod_complex_arithm , only : vcmag
    use mod_jonesvec
    implicit none
    private

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_TRIANGLEW_SIGNAL_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_TRIANGLEW_SIGNAL_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_TRIANGLEW_SIGNAL_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_TRIANGLEW_SIGNAL_FULLVER = 1000*MOD_TRIANGLEW_SIGNAL_MAJOR+100*MOD_TRIANGLEW_SIGNAL_MINOR+ &
                                                                       10*MOD_TRIANGLEW_SIGNAL_MICRO

    ! Module creation date
    character(*),  parameter, public :: MOD_TRIANGLEW_SIGNAL_CREATE_DATE = "22-08-2017 07:25 +00200 (TUE 22 AUG 2017 GMT+2)"

    ! Module build date (should be set after successful compilation)
    character(*),  parameter, public :: MOD_TRIANGLEW_SIGNAL_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_TRIANGLEW_SIGNAL_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_TRIANGLEW_SIGNAL_DESCRIPT = "Fourier series approximation of triangle wave."

    !======================================================60
    !  Type: TriangleWSignal_t
    !======================================================60

    type, public :: TriangleWSignal_t

        private

        ! Signal name
        character(len=64) :: m_name

        ! Signal ID
        integer(I32P)     :: m_sid

        ! Number of signal samples
        integer(I32P)     :: m_nsamp

        ! Number of Fourier series
        integer(I32P)     :: m_maxk

        ! Signal duration
        real(R64P)        :: m_dur

        ! Triangle wave initial time (starting time-point)
        real(R64P)        :: m_sinit

        ! Triangle wave increment time-step
        real(R64P)        :: m_stsinc

        ! Triangle wave carrier frequency
        real(R64P)        :: m_freq

        ! Jones vector field
        type(JonesVector_t), allocatable, dimension(:), public :: m_jvec

        ! Sine components of k sinusoids
        real(R64P), allocatable, dimension(:,:),        public :: m_scomp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_scomp

        ! Cosine components of k sinusoids
        real(R64P), allocatable, dimension(:,:),        public :: m_ccomp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_ccomp

        ! Triangle carrier frequency (f*t)
        real(R64P), allocatable, dimension(:),          public   :: m_wct
!DIR$   ATTRIBUTES ALIGN : 64 :: m_wct

        ! Signal natural envelope
        real(R64P), allocatable, dimension(:),          public   :: m_nenvp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_nenvp

        ! Triangle wave aproximated by k
        ! sinusoids
        real(R64P), allocatable, dimension(:),          public   :: m_triangle
!DIR$   ATTRIBUTES ALIGN : 64 :: m_triangle

        ! Triangle wave complex representation
        complex(R64P), allocatable, dimension(:),       public :: m_cform
!DIR$   ATTRIBUTES ALIGN : 64 :: m_cform

         ! Electric field
        complex(R64P), allocatable, dimension(:),       public :: m_E
!DIR$   ATTRIBUTES ALIGN : 64 :: m_E

         ! Signal amplitude  A(phi,theta)/r used for calculation electric field
         ! far from emmiter(antenna)
         real(R64P), allocatable, dimension(:),         public   :: m_amp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_amp

 ! Time-averaged power density

         complex(R64P), allocatable, dimension(:),      public :: m_S
!DIR$   ATTRIBUTES ALIGN : 64 :: m_S

        contains

        ! Creates Triangle wave approximated by Fourier
        ! series.
        procedure, pass(this), public :: triangwave_signal

        ! Creates signal with noise modulated phase
        procedure, pass(this), public :: phase_noise_triangwave_signal

        ! Creates signal with noise modulated phase
        ! coupled with background additive noise.
        procedure, pass(this), public :: additive_noise_triangwave_signal

        !==========================================52
        !   Getter pure functions
        !==========================================52

        procedure, pass(this), public :: get_name

        procedure, pass(this), public :: get_sid

        procedure, pass(this), public :: get_nsamp

        procedure, pass(this), public :: get_maxk

        procedure, pass(this), public :: get_dur

        procedure, pass(this), public :: get_sinit

        procedure, pass(this), public :: get_stsinc

        procedure, pass(this), public :: get_freq

        !==================================================60
        ! Computational subroutines
        !==================================================60

        procedure, pass(this), public :: dphi_dt

        !==============================================56
        ! write/read subroutines
        !==============================================56

        procedure, nopass,     public :: read_state

        procedure, nopass,     public :: write_state

        !===============================================
        !  Class helper procedures
        !===============================================

        procedure, pass(this) , public :: dbg_info

        !===============================================
        !   Generic operators
        !===============================================
        procedure, public :: copy_assign

        generic :: assignment (=) => copy_assign

    end type TriangleWSignal_t

    interface TriangleWSignal_t
         procedure :: constructor
    end interface TriangleWSignal_t

    contains

    !======================================================60
    ! @function:  constructor
    !             default initialization (no physical meaning)
    !======================================================60
    type(TriangleWSignal_t) function constructor(name,sid,nsamp,maxk,  &
                                  verbose, logging,filename,append)

          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_PINF, LAM_MINSAMP,  &
                                       LAM_MINK
          character(len=*),         intent(in)    :: name
          integer(I32P),            intent(in)    :: sid
          integer(I32P),            intent(inout) :: nsamp,maxk
          logical(I32P),            intent(in)    :: verbose,logging
          character(len=*),         intent(in)    :: filename
          logical(I32P),            intent(in)    :: appendg
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: aerr
          ! Start of executable statements

          if(nsamp  < LAM_MINSAMP) then
              nsamp = LAM_MINSAMP
          end if
          if(maxk <  LAM_MINK) then
              maxk = LAM_MINK
          end if
          ! Begin construction
          constructor%m_name   = name
          constructor%m_sid    = sid
          constructor%m_nsamp  = nsamp
          constructor%m_maxk   = maxk
          constructor%m_dur    = LAM_PINF
          constructor%m_sinit  = LAM_PINF
          constructor%m_stsinc = LAM_PINF
          constructor%m_freq   = LAM_PINF

          associate(k=>constructor%m_maxk,            &
                    n=>constructor%m_nsamp)
              allocate(constructor%m_jvec(n),         &
                       constructor%m_scomp(k,n),      &
                       constructor%m_ccomp(k,n),      &
                       constructor%m_wct(n),          &
                       constructor%m_nenvp(n),        &
                       constructor%m_triangle(n),     &
                       constructor%m_cform(n),        &
                       constructor%m_E(n),            &
                       constructor%m_amp(n),          &
                       constructor%m_S(n),            &
                       STAT=aerr,              &
                       ERRMSG=emsg)
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,    &
                                             "logger:303 --> mod_trianglew_signal/constructor: Memory Allocation Failure!!" , &
                                             "mod_trianglew_signal/constructor:303 -- Memory Allocation Failure!!" , &
                                             emsg,__LINE__ )
          end if
          constructor%m_jvec     = JonesVector_t()
          constructor%m_scomp    = LAM_PINF
          constructor%m_ccomp    = LAM_PINF
          constructor%m_wct      = LAM_PINF
          constructor%m_nenvp    = LAM_PINF
          constructor%m_triangle = LAM_PINF
          constructor%m_cform    = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_E        = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_amp      = LAM_PINF
          constructor%m_S        = CMPLX(LAM_PINF,LAM_PINF,R64P)
   end function constructor

    !======================================================60
    !  @subroutine: triangwave_signal
    !              Physical representation of  Triangle wave
    !              approximated by K sinusoids (Fourier-
    !              series)
    !======================================================60
    subroutine triangwave_signal(this,ierr,dur, &
                                sinit,stsinc,freq,r,h,v,      &
                                verbose,logging,filename,append,      &
                                profiling,qpctimer       )
          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PI,LAM_HR64P,LAM_PINF,LAM_2PI,LAM_c,LAM_MEPS8, &
                                       LAM_dtcoeff, LAM_8OPIE2
          class(TriangleWSignal_t),    intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(inout) :: dur
          real(R64P),                  intent(in)    :: sinit,stsinc,freq
          real(R64P), dimension(:),    intent(in)    :: r
!DIR$     ASSUME_ALIGNED r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUMED_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: verbose,logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: i,j,k,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail,invalid
          real(R64P)         :: insamp,t,t2,delta
          real(R64P), allocatable, dimension(:) :: tcos,ts,tc
!DIR$     ATTRIBUTES ALIGN : 64 :: tcos
!DIR$     ATTRIBUTES ALIGN : 64 :: ts
!DIR$     ATTRIBUTES ALIGN : 64 :: tc
          ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
          ! Check if stsinc value lies in interval 1/2^-1 -> 1/2^-16
          invalid = .false.
          do i = 1, 16
              if(DABS(stsinc)-DABS(LAM_dtcoeff(i)) > LAM_MEPS8) then
                   invalid = .true.
              end if
          end do
          if(invalid == .true.) then
              ierr = -2_I32P
              return
          end if
          if(dur.LE.LAM_ZR8) then
               ierr = -1_I32P
               return
          end if
          this%m_dur    =  dur
          this%m_sinit  = sinit
          this%m_stsinc = stsinc
          this%m_freq   = freq
          associate(n=>this%m_nsamp)
              allocate(  tcos(n),                &
                         ts(n),                  &
                         tc(n),                  &
                         STAT=aerr,              &
                         ERRMSG=emsg)
          end associate
         if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,  &
                                             "logger:388 --> mod_trianglew_signal/triangwave_signal: Memory allocation failure!!" , &
                                             "mod_trianglew_signal/triangwave_signal:388 -- Memory Allocation Failure!" ,  &
                                             emsg,__LINE__ )
          end if
          tcos = LAM_PINF
          ts   = LAM_PINF
          tc   = LAM_PINF

          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail.EQ.0) then
                  write(stderr,*) "mod_trianglew_signal/triangewave_signal: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
          ! Create Jones vector field.
          do i = 1_I32P, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
          ! Create sine and cosine Fourier series components

          insamp = 1._R64P/DBLE(this%m_nsamp)
          k = 0_I32P
          do i = 1_I32P, this%m_maxk
                 k = k+1
                 do j = 1_I32P, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*t)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*t)/((2*k+1)*(2*k+1))
                 end do
          end do
           ! Do summation over the rows
          this%m_triangle =  SUM(this%m_scomp,dim=2)
          tcos            =  SUM(this%m_ccomp,dim=2)
          ! Create sawtooth signal (final approximation) and
          ! create signal complex representation
          do j = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(j)*insamp
              t = this%m_sinit*delta
              this%m_wct(j) = t
              this%m_triangle(j) = LAM_8OPIE2*this%m_triangle(j)
              tcos(j)            = LAM_8OPIE2*tcos(j)
              this%m_cform(j) = DCMPLX(tcos(j),this%m_triangle(j))
          end do
           ! Compute natural envelope
          call vcmag(this%m_cform,this%m_nenvp)
             ! Create electrical field far from the emitter.
          k = 0_I32P
          do i = 1_I32P, this%m_maxk
                 k = k+1
                 do j = 1_I32P, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     t2 = t-r(j)/LAM_c
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*t2)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*t2)/((2*k+1)*(2*k+1))
                 end do
          end do
           ! Do summation over the rows
          tc = SUM(this%m_ccomp,dim=2)
          ts = SUM(this%m_scomp,dim=2)
          do j = 1_I32P, this%m_nsamp
              tc(j) = LAM_8OPIE2*tc(j)
              ts(j) = LAM_8OPIE2*ts(j)
              this%m_E(j) = DCMPLX(tc(j),ts(j))
          end do
            ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
            ! Compute time-average power density i.e. 0.5xExE*/n
          do j = 1_I32P, this%m_nsamp
              this%m_S(j) = LAM_HR64P*this%m_E(j)*DCONJG(this%m_E(j))*0.0026525198938992_R64P
          end do
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail .EQ. .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_trianglew_signal/triangwave_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_trianglew_signal/triangwave_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
     end subroutine  triangwave_signal

    !======================================================60
    !  @subroutine: phase_noise_signal
    !              Physical representation of  Triangle wave
    !              approximated by K sinusoids (Fourier-
    !              series)
    !              This signal is corrupted by phase additive
    !              noise.
    !======================================================60
    subroutine phase_noise_triangwave_signal(this,ierr, dur,  &
                                  sinit,stsinc,freq,noise,r,h,v, &
                                  verbose,logging,filename,append,   &
                                  profiling,qpctimer     )
          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PI,LAM_HR64P,LAM_PINF,LAM_2PI,LAM_c,LAM_MEPS8, &
                                       LAM_dtcoeff, LAM_8OPIE2
          class(TriangleWSignal_t),    intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(in)    :: dur
          real(R64P),                  intent(in)    :: sinit,stsinc,freq
          real(R64P), dimension(:),    intent(in)    :: noise,r
!DIR$     ASSUME_ALIGNED noise:64,r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: verbose,logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: i,j,k,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail,invalid
          real(R64P)         :: insamp,t,t2,delta,tn
          real(R64P), allocatable, dimension(:) :: tcos,ts,tc
!DIR$     ATTRIBUTES ALIGN : 64 :: tcos
!DIR$     ATTRIBUTES ALIGN : 64 :: ts
!DIR$     ATTRIBUTES ALIGN : 64 :: tc
          ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
           ! Check if stsinc value lies in interval 1/2^-1 -> 1/2^-16
          invalid = .false.
          do i = 1, 16
              if(DABS(stsinc)-DABS(LAM_dtcoeff(i)) > LAM_MEPS8) then
                   invalid = .true.
              end if
          end do
          if(invalid == .true.) then
              if(logging) then
                 ierr = -2_I32P
              return
          end if

          if(dur <= LAM_ZR8) then
             ierr = -1_I32P
            return
          end if
          this%m_dur    =  dur
          this%m_sinit  = sinit
          this%m_stsinc = stsinc
          this%m_freq   = freq
          associate(n=>this%m_nsamp)
              allocate( tcos(n),                &
                       ts(n),                  &
                       tc(n),                  &
                       STAT=aerr,              &
                       ERRMSG=emsg)

          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:553 --> mod_trianglew_signal/phase_noise_triangwave_signal: Memory Allocation Failure!!" , &
                                             "mod_trianglew_signal/phase_noise_triangwave_signal:553 -- Memory Allocation Failure!" , &
                                             emsg,__LINE__ )
          end if
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_trianglew_signal/phase_noise_striangwave_signal: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
           ! Create Jones vector field.
          do i = 1_I32P, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
          ! Create sine and cosine Fourier series components
            insamp = 1._R64P/DBLE(this%m_nsamp)
          k = 0
          do i = 1_I32P, this%m_maxk
                 k = k+1
                 do j = 1_I32P, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     tn = t + noise(j)
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                 end do
          end do
             ! Do summation over the rows
          this%m_triangle =  SUM(this%m_scomp,dim=2)
          tcos            =  SUM(this%m_ccomp,dim=2)
          ! Create sawtooth signal (final approximation) and
          ! create signal complex representation
          do j = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(j)*insamp
              t = this%m_sinit*delta
              t2 = t + noise(j)
              this%m_wct(j) = t2
              this%m_triangle(j) = LAM_8OPIE2*this%m_triangle(j)
              tcos(j)            = LAM_8OPIE2*tcos(j)
              this%m_cform(j) = DCMPLX(tcos(j),this%m_triangle(j))
          end do
            ! Compute natural envelope
          call vcmag(this%m_cform,this%m_nenvp)
             ! Create electrical field far from the emitter.
          k = 0_I32P
          do i = 1_I32P, this%m_maxk
                 k = k+1
                 do j = 1_I32P, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     t2 = t-r(j)/LAM_c
                     tn = t2 + noise(j)
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                 end do
          end do
           ! Do summation over the rows
          tc = SUM(this%m_ccomp,dim=2)
          ts = SUM(this%m_scomp,dim=2)
          do j = 1_I32P, this%m_nsamp
              tc(j) = LAM_8OPIE2*tc(j)
              ts(j) = LAM_8OPIE2*ts(j)
              this%m_E(j) = DCMPLX(tc(j),ts(j))
          end do
            ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
            ! Compute time-average power density i.e. 0.5xExE*/n
          do j = 1_I32P, this%m_nsamp
              this%m_S(j) = LAM_HR64P*this%m_E(j)*DCONJG(this%m_E(j))*0.0026525198938992_R64P
          end do
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_trianglew_signal/phase_noise_triangwave_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_trianglew_signal/phase_noise_triangwave_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
   end subroutine phase_noise_triangwave_signal

    !======================================================60
    !  @subroutine: additive_noise_triangwave_signal
    !              Physical representation of  Triangle wave
    !              approximated by K sinusoids (Fourier-
    !              series)
    !              This signal is corrupted by phase additive
    !              noise and by background additive noise.
    !======================================================60
    subroutine additive_noise_triangwave_signal(this,ierr,dur ,    &
                                     sinit,stsinc,freq,phnoise,bnoise, &
                                     r,h,v,verbose,logging,filename,append,    &
                                     profiling,qpctimer            )

          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PI,LAM_HR64P,LAM_PINF,LAM_2PI,LAM_c,LAM_MEPS8, &
                                       LAM_dtcoeff, LAM_8OPIE2
          class(TriangleWSignal_t),    intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(in)    :: dur,sinit,stsinc,freq
          real(R64P), dimension(:),    intent(in)    :: phnoise,bnoise,r
!DIR$     ASSUME_ALIGNED phnoise:64,bnoise:64,r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: verbose,logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: i,j,k,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail,invalid
          real(R64P)         :: insamp,t,t2,delta,tn
          real(R64P), allocatable, dimension(:) :: tcos,ts,tc
!DIR$     ATTRIBUTES ALIGN : 64 :: tcos
!DIR$     ATTRIBUTES ALIGN : 64 :: ts
!DIR$     ATTRIBUTES ALIGN : 64 :: tc
           ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
           ! Check if stsinc value lies in interval 1/2^-1 -> 1/2^-16
          invalid = .false.
          do i = 1, 16
              if(DABS(stsinc)-DABS(LAM_dtcoeff(i)).GT.LAM_MEPS8) then
                   invalid = .true.
              end if
          end do
          if(invalid) then
              ierr = -2_I32P
              return
          end if

          if(dur.LE.LAM_ZR8) then
             ierr = -1_I32P
            return
          end if
          this%m_dur    =  dur
          this%m_sinit  = sinit
          this%m_stsinc = stsinc
          this%m_freq   = freq
          associate(n=>this%m_nsamp)
              allocate( tcos(n),                &
                        ts(n),                  &
                        tc(n),                  &
                        STAT=aerr,              &
                        ERRMSG=emsg)
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:721 --> mod_trianglew_signal/additive_noise_triangwave_signal: Memory allocation failure!!" , &
                                             "mod_trianglew_signal/additive_noise_triangwave_signal:721 -- Memory Allocation Failure!", &
                                             emag,__LINE__ )
          end if
          tcos = LAM_PINF
          ts   = LAM_PINF
          tc   = LAM_PINF
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_trianglew_signal/additive_noise_triangwave_signal: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
            ! Create Jones vector field.
          do i = 1, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
          ! Create sine and cosine Fourier series components

          insamp = 1._R64P/DBLE(this%m_nsamp)
          k = 0
          do i = 1, this%m_maxk
                 k = k+1
                 do j = 1, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     tn = t + phnoise(j)
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_scomp(i,j) = bnoise(j)+this%m_scomp(i,j)
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = bnoise(j)+this%m_ccomp(i,j)
                 end do
          end do
                ! Do summation over the rows
          this%m_triangle =  SUM(this%m_scomp,dim=2)
          tcos            =  SUM(this%m_ccomp,dim=2)
          ! Create sawtooth signal (final approximation) and
          ! create signal complex representation
          do j = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(j)*insamp
              t = this%m_sinit*delta
              t2 = t + noise(j)
              this%m_wct(j) = t2
              this%m_triangle(j) = LAM_8OPIE2*this%m_triangle(j)
              tcos(j)            = LAM_8OPIE2*tcos(j)
              this%m_cform(j) = DCMPLX(tcos(j),this%m_triangle(j))
          end do
           ! Compute natural envelope
          call vcmag(this%m_cform,this%m_nenvp)
             ! Create electrical field far from the emitter.
          k = 0_I32P
            do i = 1_I32P, this%m_maxk
                 k = k+1
                 do j = 1_I32P, this%m_nsamp
                     this%m_sinit = this%m_sinit+this%m_stsinc
                     delta = DBLE(j)*insamp
                     t = this%m_sinit*delta
                     t2 = t-r(j)/LAM_c
                     tn = t2 + noise(j)
                     this%m_scomp(i,j) = -1**k*DSIN(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_scomp(i,j) = bnoise(j)+this%m_scomp(i,j)
                     this%m_ccomp(i,j) = -1**k*DCOS(LAM_2PI*(2*k+1)*this%m_freq*tn)/((2*k+1)*(2*k+1))
                     this%m_ccomp(i,j) = bnoise(j)+this%m_ccomp(i,j)
                 end do
          end do
              ! Do summation over the rows
          tc = SUM(this%m_ccomp,dim=2)
          ts = SUM(this%m_scomp,dim=2)
          do j = 1_I32P, this%m_nsamp
              tc(j) = LAM_8OPIE2*tc(j)
              ts(j) = LAM_8OPIE2*ts(j)
              this%m_E(j) = DCMPLX(tc(j),ts(j))
          end do
             ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
            ! Compute time-average power density i.e. 0.5xExE*/n
          do j = 1_I32P, this%m_nsamp
              this%m_S(j) = LAM_HR64P*this%m_E(j)*DCONJG(this%m_E(j))*0.0026525198938992_R64P
          end do
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail .EQ. .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_trianglew_signal/additive_noise_triangwave_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_trianglew_signal/additive_noise_triangwave_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine  additive_noise_triangwave_signal

    !======================================================60
    !  Getter pure functions
    !======================================================60

    pure function get_name(this) result(name)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          character(len=64) :: name
          ! Start of executable statements
          name = this%m_name
    end function

    pure function get_sid(this) result(sid)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: sid
          ! Start of executable statements
          sid = this%m_sid
    end function

    pure function get_nsamp(this) result(nsamp)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nsamp
          ! Start of executable statements
          nsamp = this%m_nsamp
    end function

    pure function get_maxk(this) result(maxk)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: maxk
          ! Start of executable statements
          maxk = this%m_maxk
    end function

    pure function get_dur(this) result(dur)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: dur
          ! Start of executable satements
          dur = this%m_dur
    end function

    pure function get_sinit(this) result(sinit)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: sinit
          ! Start of executable satatements
          sinit = this%m_sinit
    end function

    pure function get_stsinc(this) result(stsinc)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: stsinc
          ! Start of executable statements
          stsinc = this%m_stsinc
    end function

    pure function get_freq(this) result(freq)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: freq
          ! Start of executable sattaements
          freq = this%m_freq
    end function

     !======================================================60
    !    Computational procedures
    !======================================================60
    ! TODO:
    !        ! Consider using CADNA to test for cancellation errors
    subroutine dphi_dt(this,dphi,sfac)
          use mod_constants,  only : LAM_IZER8, LAM_MEPS8
          class(TriangleWSignal_t),  intent(in)     :: this
          real(R64P), dimension(:),  intent(out)    :: dphi
!DIR$     ASSUME_ALIGNED dphi:32
          integer(I64P),            intent(inout)  :: sfac
          ! Locals
          integer(I32P) :: i
          real(R64P)    :: eps,isfac,tmp
          ! Start of executable sttements
          if(sfac.LE.LAM_IZER8) then
              sfac =  1000000000000000_I64P
          end if
          isfac = 1._R64P/DBLE(sfac)
          eps = LAM_MEPS8**0.3333333333333333333333333333_R64P
          do i = 2, this%m_nsamp-1
              tmp = this%m_wct(i+1)-this%m_wct(i-1)
              dphi(i) = this%m_wct(i+1)-this%m_wct(i-1) / &
                        (2._R64P*eps*DMAX1(DABS(tmp),isfac)*DSIGN(tmp,tmp))
          end do
    end subroutine

    !============================================
    !   Read/write procedures
    !============================================
    subroutine read_state(this,form,unit,ioerr)

          class(TriangleWSignal_t), intent(in) :: this
          character(len=*),     intent(in) :: form
          integer(I32P),        intent(in) :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(TriangleWSignal_t), intent(in) :: this
          character(len=*),     intent(in) :: form
          integer(I32P),        intent(in) :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine write_state

    !======================================================60
    !  subroutine: to_screenu
    !======================================================60
    subroutine dbg_info(this,verbose)
          implicit none
          class(TriangleWSignal_t), intent(in) :: this
          logical(I32P),            intent(in) :: verbose
          ! Locals
          ! Start of executable statements
          call DATE_AND_TIME(date=dstr,time=tstr)
          print*, "======================================================"
          print*, "   ***Printing components of TriangleWSignal_t***"
          print*, "   printing subroutine called at: " , &
                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                     stime(1:2),":",stime(3:4),":",stime(5:6)
          print*, "           Dumping scalar components "
          print*, "======================================================"
          print*, "Name:               ", this%m_name
          print*, "Signal ID:          ", this%m_sid
          print*, "Number of samples:  ", this%m_nsamp
          print*, "Maximum 'k':        ", this%m_maxk
          print*, "Signal duration:    ", this%m_dur
          print*, "scalar amplitude:   ", this%m_A
          print*, "Initial time-point: ", this%m_sinit
          print*, "Time-step increment:", this%m_stsinc
          print*, "Carrier frequency:  ", this%m_freq
          print*, "           Dumping array components  "
          print*, "======================================================"

          if(verbose) then
              print*, "Sine series components:  ", this%m_scomp
              print*, "Cosine series components:", this%m_ccomp
          end if
          print*, "Signal polarization:  ",   this%m_jvec
          print*, "Time (t):             ",   this%m_wct
          print*, "Natural Envelope:     ",   this%m_nenvp
          print*, "Triangle time-domain: ",   this%m_triangle
          print*, "Complex form:         ",   this%m_cform
          print*, "Electric field:       ",   this%m_E
          print*, "Amplitude:            ",   this%m_amp
          print*, "Time-average power:   ",   this%m_S
          print*, "====================================================="
    end subroutine dbg_info

     !======================================================60
    !  subroutine: copy_assign
    !              Overloaded assignment (=)
    !======================================================60
    subroutine copy_assign(lhs,rhs)
          class(TriangleWSignal_t),  intent(inout) :: lhs
          class(TriangleWSignal_t),  intent(in)    :: rhs
          ! Start of executable statements.
          lhs%m_name     = rhs%m_name
          lhs%m_sid      = rhs%m_sid
          lhs%m_nsamp    = rhs%m_nsamp
          lhs%m_maxk     = rhs%m_maxk
          lhs%m_dur      = rhs%m_dur
          lhs%m_A        = rhs%m_A
          lhs%m_sinit    = rhs%m_sinit
          lhs%m_stsinc   = lhs%m_stsinc
          lhs%m_freq     = rhs%m_freq
          lhs%m_jvec     = rhs%m_jvec
          lhs%m_scomp    = rhs%m_scomp
          lhs%m_ccomp    = rhs%m_ccomp
          lhs%m_wct      = rhs%m_wct
          lhs%m_nenvp    = rhs%m_nenvp
          lhs%m_triangle = rhs%m_triangle
          lhs%m_cform    = rhs%m_cform
          lhs%m_E        = rhs%m_E
          lhs%m_amp      = rhs%m_amp
          lhs%m_S        = rhs%m_S
    end subroutine copy_assign

end module mod_trianglew_signal


program test_interp1
!! Need program statement for FORD
use phys_consts, only: wp,pi
use interpolation

implicit none (type, external)

integer, parameter :: lx1=25, lx2=50
integer, parameter :: lx1i=200, lx2i=400
real(wp), parameter :: stride=0.5_wp

integer :: ix1,ix2

real(wp), allocatable, dimension(:) :: x1, x2, x1i, x2i
real(wp), allocatable, dimension(:,:) :: f, fi  !< since only doing x1 interpolation

allocate(x1(lx1), x2(lx2), f(lx1,lx2), x1i(lx1i), x2i(lx2i), fi(lx1i,lx2i))

!grid for original data
x1=[ ((real(ix1,wp)-1._wp)*stride, ix1=1,lx1) ]
x2=[ ((real(ix2,wp)-1._wp)*stride, ix2=1,lx2) ]

!test function
do ix2=1,lx2
  f(:,ix2)=sin(2._wp*pi/5._wp*x1)*cos(2._wp*pi/5._wp*x2(ix2))
end do

!grid for interpolated data
x1i=[ ((real(ix1,wp)-1._wp)*stride/(lx1i/lx1), ix1=1,lx1i) ]
x2i=[ ((real(ix2,wp)-1._wp)*stride/(lx2i/lx2), ix2=1,lx2i) ]

!try a 1d interpolation for each x2 value used in simulation
do ix2=1,lx2
  fi(:,ix2)=interp1(x1,f(:,ix2),x1i)
end do

!dump results to a file so we can check things
block
  integer :: u
  open(newunit=u,file='input1D.dat',status='replace',form='unformatted',access='stream', action='write')
  write(u) lx1,lx2
  write(u) x1,x2,f
  close(u)
end block

block
  integer :: u
  open(newunit=u,file='output1D.dat',status='replace',form='unformatted',access='stream', action='write')
  write(u) lx1i,lx2
  write(u) x1i,x2,fi   !since only interpolating in x1
  close(u)
end block

end program


*###[ ffxli2:
	subroutine ffxli2(xdilog,xlog,x,ier)
***#[*comment:***********************************************************
*									*
*	Computes the dilogarithm (Li2, Sp) for (real) x	to precision	*
*	precx. It is assumed that -1<=x<=1/2.  As it is available anyway*
*	log(1-x) = -Li1(x) is also passed.				*
*									*
*	Input:	x	(real)						*
*									*
*	Output: xdilog	(real)    Li2(x)				*
*		xlog	(real)    log(1-x) = -Li1(x)			*
*		ier	(integer) 0=OK, 1=num prob, 2=error		*
*									*
*	Calls:	log,dfflo1						*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xdilog,xlog,x
*
*	local variables
*
	integer ipi12
	DOUBLE PRECISION dfflo1,u,u2,a,ffbnd,
     +		xprec,bdn02,bdn05,bdn10,bdn15
	DOUBLE COMPLEX zxdilo,zlog
	external ffbnd,dfflo1
	save xprec,bdn02,bdn05,bdn10,bdn15
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ initialisations:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	endif
*  #] initialisations:
*  #[ if the argument is too large...
	if ( x .lt. -1.5 .or. x .gt. .75 ) then
	    call ffzxdl(zxdilo,ipi12,zlog,x,0,ier)
	    if ( DIMAG(zxdilo) .ne. 0 ) then
	    	call fferr(52,ier)
	    endif
	    xdilog = DBLE(zxdilo) + ipi12*pi12
	    xlog = DBLE(zlog)
	    return
	endif
*  #] if the argument is too large...
*  #[ exceptional cases:
	if ( x .eq. -1 ) then
	    xdilog = -pi12
	    xlog = log(2D0)
	    return
	elseif ( x .eq. .5D0 ) then
	    xdilog = - xlg2**2/2 + pi12
	    xlog = - xlg2
	    return
	elseif ( abs(x) .lt. precx ) then
	    xdilog = x
	    xlog = -x
	    return
	endif
*  #] exceptional cases:
*  #[ calculate dilog:
	if ( abs(x) .lt. xloss ) then
	    xlog = dfflo1(x,ier)
	else
	    xlog = log(1-x)
	endif
	u = -xlog
	u2 = u*u
	a = abs(u2)
	if ( a .gt. bdn15 ) then
	    xdilog = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
     +		    u2*(bf(19) + u2*bf(20) ))))
	else
	    xdilog = 0
	endif
	if ( a .gt. bdn10 ) then
	    xdilog = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
     +		    u2*(bf(14) + u2*(bf(15) + xdilog)))))
	endif
	if ( a .gt. bdn05 ) then
	    xdilog = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
     +		    u2*(bf(9) + u2*(bf(10) + xdilog)))))
	endif
	if ( a .gt. bdn02 ) then
	    xdilog = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilog)))
	endif
*	watch the powers of u.
	xdilog = u + u2*(bf(1) + u*(bf(2) + xdilog))
*  #] calculate dilog:
*###] ffxli2:
	end

*###[ ffzxdl:
	subroutine ffzxdl(zxdilo,ipi12,zlog,x,ieps,ier)
***#[*comment:***************************************************
*	Computes the dilogarithm (Li2, Sp) for any (real) x	*
*	to precision precx. If an error message is given add	*
*	more bf's. For x > 1 the imaginary part is		*
*	 -/+i*pi*log(x), corresponding to x+ieps.		*
*	The number of factors pi^2/12 is passed separately in	*
*	ipi12 for accuracy.  We also calculate log(1-x)		*
*	which is likely to be needed.				*
*								*
*	Input:	x	(real)					*
*		ieps	(integer,+/-1)				*
*								*
*	Output: zxdilo	(complex) the dilog mod factors pi2/12	*
*		ipi12	(integer) these factors			*
*		zlog	(complex) log(1-x)			*
*								*
*	Calls:	log,dfflo1					*
*								*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ipi12,ieps,ier
	DOUBLE PRECISION x
	DOUBLE COMPLEX zxdilo,zlog
*
*	local variables
*
	integer jsgn
	DOUBLE PRECISION fact,u,u2,dfflo1,ffbnd,a,xdilo,
     +		xprec,bdn02,bdn05,bdn10,bdn15
	DOUBLE COMPLEX cy,cfact
	external ffbnd,dfflo1
	save xprec,bdn02,bdn05,bdn10,bdn15
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ initialisations:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	endif
*  #] initialisations:
*  #[ exceptional cases:
	if ( x .eq. 1) then
	    zxdilo = 0
	    zlog = -99999
	    ipi12 = 2
	    return
	elseif (x .eq. -1) then
	    zxdilo = 0
	    zlog = xlg2
	    ipi12 = -1
	    return
	elseif (x .eq. .5D0) then
	    zxdilo = - xlg2**2/2
	    zlog = -xlg2
	    ipi12 = 1
	    return
	elseif ( abs(x) .lt. precx ) then
	    zxdilo = x
	    zlog = -x
	    ipi12 = 0
	    return
	endif
*  #] exceptional cases:
*  #[ transform to (-1,.5):
	if (x .lt. -1) then
	    fact = log(-x)
	    cy = - fact**2/2
	    ipi12 = -2
	    if ( -x*xloss .gt. 1 ) then
		u = -dfflo1(1/x,ier)
	    else
		u = -log(1-1/x)
	    endif
	    zlog = log(1-x)
	    jsgn = -1
	elseif ( x .lt. .5D0) then
	    cy = 0
	    ipi12 = 0
	    if ( abs(x) .lt. xloss ) then
		zlog = dfflo1(x,ier)
	    else
		zlog = log(1-x)
	    endif
	    u = -DBLE(zlog)
	    jsgn = 1
	elseif ( x .le. 2 ) then
	    u = -log(x)
	    if ( abs(1-x) .lt. xalogm ) then
		cy = 0
	    elseif ( x .lt. 1 ) then
		zlog = log(1-x)
		cy = DBLE(u)*zlog
	    elseif ( ieps .gt. 0 ) then
		zlog = DCMPLX(log(x-1),-pi)
		cy = DBLE(u)*zlog
	    else
		zlog = DCMPLX(log(x-1),+pi)
		cy = DBLE(u)*zlog
	    endif
	    ipi12 = 2
	    jsgn = -1
	else
	    if ( ieps .gt. 0 ) then
		cfact = DCMPLX(log(x),-pi)
		zlog = DCMPLX(log(x-1),-pi)
	    else
		cfact = DCMPLX(log(x),+pi)
		zlog = DCMPLX(log(x-1),+pi)
	    endif
	    cy = - cfact**2/2
	    ipi12 = -2
	    if ( x*xloss .gt. 1 ) then
		u = -dfflo1(1/x,ier)
	    else
		u = -log(1-1/x)
	    endif
	    jsgn = -1
	endif
*  #] transform to (-1,.5):
*  #[ calculate dilog:
	if ( abs(u) .lt. xalog2 ) then
	    xdilo = u
	else
	u2 = u**2
	a = abs(u2)
	if ( a .gt. bdn15 ) then
	    xdilo = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
     +		    u2*(bf(19) + u2*bf(20) ))))
	else
	    xdilo = 0
	endif
	if ( a .gt. bdn10 ) then
	    xdilo = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
     +		    u2*(bf(14) + u2*(bf(15) + xdilo)))))
	endif
	if ( a .gt. bdn05 ) then
	    xdilo = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
     +		    u2*(bf(9) + u2*(bf(10) + xdilo)))))
	endif
	if ( a .gt. bdn02 ) then
	    xdilo = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilo)))
	endif
*	watch the powers of u.
	xdilo = u + u2*(bf(1) + u*(bf(2) + xdilo))
	endif
	if(jsgn.eq.1)then
	    zxdilo =  DBLE(xdilo) + cy
	else
	    zxdilo = -DBLE(xdilo) + cy
	endif
*  #] calculate dilog:
*###] ffzxdl:
	end

*###[ zxfflg:
	DOUBLE COMPLEX function zxfflg(x,ieps,y,ier)
***#[*comment:***********************************************************
*									*
*	Calculate the complex logarithm of x.  The following cases	*
*	are treted separately:						*
*		|x| too small:		give warning and return 0	*
*					(for Absoft, Apollo DN300)	*
*		|x| < 0:		take sign according to ieps	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
*
*	arguments
*
	implicit none
	integer ieps,ier
	DOUBLE PRECISION x,y
*
*	local variables
*
	DOUBLE PRECISION xlog
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ calculations:
	if ( abs(x) .lt. xalogm ) then
	    zxfflg = 0
	elseif ( x .gt. 0 ) then
	    zxfflg = log(x)
	else
	    xlog = log(-x)
*	    checked imaginary parts 19-May-1988
	    if ( abs(ieps) .eq. 1 ) then
		if ( y*ieps .lt. 0 ) then
		    zxfflg = DCMPLX(xlog,-pi)
		else
		    zxfflg = DCMPLX(xlog,pi)
		endif
	    elseif ( ieps .eq. 2 ) then
		zxfflg = DCMPLX(xlog,-pi)
	    elseif ( ieps .eq. -2 ) then
		zxfflg = DCMPLX(xlog,+pi)
	    else
		call fferr(52,ier)
		zxfflg = DCMPLX(xlog,pi)
	    endif
	endif
*  #] calculations:
*###] zxfflg:
	end

*###[ dfflo1:
	DOUBLE PRECISION function dfflo1(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x) for |x|<.14 in a faster way to ~15	*
*	significant figures.					*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn19,xprec,
     +		xa,ffbnd
	DOUBLE COMPLEX zxfflg
	external ffbnd,zxfflg
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv)
	    bdn05 = ffbnd(1,5,xninv)
	    bdn10 = ffbnd(1,10,xninv)
	    bdn15 = ffbnd(1,15,xninv)
	    bdn19 = ffbnd(1,19,xninv)
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn19 ) then
	    dfflo1 = DBLE(zxfflg(1-x,0,0D0,ier))
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    dfflo1 = x*( xninv(16) + x*( xninv(17) + x*( xninv(18) +
     +		x*( xninv(19) + x*xninv(20) ))))
	else
	    dfflo1 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo1 = x*( xninv(11) + x*( xninv(12) + x*( xninv(13) +
     +		x*( xninv(14) + x*( xninv(15) + dfflo1 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo1 = x*( xninv(6) + x*( xninv(7) + x*( xninv(8) +
     +		x*( xninv(9) + x*( xninv(10) + dfflo1 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo1 = x*( xninv(2) + x*( xninv(3) + x*( xninv(4) +
     +		x*( xninv(5) + dfflo1 ))))
	endif
	dfflo1 = - x*( xninv(1) + dfflo1 )
*  #] calculations:
*###] dfflo1:
	end

*###[ dfflo2:
	DOUBLE PRECISION function dfflo2(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x for |x|<.14 in a faster way to	*
*	~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn18,xprec,
     +		xa,ffbnd,dfflo1
	external ffbnd,dfflo1
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(2))
	    bdn05 = ffbnd(1,5,xninv(2))
	    bdn10 = ffbnd(1,10,xninv(2))
	    bdn15 = ffbnd(1,15,xninv(2))
	    bdn18 = ffbnd(1,18,xninv(2))
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn18 ) then
	    dfflo2 = dfflo1(x,ier) + x
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    dfflo2 = x*( xninv(17) + x*( xninv(18) + x*( xninv(19) +
     +		x*xninv(20) )))
	else
	    dfflo2 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo2 = x*( xninv(12) + x*( xninv(13) + x*( xninv(14) +
     +		x*( xninv(15) + x*( xninv(16) + dfflo2 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo2 = x*( xninv(7) + x*( xninv(8) + x*( xninv(9) +
     +		x*( xninv(10) + x*( xninv(11) + dfflo2 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo2 = x*( xninv(3) + x*( xninv(4) + x*( xninv(5) +
     +		x*( xninv(6) + dfflo2 ))))
	endif
	dfflo2 = - x**2*( xninv(2) + dfflo2 )
*  #] calculations:
*###] dfflo2:
	end

*###[ dfflo3:
	DOUBLE PRECISION function dfflo3(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster 	*
*	way to ~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,xprec,
     +		xa,ffbnd,dfflo2
	external ffbnd,dfflo2
	save xprec,bdn01,bdn05,bdn10,bdn15
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(3))
	    bdn05 = ffbnd(1,5,xninv(3))
	    bdn10 = ffbnd(1,10,xninv(3))
	    bdn15 = ffbnd(1,15,xninv(3))
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn15 ) then
	    dfflo3 = dfflo2(x,ier) + x**2/2
	    return
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo3 = x*( xninv(13) + x*( xninv(14) + x*( xninv(15) +
     +		x*( xninv(16) + x*xninv(17) ))))
	else
	    dfflo3 = 0
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo3 = x*( xninv(8) + x*( xninv(9) + x*( xninv(10) +
     +		x*( xninv(11) + x*( xninv(12) + dfflo3 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo3 = x*( xninv(4) + x*( xninv(5) + x*( xninv(6) +
     +		x*( xninv(7) + dfflo3 ))))
	endif
	dfflo3 = - x**3*( xninv(3) + dfflo3 )
*  #] calculations:
*###] dfflo3:
	end

*###[ ffxl22:
	subroutine ffxl22(xl22,x,ier)
***#[*comment:***************************************************
*	calculates Li2(2-x) for |x|<.14 in a faster way to ~15	*
*	significant figures.					*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,init
	DOUBLE PRECISION xl22,x,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,
     +		xprec,xa,ffbnd,dilog2(29)
	external ffbnd
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,init,dilog2
	include 'ff.h'
	data xprec /-1D0/
	data init /0/
	if ( init .eq. 0 ) then
	    init = 1
* taylor(dilog(x-1),x,30);
	    dilog2( 1) = 0.d0
	    dilog2( 2) = 1/4.d0
	    dilog2( 3) = 1/6.d0
	    dilog2( 4) = 5/48.d0
	    dilog2( 5) = 1/15.d0
	    dilog2( 6) = 2/45.d0
	    dilog2( 7) = 13/420.d0
	    dilog2( 8) = 151/6720.d0
	    dilog2( 9) = 16/945.d0
	    dilog2(10) = 83/6300.d0
	    dilog2(11) = 73/6930.d0
	    dilog2(12) = 1433/166320.d0
	    dilog2(13) = 647/90090.d0
	    dilog2(14) = 15341/2522520.d0
	    dilog2(15) = 28211/5405400.d0
	    dilog2(16) = 10447/2306304.d0
	    dilog2(17) = 608/153153.d0
	    dilog2(18) = 19345/5513508.d0
	    dilog2(19) = 18181/5819814.d0
	    dilog2(20) = 130349/46558512.d0
	    dilog2(21) = 771079/305540235.d0
	    dilog2(22) = 731957/320089770.d0
	    dilog2(23) = 2786599/1338557220.d0
	    dilog2(24) = 122289917/64250746560.d0
	    dilog2(25) = 14614772/8365982625.d0
	    dilog2(26) = 140001721/87006219300.d0
	    dilog2(27) = 134354573/90352612350.d0
	    dilog2(28) = 774885169/562194032400.d0
	    dilog2(29) = 745984697/582272390700.d0
	endif
*  #] declarations:
*  #[ initialisation:
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15,20 terms
	    bdn01 = ffbnd(2,1,dilog2)
	    bdn05 = ffbnd(2,5,dilog2)
	    bdn10 = ffbnd(2,10,dilog2)
	    bdn15 = ffbnd(2,15,dilog2)
	    bdn20 = ffbnd(2,20,dilog2)
	    bdn25 = ffbnd(2,25,dilog2)
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn25 ) then
	    call ffwarn(230,ier,precx,dilog2(27)*xa**25)
	endif
	if ( xa .gt. bdn20 ) then
	    xl22 = x*( dilog2(22) + x*( dilog2(23) + x*( dilog2(24) +
     +		x*( dilog2(25) + x*dilog2(26) ))))
	else
	    xl22 = 0
	endif
	if ( xa .gt. bdn15 ) then
	    xl22 = x*( dilog2(17) + x*( dilog2(18) + x*( dilog2(19) +
     +		x*( dilog2(20) + x*dilog2(21) ))))
	endif
	if ( xa .gt. bdn10 ) then
	    xl22 = x*( dilog2(12) + x*( dilog2(13) + x*( dilog2(14) +
     +		x*( dilog2(15) + x*dilog2(16) ))))
	endif
	if ( xa .gt. bdn05 ) then
	    xl22 = x*( dilog2(7) + x*( dilog2(8) + x*( dilog2(9) +
     +		x*( dilog2(10) + x*( dilog2(11) + xl22 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    xl22 = x*( dilog2(3) + x*( dilog2(4) + x*( dilog2(5) +
     +		x*( dilog2(6) + xl22 ))))
	endif
	xl22 = - x**2*( dilog2(2) + xl22 )
*  #] calculations:
*###] ffxl22:
	end


      subroutine fvdge(x,y,ds,dy)
!
      use kinddefine
      implicit none
      real(kind=K8),dimension(5),intent(in) :: x,y
      real(kind=K8),intent(out) :: ds,dy
      real(kind=K8) :: a1,a3,f1,f2,f3,fx,h,two
      real(kind=K8) :: x1,x2,x3,x4,x5,x21,x32,x43,x54
      real(kind=K8) :: y1,y2,y3,y4,y5,yp21,yp32,yp43,yp54,ypp1,ypp2,ypp3
      real(kind=K8) :: z13
      data h/0.5d+0/,two/2.0d+0/
!
      x1=x(1)
      x2=x(2)
      x3=x(3)
      x4=x(4)
      x5=x(5)
!
      y1=y(1)
      y2=y(2)
      y3=y(3)
      y4=y(4)
      y5=y(5)
!
!     find delta-y
      f1=(x3-x1)*(x3-x2)
      f1=two/f1
!
      f2=(x4-x3)*(x3-x2)
      f2=-two/f2
!
      f3=(x5-x3)*(x4-x3)
      f3=two/f3
!
      z13=x1+x2+x2-x4-x4-x5
      a1=(x2+x3-x4-x5)/z13
      a3=(x1+x2-x3-x4)/z13
!
      yp21=(y2-y1)/(x2-x1)
      yp32=(y3-y2)/(x3-x2)
      yp43=(y4-y3)/(x4-x3)
      yp54=(y5-y4)/(x5-x4)
!
      x21=h*(x2+x1)
      x32=h*(x3+x2)
      x43=h*(x4+x3)
      x54=h*(x5+x4)
!
      ypp1=(yp32-yp21)/(x32-x21)
      ypp2=(yp43-yp32)/(x43-x32)
      ypp3=(yp54-yp43)/(x54-x43)
      ds=a1*ypp1+a3*ypp3-ypp2
      fx=f2-a1*f1-a3*f3
      dy=ds/fx
!
      end subroutine fvdge


program main
    use double
    use stoichiometry
    implicit none

    integer :: k,l
    integer, parameter :: MATRIXSIZE=5
    real(kind=dp),dimension(MATRIXSIZE,MATRIXSIZE) :: hilb=0_dp

    ! construct a hilbert matrix
    do k=lbound(hilb,1),ubound(hilb,1)
        do l=lbound(hilb,2),ubound(hilb,2)
            hilb(k,l)=1._dp/(k+l-1)
        end do
    end do

    ! lets print the result
    print *, hilb
end program main


! { dg-do run }
! PR fortran/28276
! Original code submitted by Harald Anlauf
! Converted to Dejagnu for the testsuite by Steven G. Kargl
!
program gfcbug36
  implicit none
  real, parameter :: one = 1.0
  real :: a = one

  if (fraction(a) /= 0.5) call abort
  if (fraction(one) /= 0.5) call abort
  if (fraction(1.0) /= 0.5) call abort

  if (exponent(a) /= 1.0) call abort
  if (exponent(one) /= 1.0) call abort
  if (exponent (1.0) /= 1.0) call abort

  if (scale(fraction(a),   exponent(a))   / a   /= 1.) call abort
  if (scale(fraction(one), exponent(one)) / one /= 1.) call abort
  if (scale(fraction(1.0), exponent(1.0)) / 1.0 /= 1.) call abort

end program gfcbug36


module spherepack_precision

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: wp ! Working precision
    public :: ip ! Integer precision
    public :: PI, TWO_PI, HALF_PI, MACHINE_EPSILON
    public :: get_pi
    public :: even, odd

    ! Floating point precision constants
    integer, parameter :: FLOAT128 = selected_real_kind(p=33, r=4931) ! 33 digits, range [10^(-4931), 10^(+4931) - 1], 128 bits
    integer, parameter :: FLOAT64 = selected_real_kind(p=15, r=307) ! 15 digits, range [10^(-307) , 10^(+307)  - 1], 64 bits
    integer, parameter :: FLOAT32 = selected_real_kind(p=6, r=37) ! 6 digits, range [10^(-37)  , 10^(+37)   - 1],  32 bits
    integer, parameter :: wp = FLOAT64 ! Default floating point precision

    ! Integer precision constants
    integer, parameter :: INT64 = selected_int_kind(r=18) ! 19 digits plus sign, range [-2^(63), +2^(63) - 1], 64 bits
    integer, parameter :: INT32 = selected_int_kind(r=9) ! 10 digits plus sign, range [-2^(31), +2^(31) - 1], 32 bits
    integer, parameter :: INT16 = selected_int_kind(r=4) ! 5 digits plus sign, range [-2^(15), +2^(15) - 1], 16 bits
    integer, parameter :: INT8 = selected_int_kind(r=2) ! 3 digits plus sign, range [-2^(7) , +2^(7)  - 1], 8 bits
    integer, parameter :: ip = INT32! Default integer precision

    ! Parameters confined to the module
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    ! Commonly used constants
    real(wp), parameter :: PI = acos(-ONE)
    real(wp), parameter :: HALF_PI = PI/TWO
    real(wp), parameter :: TWO_PI = TWO * PI
    real(wp), parameter :: MACHINE_EPSILON = epsilon(ONE)

contains

    pure function odd(i) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: i
        logical                 :: return_value

        return_value = btest(i, 0)

    end function odd

    pure function even(i) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: i
        logical                 :: return_value

        return_value = .not. odd(i)

    end function even

    pure function get_pi() &
        result (return_value)

        ! Dummy arguments
        real(wp) :: return_value

        return_value = 3.141592653589793238462643383279502884197169399375105820974_wp

    end function get_pi

end module spherepack_precision


! RUN: bbc -emit-fir %s -o - | FileCheck %s

subroutine test_dreal(r, c)
  real(8), intent(out) :: r
  complex(8), intent(in) :: c

! CHECK-LABEL: func @_QPtest_dreal(
! CHECK-SAME: %[[ARG_0:.*]]: !fir.ref<f64> {fir.bindc_name = "r"},
! CHECK-SAME: %[[ARG_1:.*]]: !fir.ref<!fir.complex<8>> {fir.bindc_name = "c"}) {
! CHECK:   %[[VAL_0:.*]] = fir.load %[[ARG_1]] : !fir.ref<!fir.complex<8>>
! CHECK:   %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (!fir.complex<8>) -> f64
! CHECK:   fir.store %[[VAL_1]] to %[[ARG_0]] : !fir.ref<f64>
! CHECK:   return
! CHECK: }

  r = dreal(c)
end


! A simple fortran module for setting up a graph.
! Just vertices, edges and neighbours.
module graphf
    use iso_fortran_env, wp => real64, sp => real32
    implicit none
    private
    public :: graph
    public :: example1

    type graph
       integer :: V = 0
       integer :: E = 0
       integer,allocatable  :: edges(:,:)
       real(wp),allocatable :: eweight(:)
       real(sp),allocatable :: emat(:,:)
       integer,allocatable :: nmat(:,:)   !matrix of neighbours (1 or 0)
       logical :: directed = .false.

       contains
        procedure :: deallocate => deallocate_graph
        procedure :: addVertex => addVertex_graph
        procedure :: setOrder => addVertex_graph
        procedure :: addEdge => addEdge_graph
        procedure :: degree => degree_graph

    end type graph

contains

subroutine deallocate_graph(self)
    implicit none
    class(graph) :: self
    if(allocated(self%edges)) deallocate(self%edges)
    if(allocated(self%eweight)) deallocate(self%eweight)
    if(allocated(self%nmat)) deallocate(self%nmat)
    if(allocated(self%emat)) deallocate(self%emat)
    self%V = 0
    self%E = 0
    return
end subroutine deallocate_graph

!-- add a vertex (or x vertices) to the graph
subroutine addVertex_graph(self,x)
    class(graph) :: self
    integer,optional :: x !number of new vertices
    integer,allocatable :: ndum(:,:)
    real(sp),allocatable :: edum(:,:)
    integer :: k,o,n
    if(present(x))then
        if(x<1)return
        k = x
    else
        k = 1
    endif

    self%V = self%V + k
    if(.not.allocated(self%nmat))then
        allocate(self%nmat(k,k), source = 0)
        allocate(self%emat(k,k), source = 0.0_sp)
    else
        o = self%V - k
        n = self%V
        allocate(ndum(n,n),edum(n,n))
        ndum(1:o,1:o) = self%nmat(1:o,1:o)
        edum(1:o,1:o) = self%emat(1:o,1:o)
        call move_alloc(ndum,self%nmat)
        call move_alloc(edum,self%emat)
        self%nmat(:,n) = 0
        self%nmat(n,:) = 0
        self%emat(:,n) = 0
        self%emat(n,:) = 0
    endif

end subroutine addVertex_graph

!-- add an edge to the graph
subroutine addEdge_graph(self, vertex1, vertex2, weight)
    class(graph) :: self
    integer,intent(in) :: vertex1,vertex2
    real(sp),optional :: weight
    real(sp) :: w2
    integer :: edge(2)
    !integer,allocatable :: edum(:,:)
    !real(wp),allocatable :: wdum(:)
    logical :: ex
    !-- if any of the two vertices is larger than the specified number
    !   of vertices in the graph, print a warning and stop
    if(vertex1 > self%V .or. vertex2 > self%V)then
        error stop "please set the number of vertices before defining edges!"
    endif
    !-- the edge weight is an optional argument. If not present it is = 1.0
    if(present(weight))then
        w2=weight
    else
        w2=1.0_sp
    endif
    !-- only undirected graphs are sorted
    if(vertex1 > vertex2 .and. .not.self%directed)then
        edge(2) = vertex1
        edge(1) = vertex2
    else
        edge(1) = vertex1
        edge(2) = vertex2
    endif
    !-- check if the vertex was already documented in the neighbour matrix
    ex=areNeighbours(self,edge(1),edge(2))
    if(.not.ex)then
    self%nmat(edge(1),edge(2)) = 1
    self%emat(edge(1),edge(2)) = w2
    if(.not.self%directed)then !for undirected graphs nmat is symmetric
        self%nmat(edge(2),edge(1)) = 1
        self%emat(edge(2),edge(1)) = w2
    endif
    self%E = self%E + 1
    endif

    return
end subroutine addEdge_graph

!-- are two edges identical?
logical function equalEdge(edge1, edge2)
    implicit none
    integer,intent(in) :: edge1(2)
    integer,intent(in) :: edge2(2)
    equalEdge = .false.
    if( edge1(1)==edge2(1) .and. edge1(2)==edge2(2))then
        equalEdge = .true.
    else
        equalEdge = .false.
    endif
    return
end function equalEdge

!-- decide if the two vertices are neighbouring
logical function areNeighbours(self,v1,v2)
    implicit none
    class(graph) :: self
    integer,intent(in) :: v1,v2
    areNeighbours = .false.
    if( self%nmat(v1,v2) == 1)then
        areNeighbours = .true.
    endif
    return
end function areNeighbours

!-- get the degree of a vertex (i.e., the number of its neighbours)
function degree_graph(self, v, neighbours)
    class(graph),intent(in) :: self
    integer :: degree_graph
    integer,intent(in) :: v
    integer :: i,u
    integer :: neighbours(*)
    u = 0
    do i=1,self%V
        !-- since nmat is *not* symmetric for directed graphs
        !   this should work for both, directed and undirected
        if( self%nmat(v,i)==1)then
            u = u + 1
            neighbours(u)=i
        endif
    enddo
    degree_graph = u
    return
end function degree_graph

!=====================================================================================!

subroutine example1(G)
     implicit none
     class(graph) :: G
     real(sp) :: l
    call G%setOrder(16)
    l = 1.0_sp

    call G%addEdge( 1, 2,l)
    call G%addEdge( 1, 5, l)
    call G%addEdge( 2, 3, l)
    call G%addEdge( 3, 4, l)
    call G%addEdge( 3, 8, l)
    call G%addEdge( 4, 5, l)
    call G%addEdge( 4, 6, l)
    call G%addEdge( 5, 9, l)
    call G%addEdge( 6, 7, l)
    call G%addEdge( 6, 10, l)
    call G%addEdge( 6, 11, l)
    call G%addEdge( 7, 8, l)
    call G%addEdge( 7, 15, l)
    call G%addEdge( 9, 10, l)
    call G%addEdge(11, 12, l)
    call G%addEdge(11, 13, l)
    call G%addEdge(12, 13, l)
    call G%addEdge(12, 14, l)
    call G%addEdge(13, 15, l)
    call G%addEdge(14, 15, l)
    call G%addEdge(15, 16, l)
    return
end subroutine example1

end module graphf


! { dg-do compile }
! { dg-options "-O2 -fcheck=bounds" }

    FUNCTION F06FKFN(N,W,INCW,X,INCX)
       IMPLICIT NONE
       INTEGER, PARAMETER :: WP = KIND(0.0D0)
       REAL (KIND=WP)                  :: F06FKFN
       REAL (KIND=WP), PARAMETER       :: ONE = 1.0E+0_WP
       REAL (KIND=WP), PARAMETER       :: ZERO = 0.0E+0_WP
       INTEGER, INTENT (IN)            :: INCW, INCX, N
       REAL (KIND=WP), INTENT (IN)     :: W(*), X(*)
       REAL (KIND=WP)                  :: ABSYI, NORM, SCALE, SSQ
       INTEGER                         :: I, IW, IX
       REAL (KIND=WP), EXTERNAL        :: F06BMFN
       INTRINSIC                          ABS, SQRT
       IF (N<1) THEN
          NORM = ZERO
       ELSE IF (N==1) THEN
          NORM = SQRT(W(1))*ABS(X(1))
       ELSE
          IF (INCW>0) THEN
             IW = 1
          ELSE
             IW = 1 - (N-1)*INCW
          END IF
          IF (INCX>0) THEN
             IX = 1
          ELSE
             IX = 1 - (N-1)*INCX
          END IF
          SCALE = ZERO
          SSQ = ONE
          DO I = 1, N
             IF ((W(IW)/=ZERO) .AND. (X(IX)/=ZERO)) THEN
                ABSYI = SQRT(W(IW))*ABS(X(IX))
                IF (SCALE<ABSYI) THEN
                   SSQ = 1 + SSQ*(SCALE/ABSYI)**2
                   SCALE = ABSYI
                ELSE
                   SSQ = SSQ + (ABSYI/SCALE)**2
                END IF
             END IF
             IW = IW + INCW
             IX = IX + INCX
          END DO
          NORM = F06BMFN(SCALE,SSQ)
       END IF
       F06FKFN = NORM
       RETURN
    END FUNCTION F06FKFN


program const_kind_01
integer, parameter :: sp = 4, dp = 8
real(sp), parameter :: r1 = 1.0_sp
real(dp), parameter :: r2 = 1.0_dp
real :: r3
r3 = 1.0_sp
r3 = 1.0_dp
print *, sp, dp, r1, r2, r3
end program


c { dg-do run }
c
c Fixed form test program for PR 17941 (signed constants with spaces)
c
      program real_const_1
      complex c0, c1, c2, c3, c4
      real rp(4), rn(4)
      parameter (c0 = (-0.5, -     0.5))
      parameter (c1 = (-     0.5, +     0.5))
      parameter (c2 = (-    0.5E2, +0.5))
      parameter (c3 = (-0.5, +     0.5E-2))
      parameter (c4 = (-     1, +     1))
      data rn /- 1.0, - 1d0, - 1.d0, - 10.d-1/
      data rp /+ 1.0, + 1d0, + 1.d0, + 10.d-1/
      real, parameter :: del = 1.e-5

      if (abs(c0 - cmplx(-0.5,-0.5)) > del) STOP 1
      if (abs(c1 - cmplx(-0.5,+0.5)) > del) STOP 2
      if (abs(c2 - cmplx(-0.5E2,+0.5)) > del) STOP 3
      if (abs(c3 - cmplx(-0.5,+0.5E-2)) > del) STOP 4
      if (abs(c4 - cmplx(-1.0,+1.0)) > del) STOP 5
      if (any (abs (rp - 1.0) > del)) STOP 6
      if (any (abs (rn + 1.0) > del)) STOP 7
      end program


C     File: goto_05.f
C     A simple program with a single forward conditional goto and
C     a single backward conditional goto.
C     The program computes and prints out the values of n! for n in [1,10].

      program factorial
      implicit none

      integer i, n, fact

      i = 0
      n = 10
      fact = 0

 111  i = i + 1
      if (fact .ne. 0) goto 222

      fact = fact + 1    ! this line is executed exactly once

 222  fact = fact * i

      write (*, 10) i, fact

      if (i .lt. n) goto 111

      stop
 10   format('i = ', I3, '; fact = ', I8)

      end program factorial


      FUNCTION AREA (G,I,J,K)
C
C     THIS ROUTINE IS CALLED BY SFAREA WHICH IS CALLED BY EMGFIN TO
C     COMPUTE THE SURFACE AREAS OF THE SOLID ELEMENTS
C
      DIMENSION  G(1)
      AREA = 0.5*SQRT(
     1 ((G(J+2)-G(I+2))*(G(K+3)-G(I+3))-(G(J+3)-G(I+3))*(G(K+2)-G(I+2)))
     2 **2
     3+((G(J+3)-G(I+3))*(G(K+1)-G(I+1))-(G(J+1)-G(I+1))*(G(K+3)-G(I+3)))
     4 **2
     5+((G(J+1)-G(I+1))*(G(K+2)-G(I+2))-(G(J+2)-G(I+2))*(G(K+1)-G(I+1)))
     6 **2)
      RETURN
      END


subroutine invmtx(a,b,deter,nsize)

!-----------------------------------------------------------------------
!
! This routine inverts a square matrix A -> Mat(nsize,nsize). The
! inverse is stored in B. Its determinant is DETER
!
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: nsize
  real(rp),    intent(in)  :: a(nsize,nsize)
  real(rp),    intent(out) :: b(nsize,nsize),deter
  integer(ip)              :: isize,jsize
  real(rp)                 :: denom,t1,t2,t3,t4

  select case (nsize)

  case(1)
     deter=a(1,1)
     if(deter==0.0_rp) return
     b(1,1) = 1.0_rp/a(1,1)

  case(2)
     deter=a(1,1)*a(2,2)-a(2,1)*a(1,2)
     if(deter==0.0_rp) return
     denom=1.0_rp/deter
     b(1,1) = a(2,2)*denom
     b(2,2) = a(1,1)*denom
     b(2,1) =-a(2,1)*denom
     b(1,2) =-a(1,2)*denom

  case(3)
     t1  = a(2,2)*a(3,3) - a(3,2)*a(2,3)
     t2  =-a(2,1)*a(3,3) + a(3,1)*a(2,3)
     t3  = a(2,1)*a(3,2) - a(3,1)*a(2,2)
     deter = a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3
     if(deter==0.0_rp) return
     denom = 1.0_rp/deter
     b(1,1) = t1*denom
     b(2,1) = t2*denom
     b(3,1) = t3*denom
     b(2,2) = ( a(1,1)*a(3,3) - a(3,1)*a(1,3))*denom
     b(3,2) = (-a(1,1)*a(3,2) + a(1,2)*a(3,1))*denom
     b(3,3) = ( a(1,1)*a(2,2) - a(2,1)*a(1,2))*denom
     b(1,2) = (-a(1,2)*a(3,3) + a(3,2)*a(1,3))*denom
     b(1,3) = ( a(1,2)*a(2,3) - a(2,2)*a(1,3))*denom
     b(2,3) = (-a(1,1)*a(2,3) + a(2,1)*a(1,3))*denom

  case(4)
     t1= a(2,2)*a(3,3)*a(4,4) + a(2,3)*a(3,4)*a(4,2)&
          + a(2,4)*a(3,2)*a(4,3) - a(2,3)*a(3,2)*a(4,4)&
          - a(2,2)*a(3,4)*a(4,3) - a(2,4)*a(3,3)*a(4,2)
     t2=-a(2,1)*a(3,3)*a(4,4) - a(2,3)*a(3,4)*a(4,1)&
          - a(2,4)*a(3,1)*a(4,3) + a(2,4)*a(3,3)*a(4,1)&
          + a(2,3)*a(3,1)*a(4,4) + a(2,1)*a(3,4)*a(4,3)
     t3=+a(2,1)*a(3,2)*a(4,4) + a(2,2)*a(3,4)*a(4,1)&
          + a(2,4)*a(3,1)*a(4,2) - a(2,4)*a(3,2)*a(4,1)&
          - a(2,2)*a(3,1)*a(4,4) - a(2,1)*a(3,4)*a(4,2)
     t4=-a(2,1)*a(3,2)*a(4,3) - a(2,2)*a(3,3)*a(4,1)&
          - a(2,3)*a(3,1)*a(4,2) + a(2,3)*a(3,2)*a(4,1)&
          + a(2,2)*a(3,1)*a(4,3) + a(2,1)*a(3,3)*a(4,2)
     deter= a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3 + a(1,4)*t4
     if(deter==0.0_rp) return
     denom=1.0_rp/deter
     b(1,1) = t1*denom
     b(2,1) = t2*denom
     b(3,1) = t3*denom
     b(4,1) = t4*denom
     b(1,2) =(- a(1,2)*a(3,3)*a(4,4) - a(1,3)*a(3,4)*a(4,2)&
          - a(1,4)*a(3,2)*a(4,3) + a(1,3)*a(3,2)*a(4,4)&
          + a(1,2)*a(3,4)*a(4,3) + a(1,4)*a(3,3)*a(4,2))*denom
     b(2,2) =(  a(1,1)*a(3,3)*a(4,4) + a(1,3)*a(3,4)*a(4,1)&
          + a(1,4)*a(3,1)*a(4,3) - a(1,4)*a(3,3)*a(4,1)&
          - a(1,3)*a(3,1)*a(4,4) - a(1,1)*a(3,4)*a(4,3))*denom
     b(3,2) =(- a(1,1)*a(3,2)*a(4,4) - a(1,2)*a(3,4)*a(4,1)&
          - a(1,4)*a(3,1)*a(4,2) + a(1,4)*a(3,2)*a(4,1)&
          + a(1,2)*a(3,1)*a(4,4) + a(1,1)*a(3,4)*a(4,2))*denom
     b(4,2) =(  a(1,1)*a(3,2)*a(4,3) + a(1,2)*a(3,3)*a(4,1)&
          + a(1,3)*a(3,1)*a(4,2) - a(1,3)*a(3,2)*a(4,1)&
          - a(1,2)*a(3,1)*a(4,3) - a(1,1)*a(3,3)*a(4,2))*denom
     b(1,3) =(  a(1,2)*a(2,3)*a(4,4) + a(1,3)*a(2,4)*a(4,2)&
          + a(1,4)*a(2,2)*a(4,3) - a(1,3)*a(2,2)*a(4,4)&
          - a(1,2)*a(2,4)*a(4,3) - a(1,4)*a(2,3)*a(4,2))*denom
     b(2,3) =(- a(1,1)*a(2,3)*a(4,4) - a(1,3)*a(2,4)*a(4,1)&
          - a(1,4)*a(2,1)*a(4,3) + a(1,4)*a(2,3)*a(4,1)&
          + a(1,3)*a(2,1)*a(4,4) + a(1,1)*a(2,4)*a(4,3))*denom
     b(3,3) =(  a(1,1)*a(2,2)*a(4,4) + a(1,2)*a(2,4)*a(4,1)&
          + a(1,4)*a(2,1)*a(4,2) - a(1,4)*a(2,2)*a(4,1)&
          - a(1,2)*a(2,1)*a(4,4) - a(1,1)*a(2,4)*a(4,2))*denom
     b(4,3) =(- a(1,1)*a(2,2)*a(4,3) - a(1,2)*a(2,3)*a(4,1)&
          - a(1,3)*a(2,1)*a(4,2) + a(1,3)*a(2,2)*a(4,1)&
          + a(1,2)*a(2,1)*a(4,3) + a(1,1)*a(2,3)*a(4,2))*denom
     b(1,4) =(- a(1,2)*a(2,3)*a(3,4) - a(1,3)*a(2,4)*a(3,2)&
          - a(1,4)*a(2,2)*a(3,3) + a(1,4)*a(2,3)*a(3,2)&
          + a(1,3)*a(2,2)*a(3,4) + a(1,2)*a(2,4)*a(3,3))*denom
     b(2,4) =(  a(1,1)*a(2,3)*a(3,4) + a(1,3)*a(2,4)*a(3,1)&
          + a(1,4)*a(2,1)*a(3,3) - a(1,4)*a(2,3)*a(3,1)&
          - a(1,3)*a(2,1)*a(3,4) - a(1,1)*a(2,4)*a(3,3))*denom
     b(3,4) =(- a(1,1)*a(2,2)*a(3,4) - a(1,2)*a(2,4)*a(3,1)&
          - a(1,4)*a(2,1)*a(3,2) + a(1,4)*a(2,2)*a(3,1)&
          + a(1,2)*a(2,1)*a(3,4) + a(1,1)*a(2,4)*a(3,2))*denom
     b(4,4) =(  a(1,1)*a(2,2)*a(3,3) + a(1,2)*a(2,3)*a(3,1)&
          + a(1,3)*a(2,1)*a(3,2) - a(1,3)*a(2,2)*a(3,1)&
          - a(1,2)*a(2,1)*a(3,3) - a(1,1)*a(2,3)*a(3,2))*denom

  case default
     b=a
     call invert(b,nsize,nsize)

  end select

end subroutine invmtx


!	probvecitem is used to compute underlying item probabilities for one probability.

!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
function probvecitem(locations,scales,theta)
implicit none

real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
real(kind=8)::probvecitem(size(locations))

!
!	cat is the category number.

integer::cat
!	probdiv is used to normalize probabilities
real(kind=8)::probdiv
!	Initialize locations.

do cat=1,size(locations)
	probvecitem(cat)=exp(sum(theta*scales(:,cat))+locations(cat))

end do
probdiv=sum(probvecitem)
probvecitem=probvecitem/probdiv

return
end function probvecitem