    Program zhbgst_example

!     ZHBGST Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dsterf, zhbgst, zhbtrd, zpbstf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, j, ka, kb, ldab, ldbb, ldx, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), bb(:, :), work(:), x(:, :)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZHBGST Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, ka, kb
      ldab = ka + 1
      ldbb = kb + 1
      ldx = n
      Allocate (ab(ldab,n), bb(ldbb,n), work(n), x(ldx,n), d(n), e(n-1), &
        rwork(n))

!     Read A and B from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(ka+1+i-j,j), j=i, min(n,i+ka))
        End Do
        Do i = 1, n
          Read (nin, *)(bb(kb+1+i-j,j), j=i, min(n,i+kb))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-ka), i)
        End Do
        Do i = 1, n
          Read (nin, *)(bb(1+i-j,j), j=max(1,i-kb), i)
        End Do
      End If

!     Compute the split Cholesky factorization of B
      Call zpbstf(uplo, n, kb, bb, ldbb, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'B is not positive definite.'
      Else

!       Reduce the problem to standard form C*y = lambda*y, storing
!       the result in A
        Call zhbgst('N', uplo, n, ka, kb, ab, ldab, bb, ldbb, x, ldx, work, &
          rwork, info)

!       Reduce C to tridiagonal form T = (Q**H)*C*Q
        Call zhbtrd('N', uplo, n, ka, ab, ldab, d, e, x, ldx, work, info)

!       Calculate the eigenvalues of T (same as C)
        Call dsterf(n, d, e, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Print eigenvalues

          Write (nout, *) 'Eigenvalues'
          Write (nout, 100) d(1:n)
        End If
      End If

100   Format (3X, (8F8.4))
    End Program


 SUBROUTINE inpda7 (task,nelem, eule0,euler,coord, iwrit,elsnam,nelms)
 !******************************************************************
 !
 !*** READ control DATA for 6-node triangular shell elements
 !    TQQL and TQLL
 !
 !******************************************************************

 USE ctrl_db, ONLY : ndofn
 USE ele07_db
 USE gvar_db,ONLY : maxsdv,fimpo,overw

 IMPLICIT NONE
 ! dummy arguments
 CHARACTER(len=*),INTENT(IN):: elsnam
 CHARACTER(len=*),INTENT(IN):: task
 INTEGER (kind=4) :: nelem,nelms,iwrit
 REAL    (kind=8) :: coord(:,:),eule0(:,:),euler(:,:)

 ! local variables
 LOGICAL :: cmpea, &   !CoMPute Euler Angles
            oldset     !
 INTEGER (kind=4) :: nreqs, narch,i,stype,g,ngaus,nnode,nstre
 INTEGER (kind=4), ALLOCATABLE  :: lnods(:,:)
 TYPE (ele07_set), POINTER :: elset,anter
 TYPE (ele07), POINTER :: el
 REAL (kind=8) :: a,b,deriv(6,2)
 CHARACTER(len=mnam) :: sname     ! element set name

 INTERFACE
   INCLUDE 'nodnor.h'
   INCLUDE 'nodn07.h'
 END INTERFACE

 sname = elsnam

 !  ******************************
 !  assumed membrane strain points

 a = (1d0-1d0/SQRT(3d0))/2d0
 b = (1d0+1d0/SQRT(3d0))/2d0
 CALL shape7(a  ,0d0,deriv(1,1),nfdas(1,1,1))
 CALL shape7(b  ,0d0,deriv(1,1),nfdas(1,1,2))
 CALL shape7(b  ,a  ,deriv(1,1),nfdas(1,1,3))
 CALL shape7(a  ,b  ,deriv(1,1),nfdas(1,1,4))
 CALL shape7(0d0,b  ,deriv(1,1),nfdas(1,1,5))
 CALL shape7(0d0,a  ,deriv(1,1),nfdas(1,1,6))

 IF (TRIM(task) == 'INPUT') THEN
   ! check if list of sets and set exists and initializes
   CALL srch_ele07 (head, anter, elset, elsnam, oldset)
   IF (oldset) THEN    !if set exists
     CALL commv7 (1, nelem,  nreqs, narch, stype, ngaus, elsnam, nnode, nstre, elset)
     cmpea = .FALSE.
   ELSE                !set ELSNAM does not exist
     CALL new_ele07(elset)       !reserve memory for set
     nelem  =  0           !new set, initializes number of elements
     CALL listen('INPDA7')
     nreqs = getint('NREQS ',0,' GAUSS PT FOR STRESS TIME HISTORY .')
     ngaus = getint('NGAUS ',3,' Number of integration points .....')
     stype = getint('STYPE ',0,' Formulation type for this set ....')
     IF( ngaus == 3 )THEN
       elset%ngamm = 6
       nnode = 6
     ELSE
       IF( stype > 1) stype = 1 !TLLL element
       IF( exists('QUAD  ') )THEN
         WRITE(lures,"(/,5X,' Quadratic approach for membrane ', &
                        &      'behavior Selected'//)",ERR=9999)
         nnode = 9
       ELSE
         nnode = 6
       END IF
       elset%ngamm = 3
       elset%stabq=getrea('STABQ ',1d0,' Stabilization factor for shear    ')
     END IF
     cmpea = exists('EULER ')
     IF(cmpea)WRITE(lures,"(/,5X,' Automatic Evaluation of Local ', &
                          &      'Nodal Systems Selected'//)",ERR=9999)
     elset%angdf=getrea('ANGLE ',0d0,' Default angle between X1 and Ort_1')
     IF( exists('LOCAL  ',i)) THEN   !local axis definition
       elset%locax =  INT(param(i))
       IF( elset%locax < 1 .OR. elset%locax > 3 )THEN
         WRITE(lures,"(/,5X,'Error in the definition of local system', / &
                         5X,'Invalid axis: ',i3,' Default value used (3)')") elset%locax
         elset%locax = 3
       END IF
     END IF
     ALLOCATE(elset%ap1(2,elset%ngamm,ngaus))

     IF( ngaus == 3 )THEN
!       gauss points in local coordinates and weigths
       ALLOCATE( elset%posgp(2,ngaus), elset%weigp(ngaus), elset%shape(nnode,ngaus))

       ! assumed membrane strain points

       a = 1d0/3d0
       CALL shape7(a  ,a  ,deriv(1,1),dn(1,1,1))
       CALL shape7(0d0,0d0,deriv(1,1),dn(1,1,2))
       CALL shape7(1d0,0d0,deriv(1,1),dn(1,1,3))
       CALL shape7(0d0,1d0,deriv(1,1),dn(1,1,4))

       ! ******************************
       ! gauss points in local coordinates and weigths
       a = 1d0/6d0
       elset%weigp(:) = a
       ! version for Integration points at mid-side nodes
       b = 1d0/2d0                   !coordinate at mid point
       elset%posgp(:,1) = (/ b  ,0d0 /)    !
       elset%posgp(:,2) = (/ b  ,b   /)    !
       elset%posgp(:,3) = (/ 0d0,b   /)    !
       !! version for Integration points at interior points
       !b = 2d0/3d0                   !coordinate at interior point
       !elset%posgp(:,1)= (/ a,a /)
       !elset%posgp(:,2)= (/ b,a /)
       !elset%posgp(:,3)= (/ a,b /)

       ! matrix AP^(-T) for assumed shear at Gauss points
       DO g=1,ngaus
         !CALL shape7(elset%posgp(1,g),elset%posgp(2,g),elset%shape(1,g),deriv)
         CALL ap1tm7(elset%ap1(:,:,g),elset%posgp(1,g),elset%posgp(2,g))
       END DO

     ELSE
       !a = 1d0/3d0
       !elset%posgp(:,1) = (/ a,a /)
       !elset%weigp = 0.5d0
       !elset%shape(1:3,1) = a
       !elset%shape(4:6,1) = 0d0
       NULLIFY(elset%posgp, elset%weigp, elset%shape)
       elset%ap1 =  RESHAPE((/ -1d0/3d0,  1d0/3d0,   &
                               -1d0/3d0, -2d0/3d0,   &
                                2d0/3d0,  1d0/3d0/), (/2,elset%ngamm,1/))

     END IF
     nstre = 8
     IF( exists('ZIGZAG') ) THEN !local axis definition
       IF( ndofn == 8 )THEN
         elset%zigzag = .TRUE.
         nstre  = 14
       END IF
     END IF

   END IF

   CALL elmda7(nelem,nnode,elset%head,elset%tail,stype,iwrit,ngaus,elset%ngamm,nstre)
   CALL nodxy7(nelem,elset%head,coord,eule0,euler,ngaus)

   IF(cmpea)THEN
     ALLOCATE (lnods(6,nelem))
     el => elset%head
     DO i=1,nelem
       lnods(:,i) = el%lnods(1:6)
       el => el%next
     END DO
     IF( ngaus /= 1 )THEN
       CALL nodnor(nelem,nnode,lnods,coord,eule0,euler)
     ELSE
       CALL nodn07(nelem,lnods,coord,eule0,euler)  !locax
     END IF
     DEALLOCATE (lnods)
   END IF

   elset%plstr = 0     ! do not compute plastic strains
   IF (.NOT.oldset) CALL rdreqs ( 1 ,nreqs, elset%ngrqs, iwrit )

   CALL commv7(0, nelem,  nreqs, narch, stype, ngaus, elsnam, nnode, nstre, elset)
   ! add to the list of sets
   IF (.NOT.oldset) THEN
     CALL add_ele07 (elset, head, tail) ! add to the list of sets
     nelms = nelms + 1 ! increased set counter for this element type
   END IF

 ELSE IF (TRIM(task) == 'RESTAR') THEN

   ALLOCATE (elset)          !initializes a list
   NULLIFY(elset%head)       !nullify head pointer
   ! read control parameters
   elset%sname = elsnam
   READ (51) elset%nelem, elset%nreqs, elset%narch, elset%stype, elset%ngaus, elset%lside, &
             elset%gauss, elset%plstr, elset%angdf, elset%stabq, elset%nnode, elset%zigzag, elset%nstre
   ngaus = elset%ngaus
   IF( ngaus /= 1 )THEN
     elset%ngamm = 6
   ELSE
     elset%ngamm = 3
   END IF
   ALLOCATE(elset%ap1(2,elset%ngamm,ngaus))
   READ (51) elset%ap1

   IF( ngaus == 3 )THEN
!     gauss points in local coordinates and weigths
     ALLOCATE( elset%posgp(2,ngaus), elset%weigp(ngaus), elset%shape(nnode,ngaus))
     READ (51) elset%posgp, elset%weigp, elset%shape

   ELSE
     NULLIFY(elset%posgp, elset%weigp, elset%shape)

   END IF

   ! restore list of elements
   CALL rest07 (elset%nelem, elset%nreqs, elset%head, elset%tail, &
                elset%ngrqs, elset%stype, elset%ngaus, elset%ngamm, elset%nnode, elset%nstre)
   ! add to list of elements
   CALL add_ele07 (elset, head, tail)

 ELSE IF (TRIM(task) == 'IMPORT') THEN
   ! check if list of sets and set exists and initializes
   IF( overw )THEN
     CALL srch_ele07 (head, anter, elset, elsnam, oldset)
     IF (oldset) THEN    !if set exists
       CALL commv7(1, nelem,  nreqs, narch, stype, ngaus, elsnam, nnode, nstre, elset)
       !elset%lside = .FALSE.   !initializes flag to compute LSIDE
     ELSE
       CALL runen2(' Old set to overwrite does not exist')
     END IF
     READ (fimpo)
   ELSE
     CALL new_ele07(elset)       !reserve memory for set
     elset%sname = sname
     READ (fimpo) nelem,nnode,ngaus,stype,elset%angdf,elset%stabq,nstre
     nreqs = 0
     narch = 0
     IF( ngaus /= 1 )THEN
       elset%ngamm = 6
     ELSE
       elset%ngamm = 3
     END IF
     elset%locax = 3
   END IF
   ! restore list of elements
   CALL impo07 ( nelem,elset%head, elset%tail, ngaus, nnode, stype, elset%ngamm, nstre)
   CALL commv7 (0, nelem,  nreqs, narch, stype, ngaus, elsnam, nnode, nstre, elset)
   ! add to list of elements
   IF( .NOT.overw )THEN
     ALLOCATE(elset%ap1(2,elset%ngamm,ngaus))
     IF( ngaus == 3 )THEN
       !    gauss points in local coordinates and weigths
       ALLOCATE( elset%posgp(2,ngaus), elset%weigp(ngaus), elset%shape(nnode,ngaus))

       ! assumed membrane strain points

       a = 1d0/3d0
       CALL shape7(a  ,a  ,deriv(1,1),dn(1,1,1))
       CALL shape7(0d0,0d0,deriv(1,1),dn(1,1,2))
       CALL shape7(1d0,0d0,deriv(1,1),dn(1,1,3))
       CALL shape7(0d0,1d0,deriv(1,1),dn(1,1,4))

       ! ******************************
       ! gauss points in local coordinates and weigths
       ! version for Integration points at mid-side nodes
       a = 1d0/6d0                   !a = 1d0/6d0
       b = 1d0/2d0                   !b = 2d0/3d0
       elset%posgp(:,1) = (/ b  ,0d0 /)    !posgp(:,1)= (/ a,a /)
       elset%posgp(:,2) = (/ b  ,b   /)    !posgp(:,2)= (/ b,a /)
       elset%posgp(:,3) = (/ 0d0,b   /)    !posgp(:,3)= (/ a,b /)
       elset%weigp = a

       ! gauss points shape of nodal functions

       DO g=1,ngaus
         !CALL shape7(elset%posgp(1,g),elset%posgp(2,g),elset%shape(1,g),deriv)
         CALL ap1tm7(elset%ap1(:,:,g),elset%posgp(1,g),elset%posgp(2,g))
       END DO

     ELSE
       !a = 1d0/3d0
       !elset%posgp(:,1) = (/ a,a /)
       !elset%weigp = 0.5d0
       !elset%shape(1:3,1) = a
       !elset%shape(4:6,1) = 0d0
       NULLIFY(elset%posgp, elset%weigp, elset%shape)
       elset%ap1 =  RESHAPE((/ -1d0/3d0, -2d0/3d0,   &
                                2d0/3d0,  1d0/3d0,   &
                               -1d0/3d0,  1d0/3d0/), (/2,elset%ngamm,1/))

     END IF
     CALL add_ele07 (elset, head, tail)
     nelms = nelms + 1 ! increased set counter for this element type
   END IF

 ELSE
   CALL runend('INPD07: NON-EXISTENT TASK .        ')
 END IF

 RETURN
 9999 CALL runen2('')
 END SUBROUTINE inpda7


	program timeWrap

!	use lapack95
	use dyn_array

	implicit none

	integer:: i,info
	integer:: nrA
	integer:: ncA
	integer:: nrU,ncU,nrVT,ncVT,nrS,ncS
	integer:: niter=4
	real*8::tolerance = 1e-3
	integer :: relevant = 100
	real*8 :: start_time, stop_time
	double complex, allocatable, dimension(:,:) :: rawUin, rawVTin
	real*8, allocatable, dimension(:) :: rawSin
	double complex, allocatable,dimension(:,:):: A
	double complex, allocatable, dimension(:) :: rawA
	real*8, allocatable, dimension(:)::ww
	!	double complex, allocatable, dimension(:) :: rawU,rawVT,rawS

    integer :: lwork
    double complex, allocatable, dimension(:) :: work
    real*8, allocatable, dimension(:) :: rwork

    character(Len=100) :: arg

    call getarg(1,arg)
    write (*,*) arg

    call cpu_time(start_time)

    open(5,FILE = arg, form='unformatted',access='stream')

	read(5) nrA
	read(5) ncA
	print *, 'nrA=' ,nrA
	print *, 'ncA=' ,ncA

allocate(rawA(nrA*ncA))
	do i=1,nrA*ncA

read(5) rawA(i)

	end do

	close(5)
call cpu_time(stop_time)
	print *, 'Reading time: ',stop_time - start_time
	print *,'rawA(1)'  , rawA(1)
	nrU=nrA
	ncU=ncA
	nrS=ncA
	ncS=ncA
	nrVT=ncA
	ncVT=ncA

	allocate(raWUin(nrU,ncU))
	allocate(rawSin(nrS))
allocate(rawVTin(nrVT,ncVT))
allocate(A(nrA,ncA))
allocate(ww(ncA-1))
A=reshape(rawA,(/nrA,ncA/))
print *,'A reshaped(1,1): ',A(1,1)
call cpu_time(start_time)
!allocate the rwork array for zgesvd
allocate(rwork(5*nrA))
allocate(work(1))
!Set this for work dimension query
lwork = -1
call zgesvd('A','A',nrA,ncA,A,nrA,&
rawSin,rawUin,nrA,rawVTin,ncA,work,lwork,rwork,info)
lwork = work(1)
deallocate(work)
allocate(work(lwork))
call zgesvd('A','A',nrA,ncA,A,nrA,&
rawSin,rawUin,nrA,rawVTin,ncA,work,lwork,rwork,info)

deallocate(work)
deallocate(rwork)

!call gesvd(A,rawSin,rawUin,rawVTin,ww,'N',info)
call cpu_time(stop_time)
print *,'S(1): ',rawSin(1)
print *,'Time Standard SVD: ',stop_time - start_time

call cpu_time(start_time)
	print *,'Call to tamaImport'
call tamaImport(nrA,ncA,rawA,relevant,niter,tolerance,nrU,ncU,rawUin, nrS,ncS,rawSin,nrVT,ncVT,rawVTin)
print *,'tamaImport competed!'
call cpu_time(stop_time)
print *,'tamaImport time: ',stop_time - start_time

print *,'rawSin(1)',rawSin(1)
	end program


      program main

     ! Size of vectors
      integer :: n = 100000

     ! Input vectors
     real,dimension(:),allocatable :: a
     real,dimension(:),allocatable :: b
     ! Output vector
     real,dimension(:),allocatable :: c

      integer :: i
     real :: sum

     ! Allocate memory for each vector
     allocate(a(n))
     allocate(b(n))
     allocate(c(n))

     ! Initialize content of input vectors, vector a[i] = sin(i)^2 vector b[i] = cos(i)^2
      do i=1,n
        a(i) = sin(i*1.0)*sin(i*1.0)
        b(i) = cos(i*1.0)*cos(i*1.0)
      enddo

     ! Sum component wise and save result into vector c

     !$acc region
      do i=1,n
        c(i) = a(i) + b(i)
      enddo
     !$acc end region

     ! Sum up vector c and print result divided by n, this should equal 1 within error
      do i=1,n
        sum = sum +  c(i)
      enddo
     sum = sum/n
     print *, 'final result: ', sum

     ! Release memory
     deallocate(a)
     deallocate(b)
     deallocate(c)

      end program


program cov
  use stdlib_stats, only: cov
  implicit none
  real :: y(1:2, 1:3) = reshape([1., 2., 3., 4., 5., 6.], [2, 3])

  print*, cov(y, 1)
  print*, cov(y, 2)
end program cov


program Karpekar_Numbers
  implicit none

  integer, parameter :: i64 = selected_int_kind(18)
  integer :: count

  call karpekar(10000_i64, .true.)
  write(*,*)
  call karpekar(1000000_i64, .false.)

contains

subroutine karpekar(n, printnums)

  integer(i64), intent(in) :: n
  logical, intent(in) :: printnums
  integer(i64) :: c, i, j, n1, n2
  character(19) :: str, s1, s2

  c = 0
  do i = 1, n
    write(str, "(i0)") i*i
    do j = 0, len_trim(str)-1
      s1 = str(1:j)
      s2 = str(j+1:len_trim(str))
      read(s1, "(i19)") n1
      read(s2, "(i19)") n2
      if(n2 == 0) cycle
      if(n1 + n2 == i) then
        c = c + 1
        if (printnums .eqv. .true.) write(*, "(i0)") i
        exit
      end if
    end do
  end do
  if (printnums .eqv. .false.) write(*, "(i0)") c
end subroutine
end program


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE MXVECT(N,VEC,MAT,RES)
      REAL VEC(*),MAT(N,*),RES(*)

      IF (N .EQ. 4) THEN
        RES(1) = MAT(1,1)*VEC(1) + MAT(2,1)*VEC(2) + MAT(3,1)*VEC(3) +
     *    MAT(4,1)*VEC(4)

        RES(2) = MAT(1,2)*VEC(1) + MAT(2,2)*VEC(2) + MAT(3,2)*VEC(3) +
     *    MAT(4,2)*VEC(4)

        RES(3) = MAT(1,3)*VEC(1) + MAT(2,3)*VEC(2) + MAT(3,3)*VEC(3) +
     *    MAT(4,3)*VEC(4)

        RES(4) = MAT(1,4)*VEC(1) + MAT(2,4)*VEC(2) + MAT(3,4)*VEC(3) +
     *    MAT(4,4)*VEC(4)

      ELSE
        DO 2980 J = 1,N
          RES(J) = 0.0
 2980   CONTINUE
        DO 3010 I = 1,N
          DO 2990 J = 1,N
            RES(J) = RES(J) + MAT(I,J)*VEC(I)
 2990     CONTINUE
 3010   CONTINUE
      END IF
      RETURN

      END


!  *******************************************************************
!  *                                                                 *
!  *                    subroutine vnorm                             *
!  *                                                                 *
!  *******************************************************************
!  Single Precision Version 2.21
!  Written by Gordon A. Fenton, TUNS, Mar. 21, 1993.
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  return a vector of N(0,1) random distributed realizations
!
!  Returns a normally distributed, zero mean, unit variance random vector
!  in the argument `g'. `n' is the length of the desired vector.
!
!  Notes:
!   1) Ensure that the random number generator is initialized prior to calling
!      this routine.
!   2) since randu returns random numbers in the range (0,1), excluding
!      the endpoints, we need not guard against taking the log of zero
!      below.
!
!  REVISION HISTORY:
!  2.1	now using new randu function (RAN2 from Numerical Recipes, 2nd Ed)
!	(Oct 14/96)
!  2.2	eliminated unused local variables `zero' and `big' (Dec 5/96)
!  2.21	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!---------------------------------------------------------------------------
      subroutine vnorm( g, n )
      real g(*)
      data twopi/6.2831853071795864769/
      data two/2.0/
!
      nn = n/2
      nn = 2*nn
      do 10 i = 1, nn, 2
         a = twopi*randu(0)
         r = sqrt(-two*alog(randu(0)))
         g(i)   = r*cos(a)
         g(i+1) = r*sin(a)
  10  continue

      if( n .eq. nn ) return
!                                     for n odd, set the last value
      a = twopi*randu(0)
      r = sqrt(-two*alog(randu(0)))
      g(n) = r*cos(a)

      return
      end


!PROGRAM EXAMPLE
!  USE LA_PRECISION, ONLY: WP => SP
!  USE F77_LAPACK, ONLY: LA_GEQRF
!  IMPLICIT NONE
!  CHARACTER(LEN=*), PARAMETER :: FMT = '(7(1X,F9.3))'
!  INTEGER :: I, INFO, LDA, LWORK, M, N
!  REAL(WP), ALLOCATABLE :: A(:,:), TAU(:), WORK(:)
!  M = 5; N = 6; LDA = M; LWORK = -1
!  ALLOCATE( A(M,N), TAU(MIN(M,N)), WORK(MAX(1,N)) )
!  CALL RANDOM_NUMBER(A)
!  CALL LA_GEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!  LWORK = INT(WORK(1)); DEALLOCATE( WORK )
!  ALLOCATE( WORK(LWORK) )
!  CALL LA_GEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!  WRITE(*,*) 'INFO = ', INFO
!  IF( INFO == 0 )THEN
!    WRITE(*,*) 'Matrix A on exit:'
!    DO I = 1, M; WRITE (*,FMT) A(I,:); ENDDO
!  ENDIF
!END PROGRAM EXAMPLE
PROGRAM EXAMPLE
USE LA_PRECISION, ONLY: WP => dp
USE F77_LAPACK, ONLY: LA_GEQRF
IMPLICIT NONE
CHARACTER(LEN=*), PARAMETER :: FMT = '(7(1X,F9.3))'
INTEGER :: I, INFO, LDA, LWORK, M, N
REAL(WP), ALLOCATABLE :: A(:,:), TAU(:), WORK(:)
M = 5; N = 6; LDA = M; LWORK = -1
ALLOCATE( A(M,N), TAU(MIN(M,N)), WORK(MAX(1,N)) )
CALL RANDOM_NUMBER(A)
CALL LA_GEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
LWORK = INT(WORK(1)); DEALLOCATE( WORK )
ALLOCATE( WORK(LWORK) )
CALL LA_GEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
WRITE(*,*) 'INFO = ', INFO
IF( INFO == 0 )THEN
  WRITE(*,*) 'Matrix A on exit:'
  DO I = 1, M; WRITE (*,FMT) A(I,:); ENDDO
ENDIF

stop info

END PROGRAM EXAMPLE


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Last modified 22 August 2014
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Compute the real coefficients of a polynomial
! from its roots
! roots have to be real or in conj complex pairs
!
! uses MPFUN
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! n        (in) problem size
!
! rroots   (in) real parts of the roots
! iroots   (in) imag parts of the roots
!
! coeffs   (out) real coefficients of the polynomial
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine rootstocoeffs(n,rroots,iroots,coeffs)
  use mpmodule
  implicit none

  integer, intent(in):: n
  double precision, intent(in) :: rroots(n), iroots(n)
  double precision, intent(inout) :: coeffs(n)
  type (mp_real) :: rr(n), ir(n), c(n), alpha, beta, zero

  ! compute variables
  integer :: ii, jj

  ! convert to mp-type
  zero = 0.0d0
  do ii=1,n
     rr(ii) = rroots(ii)
     ir(ii) = iroots(ii)
     c(ii)  = 0.0d0
  end do

  ii=1

  do while (ii .LE. n)
     if (ir(ii) .EQ. zero) then
        alpha = -rr(ii)
        do jj=ii,1,-1
           if (jj==1) then
              c(jj) = c(jj) + alpha*1d0
           else
              c(jj) = c(jj) + alpha*c(jj-1)
           end if
        end do
        ii=ii+1
     else
        alpha = - rr(ii)*2
        beta = rr(ii)**2 + ir(ii)**2
        do jj=ii+1,1,-1
           if (jj == 2) then
              c(jj) = c(jj) + alpha*c(jj-1) + beta
           elseif (jj == 1) then
              c(jj) = c(jj) + alpha
           else
              c(jj) = c(jj) + alpha*c(jj-1) + beta*c(jj-2)
           endif
        enddo
        ii=ii+2
     endif
  enddo

  ! convert to double precision
  do ii=1,n
     coeffs(ii) = c(n+1-ii)     ! note n+1-ii which orders for FPML use
  end do

end subroutine rootstocoeffs


program ecuaciones diferenciales
!NO FUNCIONAN LAS SUBRUTINAS POR COMO SE LLAMAA A LA FUNCION, TAMPOCO LO DE REAL*4 Y ESO PERO SI FUNCIONAN TODOS LOS CODIGOS
!-------------------------------------------------
contains
!-------------------------------------------------
subroutine eulerexp(func,xo,yo,a,b,n,y)!funciona el codigo pero no com subrutina
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve el valor de la funcion y en esos puntos.
implicit none
external func
REAL,ALLOCATABLE,DIMENSION(:)::y,x
integer::n,i
real::func,xo,yo,a,b,h
open (10, FILE='intfunEE.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
y(0)=yo+func(xo,yo)*h
do i=0,n
y(i+1)=y(i)+func(x(i),y(i))*h
write(10,*) i,x(i),y(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine eulerimp(func,xo,yo,a,b,n,y)!funciona el codigo pero no com subrutina
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::y,x
integer::n,i
real::func,xo,yo,a,b,h,YY
open (10, FILE='intfunEI.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
YY=yo+func(xo,yo)*h
y(0)=yo+func(xo,yo)*h
do i=0,n
YY=y(i)+func(x(i+1),YY)
y(i+1)=y(i)+func(x(i+1),YY)*h
write(10,*) i,x(i),y(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine midpexp(func,xo,yo,a,b,n,y)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL*8,ALLOCATABLE,DIMENSION(:)::y,x
integer*4::n,i
real*8::func,xo,yo,a,b,h,YY
open (10, FILE='intfunME.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
y(0)=yo
do i=0,n
YY=y(i)+func(x(i)+(h/2),y(i))*(h/2)
y(i+1)=y(i)+func(x(i)+(h/2),YY)*h
write(10,*) i,x(i),y(i)
end do
close(10)
returnend subroutine
!-------------------------------------------------
subroutine midpimp(func,xo,yo,a,b,n,y)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::y,x
integer::n,i
real::func,xo,yo,a,b,h,YY
open (10, FILE='intfunMI.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
y(0)=yo
YY=yo
do i=0,n
YY=y(i)+func(x(i)+(h/2),YY)*(h/2)
y(i+1)=y(i)+func(x(i)+(h/2),YY)*h
write(10,*) i,x(i),y(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine ruegekutta2to(func,xo,yo,a,b,n,y)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::y,x
integer::n,i
real::func,xo,yo,a,b,h,YY
open (10, FILE='intfunRK2TO.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
y(0)=yo
do i=0,n
YY=y(i)+func(x(i),y(i))*h
y(i+1)=y(i)+(func(x(i),y(i))+func(x(i)+h,YY))*(h/2)
write(10,*) i,x(i),y(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine ruegekutta4to(func,xo,yo,a,b,n,y)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::y,x
integer::n,i
real::func,xo,yo,a,b,h,YY1,YY2,YY3,YY4

open (10, FILE='intfunRK4TO.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(x(n+1),y(n+1))
do i=0,n
x(i)=xo+h*i
end do
y(0)=yo
do i=0,n
YY1=func(x(i),y(i))
YY2=y(i)+func(x(i),YY1)*(h/2)
YY3=y(i)+func(x(i),YY2)*(h/2)
YY4=y(i)+func(x(i)+(h/2),YY3)*h
y(i+1)=y(i)+(h/6)*func(x(i),y(i))+(h/3)*func(x(i)+(h/2),YY2)+(h/3)*func(x(i)+(h/2),YY3)+(h/6)*func(x(i),YY4)
write(10,*) i,x(i),y(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine leapfrogDKD(func,xo,vo,a,b,n,x,v)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::x,v
integer::n,i
real::func,xo,vo,a,b,h,VNmid
open (10, FILE='intfuncDKD.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(v(n+1),x(n+1))
x(0)=xo
v(0)=vo
do i=0,n
VNmid=v(i)+func(x(i))*(h/2.)
x(i+1)=x(i)+VNmid*h
v(i+1)=VNmid+func(x(i+1))*(h/2)
write(10,*) i,x(i),v(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
subroutine leapfrogDKD(func,xo,vo,a,b,n,x,v)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::x,v
integer::n,i
real::func,xo,vo,a,b,h,XNmid
open (10, FILE='intfuncKDK.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(v(n+1),x(n+1))
x(0)=xo
v(0)=vo
do i=0,n
XNmid=x(i)+v(i)*(h/2.)
v(i+1)=v(i)+func(XNmid)*h
x(i+1)=XNmid+v(i+1)*(h/2)
write(10,*) i,x(i),v(i)
end do
close(10)
return
end subroutine
!-------------------------------------------------
end


MODULE m_matrixRxR

! ----------------------------------------------------------------------
! MODULE: m_matrixRxR
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the following subroutines
!
! Subroutines contained within the module:
! - matrixRxR
! ----------------------------------------------------------------------
! Author :  Dr. Thomas Papanikolaou
!                 Cooperative Research Centre for Spatial Information, Australia
! Created:  5 March 2018
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE matrixRxR (R1, R2, R3)

! ----------------------------------------------------------------------
! SUBROUTINE: matrixRxR (matrix_RxR.f90)
! ----------------------------------------------------------------------
! Purpose:
!  Multiply 2 arrays
! ----------------------------------------------------------------------
! Input arguments:
! - R1 : Array 1 with dimensions ixj
! - R1 : Array 2 with dimensions nxm
!
! Output arguments:
! - R3 : Array ixm obtained from multiplication R1*R2
! ----------------------------------------------------------------------
! Note:
! Input and Output arguments are allocatable arrays and are declared
! through module mdl_arr.f90
! ----------------------------------------------------------------------
! Thomas D. Papanikolaou, Geoscience Australia              29 June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      !USE mdl_arr
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:), ALLOCATABLE :: R1, R2
! OUT
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: R3
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: R1_i, R1_j, R2_i, R2_j
      INTEGER (KIND = prec_int8) :: i, j, n, m
      REAL (KIND = prec_q) :: R3_ij
      INTEGER (KIND = prec_int2) :: AllocateStatus
!       , DeAllocateStatus
! ----------------------------------------------------------------------

      R1_i = size(R1, dim = 1)
      R1_j = size(R1, dim = 2)

      R2_i = size(R2, dim = 1)
      R2_j = size(R2, dim = 2)

! Allocatable arrays
ALLOCATE (R3(R1_i,R2_j), STAT = AllocateStatus)

      DO i = 1 , R1_i
        DO m = 1 , R2_j
        ! R3(i,m)
          R3_ij = 0.0D0
          DO j = 1 , R1_j
            n = j
                  R3_ij = R1(i,j) * R2(n,m) + R3_ij
          End Do
          R3(i,m) = R3_ij
        End Do
      End Do

END SUBROUTINE

END Module


PROGRAM test_maxval
!
!  Purpose:
!    To test the generic subroutine maxval with five different types
!    of input data sets.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/15/06    S. J. Chapman        Original code
!
USE generic_maxval
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
INTEGER, DIMENSION(6) :: array_i            ! Integer array
REAL(KIND=SGL), DIMENSION(6) :: array_r     ! Sng prec real arr
REAL(KIND=DBL), DIMENSION(6) :: array_d     ! Dbl prec real arr
COMPLEX(KIND=SGL), DIMENSION(6) :: array_c  ! Sing. prec. cx arr
COMPLEX(KIND=DBL), DIMENSION(6) :: array_dc ! Sing. prec. cx arr
INTEGER :: value_max_i                      ! Max value
REAL(KIND=SGL) :: value_max_r               ! Max value
REAL(KIND=DBL) :: value_max_d               ! Max value
INTEGER :: pos_maxval                       ! Pos of max value

! Initialize arrays
array_i  = (/ -13,  3,  2,  0,  25,  -2  /)
array_r  = (/ -13., 3., 2., 0., 25., -2. /)
array_d  = (/ -13._DBL, 3._DBL, 2._DBL, 0._DBL, 25._DBL, -2._DBL /)
array_c  = (/ (1.,2.), (-4.,-6.), (4.,-7), (3.,4.), &
              (0.,1.), (6.,-8.) /)
array_dc = (/ (1._DBL,2._DBL), (-4._DBL,-6._DBL), &
              (4._DBL,-7._DBL), (3._DBL,4._DBL), &
              (0._DBL,1._DBL), (6._DBL,-8._DBL) /)

! Test integer subroutine.  Include optional argument.
CALL maxval ( array_i, 6, value_max_i, pos_maxval )
WRITE (*,1000) value_max_i, pos_maxval
1000 FORMAT (' Integer args: max value = ',I3, &
             ';  position = ', I3 )

! Test SGL prec real subroutine.  Leave out optional arg.
CALL maxval ( array_r, 6, value_max_r )
WRITE (*,1010) value_max_r
1010 FORMAT (' Single prec real args: max value = ',F7.3)

! Test DBL prec real subroutine.  Use keywords.
CALL maxval ( ARRAY=array_d, NVALS=6, VALUE_MAX=value_max_d )
WRITE (*,1020) value_max_d
1020 FORMAT (' Double prec real args: max value = ',F7.3)

! Test SGL prec cmplx subroutine.  Use scrambled keywords.
CALL maxval ( NVALS=6, ARRAY=array_c, VALUE_MAX=value_max_r, &
              POS_MAXVAL=pos_maxval )
WRITE (*,1030) value_max_r, pos_maxval
1030 FORMAT (' Single precision complex args:' &
             ' max abs value = ',F7.3, &
             ';  position = ', I3 )

! Test DBL prec cmplx subroutine.  Leave out optional arg.
CALL maxval ( array_dc, 6, value_max_d )
WRITE (*,1040) value_max_r
1040 FORMAT (' Double precision complex args:' &
             ' max abs value = ',F7.3 )

END PROGRAM test_maxval


program fine_grain

    use omp_lib

    implicit none

    integer :: i, thread_num
    integer(kind=8), parameter :: n = 2**10

    real(kind=8), dimension(n) :: x, y
    real(kind=8) :: norm,ynorm

    integer :: nthreads

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 8
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    ! initialize x:
    !$omp parallel do
    do i=1,n
        x(i) = real(i, kind=8)  ! convert to double float
    enddo

    norm = 0.d0
    ynorm = 0.d0

    !$omp parallel private(i)

    !$omp do reduction(+ : norm)
    do i=1,n
        norm = norm + abs(x(i))
    enddo

    !$omp barrier   ! not needed (implicit)

    !$omp do reduction(+ : ynorm)
    do i=1,n
        y(i) = x(i) / norm
        ynorm = ynorm + abs(y(i))
    enddo

    !$omp end parallel

    print *, "norm of x = ",norm, "  n(n+1)/2 = ",n*(n+1)/2
    print *, 'ynorm should be 1.0:   ynorm = ', ynorm

end program fine_grain


program openmp_pi
  ! use simple pi calculation without random MonteCarlo like calculation
  ! distribute points equally in x-y plane and count the points inside/outside circle

  implicit none

  integer , parameter                     :: x_pts = 100
  integer , parameter                     :: y_pts = 100
  real    , dimension( 0:x_pts )          :: x = 0.0
  real    , dimension( 0:y_pts )          :: y = 0.0
  logical , dimension( 0:x_pts , 0:y_pts) :: inside = .false.
  real                                    :: dx , dy
  integer                                 :: i , j
  integer                                 :: num_inside = 0
  real                                    :: pi
  real                                    :: start , end

  ! spatial distance between points
  dx = 2.0 / x_pts
  dy = 2.0 / y_pts

  !!!!! OPENMP !!!!!
  call cpu_time( start )

  ! construct positions of darts - construct race condition
  !$omp parallel do private(i)
  do i = 0 , x_pts
    x(i) = x(i-1) - 1.0 + i * dx
  enddo
  !$omp end parallel do

  !$omp parallel do private(j)
  do j = 0 , y_pts
    y(j) = -1.0 + j * dy
  enddo
  !$omp end parallel do

  ! check if darts are inside
  !$omp parallel do private(j)
  do i = 0 , x_pts
    do j = 0 , y_pts
      if ( (x(i)**2.0+y(j)**2.0) <= 1.0 ) then
        inside( i , j ) = .true.
      endif
    enddo
  enddo
  !$omp end parallel do

  ! count how many darts inside
  !$omp parallel do private(j) reduction(+:num_inside)
  do i = 0 , x_pts
    do j = 0 , y_pts
      if ( inside( i , j ) ) then
        num_inside = num_inside + 1
      endif
    enddo
  enddo
  !$omp end parallel do

  call cpu_time( end )
  !!!!! OPENMP !!!!!

  pi = 4.0 * ( real(num_inside) / real(x_pts * y_pts))

  write( * , * ) "pi           = " , pi
  write( * , * ) "time elapsed = ", (end-start)

end program openmp_pi


! { dg-do run }

program test_underflow_control
  use ieee_arithmetic
  use iso_fortran_env

  ! kx and ky will be large real kinds, if supported, and single/double
  ! otherwise
  integer, parameter :: kx = &
    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
  integer, parameter :: ky = &
    max(ieee_selected_real_kind(precision(0._kx) + 1), kind(0.d0))

  logical l
  real(kind=kx), volatile :: x
  real(kind=ky), volatile :: y

  if (ieee_support_underflow_control(x)) then

    x = tiny(x)
    call ieee_set_underflow_mode(.true.)
    x = x / 2000._kx
    if (x == 0) call abort
    call ieee_get_underflow_mode(l)
    if (.not. l) call abort

    x = tiny(x)
    call ieee_set_underflow_mode(.false.)
    x = x / 2000._kx
    if (x > 0) call abort
    call ieee_get_underflow_mode(l)
    if (l) call abort

  end if

  if (ieee_support_underflow_control(y)) then

    y = tiny(y)
    call ieee_set_underflow_mode(.true.)
    y = y / 2000._ky
    if (y == 0) call abort
    call ieee_get_underflow_mode(l)
    if (.not. l) call abort

    y = tiny(y)
    call ieee_set_underflow_mode(.false.)
    y = y / 2000._ky
    if (y > 0) call abort
    call ieee_get_underflow_mode(l)
    if (l) call abort

  end if

end program


! { dg-do  run }
! { dg-additional-options "-fno-frontend-optimize -fdump-tree-original" }
program main
  integer, parameter :: A(3,2) = reshape([1,2,3,4,5,6],[3,2])
  integer, parameter :: B(2,3) = reshape([1,1,1,1,1,1],[2,3])
  character (len=30) :: line
  write (unit=line,fmt='(9i3)') matmul(A,B)
  if (line /= '  5  7  9  5  7  9  5  7  9') STOP 1
end program main
!  dg-final { scan-tree-dump-times "matmul_i4" 0 "original" } }


module NNLoss

    integer,parameter,private   :: dp = kind(1.d0)

    contains

    !=================================================================================
    ! ELEMENTAL LOSS FUNCTIONS
    !=================================================================================
    ! Elemental loss
    ! a: estimated, b: expected
    elemental function elementalLoss(estimated,expected,losstype) result(c)
        implicit none

        real(dp),intent(in)         :: estimated,expected
        character(len=*),intent(in) :: losstype
        real(dp)                    :: c

        select case(losstype)
            case("L1")
                c = abs(expected-estimated)

            case("L2")
                c = (expected-estimated)**2

            case("BCE")
                c = maxval([real(dp) :: 0,estimated]) - expected*estimated + log(1.0+exp(-abs(estimated)))
        end select
    end function

    ! Elemental derivative of the loss function
    ! a: estimated, b: expected
    elemental function elementalDeLoss(estimated,expected,losstype) result(c)
        implicit none

        real(dp),intent(in)         :: estimated,expected
        character(len=*),intent(in) :: losstype
        real(dp)                    :: c

        real(dp),parameter          :: threshold = 1E-7

        select case(losstype)
            case("L1")
                c = sign(1.d0,estimated - expected)
            case("L2")
                c = 2*(estimated - expected)
            case("BCE")
                c = estimated - expected

        end select
    end function

    !=================================================================================
    ! TENSOR FUNCTIONS
    !=================================================================================
    ! Gradient of loss function
    function deLoss(estimated,expected,losstype) result(r)
        implicit none

        real(dp),intent(in)     :: estimated(:,:)
        real(dp),intent(in)     :: expected(:,:)
        character(len=*)        :: losstype
        real(dp)                :: r(size(estimated,2),size(estimated,1))

        integer     :: i
        real(dp)    :: t(size(estimated,1),size(estimated,2))

        t = elementalDeLoss(estimated,expected,losstype)
        r = transpose(t)
    end function

end module


submodule(euler_interface_m) euler_prob_0056_m
    use euler_multiprecision_m
    implicit none

contains

    module character(len=20) function euler0056()
        write (euler0056, "(i20)") answer()
    end function euler0056

    function answer() result(ret)
        integer, parameter :: const = 89, ubound = 10
        type(multiprecision_int_t) :: int_arr(ubound)
        integer :: ret, i, j, sum_arr(ubound, ubound)

        int_arr = [(to_long(const + i)**const, i=1, ubound)]
        do j = 1, ubound
            do i = 1, ubound
                int_arr(i) = to_long(const + i)*int_arr(i)
                sum_arr(i, j) = sum(int_arr(i)%arr)
            end do
        end do
        ret = maxval(sum_arr)
    end function answer

end submodule euler_prob_0056_m


c Dummy routine
c supply functions for initialization
c eg: z=hinit(x), z=huinit(x) etc.

c=======================================================================
      function hinit(x)
c
c     function to return the depth, given x
c     this is for the flume mobilization/failure experiments
c=======================================================================

      implicit none

      double precision x,hinit,h,deg2rad
      double precision alpha1,alpha2,alpha3,Depth
      double precision D1,D2,D3,D4,x0,x1,x2,x3,x4

      deg2rad = 3.14159d0/180.d0
      alpha1 = 30.d0*deg2rad
      alpha2 = 10.d0*deg2rad
      alpha3 = 19.d0*deg2rad
      Depth = 0.65

      D1 = Depth/tan(alpha1)
      D2 = 4.d0
      D3 = Depth/tan(alpha2)
      D4 = Depth/tan(alpha3)

      x3 = 0.d0 !gate
      x2 = x3 - D3 ! failure surface
      x1 = x2 - D2 ! back slope
      x0 = x1 - D1 ! start of debris
      x4 = x3 + D4 ! front ramp

      if (x.ge.x3.or.x.le.x0) then
         h = 0.d0
      else
         if (x.ge.x0.and.x.lt.x1) then
            h = (x-x0)*tan(alpha1)
         elseif (x.ge.x1.and.x.lt.x2) then
            h = Depth
         elseif (x.ge.x2.and.x.lt.x3) then
            h = Depth - (x-x2)*tan(alpha2)
         endif
      endif
      hinit = h

      return
      end

c=======================================================================
      function theta_init(x)
c
c     function to return the depth, given x, for the flume hopper
c     uses parameters set in digparams
c=======================================================================

      implicit none

      double precision x,hinit,h,deg2rad
      double precision alpha1,alpha2,alpha3,Depth
      double precision D1,D2,D3,D4,x0,x1,x2,x3,x4

      deg2rad = 3.14159d0/180.d0
      alpha1 = 30.d0
      alpha2 = 10.d0
      alpha3 = 19.d0
      Depth = 0.65

      D1 = Depth/tan(alpha1)
      D2 = 4.d0
      D3 = Depth/tan(alpha2)
      D4 = Depth/tan(alpha3)

      x3 = 0.d0 !gate
      x2 = x3 - D3 ! failure surface
      x1 = x2 - D2 ! back slope
      x0 = x1 - D1 ! start of debris
      x4 = x3 + D4 ! front ramp
      if (x.ge.x4.or.x.le.x2) then
         theta = 31.d0
      else
         if (x.ge.x2.and.x.lt.x3) then
            theta = 31.d0 -alpha2
         elseif (x.ge.x3.and.x.lt.x4) then
            theta = 31.d0 + alpha3
         endif
      endif
      theta_init = theta*deg2rad

      return
      end


      subroutine dad(a, na, i1, i2, j1, j2, r, isw)
c
c!purpose
c
c     dad compute the matrix product a=d*a or a=a*d
c     where d is the matrix with ones on the anti-
c     diagonal and a the input matrix. it also
c     multiplies each element of the product with
c     the constant r
c!calling sequence
c
c     subroutine dad(a, na, i1, i2, j1, j2, r, isw)
c     integer i1, i2, j1, j2, na, isw
c     double precision a, r
c     dimension a(na,*)
c
c     a : input matrix
c
c     na: leading dimension of a
c
c     i1,i2 : the first and the last rows of a to be considered
c
c     j1,j2 : the first and the last columns of a to be considered
c
c     r: constant factor
c
c      isw: parameter specifying the product to be done
c          isw=0 : d*a
c          isw=1 : a*d
c
c!auxiliary routines
c     ifix real mod (fortran)
c!
c
c     Copyright INRIA
      integer i1, i2, j1, j2, na, isw
      double precision a, r
      dimension a(na,*)
c internal variables
c
      integer i1i ,i2i,j1j,j2j,nrd2,ip1,i,j,ncd2
      double precision temp
c
      if (isw.eq.1) go to 60
      if (i1.eq.i2) go to 40
c
      nrd2 = ifix(real((i2-i1+1)/2))
      do 20 j=j1,j2
         do 10 ip1=1,nrd2
            i = ip1 - 1
            i1i = i1 + i
            i2i = i2 - i
            temp = a(i1i,j)
            a(i1i,j) = a(i2i,j)*r
            a(i2i,j) = temp*r
   10    continue
   20 continue
      if (mod(i2-i1,2).eq.1) return
      i = i1 + nrd2
      do 30 j=j1,j2
         a(i,j) = a(i,j)*r
   30 continue
      return
   40 continue
      do 50 j=j1,j2
         a(i1,j) = a(i1,j)*r
   50 continue
      return
c
c
c         computes the product ad where d is as above.
c
c
c
   60 continue
      if (j1.eq.j2) go to 100
      ncd2 = ifix(real((j2-j1+1)/2))
      do 80 jp1=1,ncd2
         j = jp1 - 1
         do 70 i=i1,i2
            j1j = j1 + j
            j2j = j2 - j
            temp = a(i,j1j)
            a(i,j1j) = a(i,j2j)*r
            a(i,j2j) = temp*r
   70    continue
   80 continue
      if (mod(j2-j1,2).eq.1) return
      j = j1 + ncd2
      do 90 i=i1,i2
         a(i,j) = a(i,j)*r
   90 continue
      return
  100 continue
      do 110 i=i1,i2
         a(i,j1) = a(i,j1)*r
  110 continue
      return
      end


! encode_mod.f90 -- module for encoding and decoding state vectors
!
! Copyright (C) 2008 Jason Blevins <jrblevin@sdf.lonestar.org>
! All rights reserved.
!
! This software may be modified and distributed under the terms
! of the BSD license.  See the LICENSE file for details.
!
! Description:
!
! This is a Fortran 2003 implementation of the "probability density"
! encoding algorithm presented in the following article:
!
!   Gowrisankaran, G. (1999). "Efficient representation of state
!   spaces for some dynamic models."  Journal of Economic Dynamics and
!   Control 23 (8), 1077-1098.
!
! This module implements an encoding of the state space $Z(N,M)$
! consisting of all discrete approximations to probability
! distributions on the interval $[0,1]$ with $N-1$ discrete regions
! and $N$ endpoints.  The mass assigned to any of these $N$ endpoints
! may take $M$ discrete values $0/(M-1), 1/(M-1), \dots, (M-1)/(M-1)$
! such that the elements sum to one.
!
! This encoding can be used, for example, to represent the space of
! all probability distributions or to represent the state space in a
! dynamic oligopoly model such as that of Ericson and Pakes (1995).
! In the dynamic oligopoly example, with $n$ firms and $L$ possible
! states, one can represent the state space using $Z(L,n+1)$.  The
! $k$-th element of the state vector then represents the fraction of
! firms in state $k$.

module encode_mod
  implicit none
  private

  public :: encode_init, encode_free
  public :: encode, decode
  public :: n_state

  integer, dimension(:,:), allocatable :: table   ! encoding table
  integer :: N_                                   ! number of endpoints
  integer :: M_                                   ! sum of values
  integer :: n_state                              ! number of states

contains

  ! Initializes the encoding table.
  subroutine encode_init(N, M)
    integer, intent(in) :: N, M
    integer :: i, j
    N_ = N
    M_ = M
    allocate(table(N,M))
    table(1,:) = 1
    table(:,1) = 1
    do i = 2, N
       do j = 2, M
          table(i,j) = table(i-1,j) + table(i, j-1)
       end do
    end do

    ! Cardinality of the state space (see Theorem 1, pg. 1084).
    n_state = table(N_, M_)
  end subroutine encode_init

  ! Frees memory used by the encoding table.
  subroutine encode_free
    deallocate(table)
  end subroutine encode_free

  ! Bijectively maps elements of the state space to integers from 0 to
  ! n_state - 1.
  function encode(x) result(enc)
    integer, dimension(N_), intent(in) :: x
    integer :: enc
    integer :: i, xsum, idx

    enc = 0
    xsum = 0
    do i = 1, N_
       idx = N_ - i + 1
       enc = enc + table(idx, M_ - xsum)
       xsum = xsum + x(i)
       enc = enc - table(idx, M_ - xsum)
    end do
  end function encode

  ! Bijectively maps the integers from 0 to n_state to vectors in the
  ! state space.
  function decode(ix) result(x)
    integer, intent(in) :: ix
    integer, dimension(N_) :: x
    integer :: digit, xsum, i, j, idx, code, enc

    x = 0
    code = ix
    xsum = 0
    do i = 1, N_
       idx = N_ - i + 1
       digit = 0

       ! Search for the largest valid digit that would result in an
       ! encoded value no larger the encoded value ix (see pg. 1088).
       do j = 1, M_ - 1 - xsum
          enc = table(idx, M_ - xsum) - table(idx, M_ - xsum - j)
          if (enc <= code) then
             digit = j
          end if
       end do

       ! Use the remainder of the encoded value to find the next digit.
       code = code - (table(idx, M_ - xsum) - table(idx, M_ - xsum - digit))
       x(i) = digit
       xsum = xsum + x(i)
    end do
  end function decode

end module encode_mod


c function pgauss.f
c
c source
c   Bevington, page 45.
c
c purpose
c   evaluate gaussian probability function
c
c usage
c   result = pgauss (x, averag, sigma)
c
c description of parameters
c   x      - value for which probability is to be evaluated
c   averag - mean of distribution
c   sigma  - standard deviation of distribution
c
c subroutines and function subprograms required
c   none
c
	function pgauss (x,averag,sigma)
	double precision z
1	z=(x-averag)/sigma
2	pgauss=0.3989422804/sigma*dexp(-(z**2)/2.)
	return
	end


Real Function pinsg0(srt)
  Save
  srt0 = 0.938 + 2.*0.498
  If (srt<srt0) Then
    pinsg0 = 0.0
    Return
  End If
  ratio = srt0**2/srt**2
  pinsg0 = 1.121*(1.-ratio)**1.86*ratio**2
  Return
End Function pinsg0


! Consider using unformatted stream I/O introduced in Fortran 2003 for
! large data sets. Formatted I/O converts numerical data to and from ASCII
! and is much slower than unformatted. This program times the writing and
! reading of 10^7 double precision floats using formatted and unformatted
! stream I/O. The elapsed times of the program on my Windows PC compiled
! with gfortran -O3 are below. Unformatted stream write and read were
! 25 and 260 times faster than formatted.
!
!   formatted   formatted unformatted unformatted
!       write        read       write        read
!      7.5000      8.1100      0.2970      0.0310
!
program stream_io
implicit none
integer, parameter :: wp = kind(1.0d0), n = 10**7
real(kind=wp)      :: x(n),xchk(n)
integer            :: iunit,irate,times(6)
call system_clock(count_rate = irate) ! get the # of clock ticks per second
print*,"n =",n
call random_number(x)
call system_clock(count = times(1))
! use formatted write and read
open (newunit=iunit,file="temp.txt",action="write",status="replace")
write (iunit,"(f0.16)") x
close (iunit)
call system_clock(count = times(2)) ! (times(2) - times(1))/irate = time elapsed (s) for formatted write
open (newunit=iunit,file="temp.txt",action="read",status="old")
read (iunit,*) xchk ! list-directed read with the * gets data from as many lines are needed
call system_clock(count = times(3))
print*,maxval(x-xchk),minval(x),maxval(x),minval(xchk),maxval(xchk) ! check that data read back correctly
call system_clock(count = times(4))
! use unformatted stream write and read
open (newunit=iunit,file="temp.bin",action="write",status="replace",form="unformatted",access="stream")
write (iunit) x ! no format supplied for unformatted I/O
close (iunit)
call system_clock(count = times(5))
open (newunit=iunit,file="temp.bin",action="read",status="old",form="unformatted",access="stream")
read (iunit) xchk
call system_clock(count = times(6))
print*,maxval(x-xchk),minval(x),maxval(x),minval(xchk),maxval(xchk)
write (*,"(/,*(a12))") "formatted","formatted","unformatted","unformatted"
write (*,"(*(a12))") "write","read","write","read"
write (*,"(*(f12.4))") [times(2:3)-times(1:2),times(5:6)-times(4:5)]/real(irate) ! count differences divided by count_rate equal seconds elapsed
end program stream_io


c      program P0204
c>> 1997-06-20 Krogh Generate plots for ch02-04.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = -10.0E0, XB = 15.0E0)
      parameter (XSIZE=3.0E0, YSIZE=2.5E0)
      real YMIN
      parameter (YMIN = -1.5E0)
      real DX, OPT(23), OPT2(8), X(MAXPT), Y(MAXPT, 2)
      external SBESJ0, SBESJ1, SBESY0, SBESY1
      real SBESJ0, SBESJ1, SBESY0, SBESY1
      integer I
      character COPT*54
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1  PLOYMX=9.E0)
      data OPT / 0.E0,  PLONY, RMAXPT, 2.E0, PLOTXT, -4.E0, .8E0, 0.E0,
     1   PLOTXT, -3.8E0, -.75E0, 0.E0, PLOTXT, -3.0E0, -1.25E0, 0.E0,
     2   PLOTXT, 1.E0, -1.4E0, 0.E0, PLOUNI, 3.E0, 0.E0 /
      data COPT /
     1  'F{pl02-04.tex}{$J_0(x)$}{$J_1(x)$}{$Y_0(x)$}{$Y_1(x)$}'/
      data OPT2 / 0.E0, PLONY, RMAXPT, 2.E0, PLOYMX, YMIN,
     1  1.0E0, 0.E0 /
c
      DX = (XB - XA) / (MAXPT - 1)
      do 100 I = 1, MAXPT
         X(I) = XA + real(I - 1) * DX
         Y(I,1) = SBESJ0(X(I))
         Y(I,2) = SBESJ1(X(I))
  100 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPT)
      DX = (XB - 0.E0) / (MAXPT)
      do 200 I = 1, MAXPT
         X(I) = real(I) * DX
         Y(I,1) = max(SBESY0(X(I)), YMIN - .5E0)
         Y(I,2) = max(SBESY1(X(I)), YMIN - .5E0)
  200 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT2, 'Q')
      stop
      end


!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis

SUBROUTINE Intplt2(p,x,vin,vout)

!==========================================================
!  This routine interpolates a value using a second order
!  scheme.
!
!  Input:
!	p: position where to interpolate;
!	x: positions of 2 grid points;
!	vin: input grid values;
!  Output:
!	vout: interpolated value;
!
!  Reference: intpl2.doc on MAC notebook.
!
!  HISTORY:
!	JUL. 2006 by YUANFU XIE.
!==========================================================

  IMPLICIT NONE

  REAL, INTENT(IN) :: p,x(2),vin(2)
  REAL, INTENT(OUT) :: vout

  INTEGER :: i,j
  REAL :: e(2),r,b,c

  ! Check the 4 grid points:
  DO i=1,2
    DO j=1,2
      IF ((i .NE. j) .AND. &
        (ABS(x(i)-x(j)) .LT. 1.0e-5*x(i) ) ) THEN
        PRINT*,'Intplt2: There are overlap gridpoints, STOP'
	STOP
      ENDIF
    ENDDO
  ENDDO

  DO i=1,2
    IF (ABS(p-x(i)) .LT. 1.0e-5*MAXVAL(x) ) THEN
      e = 0.0
      e(i) = 1.0
      GOTO 1
    ENDIF
  ENDDO

  ! e2:
  e(2) = (p-x(1))/(x(2)-x(1))

  ! e1:
  e(1) = 1.0-e(2)

1 CONTINUE

  ! Interpolate:
  vout = 0.0
  DO i=1,2
    vout = vout+e(i)*vin(i)
  ENDDO

END SUBROUTINE Intplt2

SUBROUTINE Intplt4(p,x,vin,vout)

!==========================================================
!  This routine interpolates a value using a fourth order
!  scheme.
!
!  Input:
!	p: position where to interpolate;
!	x: positions of 4 grid points;
!	vin: input grid values;
!  Output:
!	vout: interpolated value;
!
!  Reference: intpl2.doc on MAC notebook.
!
!  HISTORY:
!	JUL. 2006 by YUANFU XIE.
!==========================================================

  IMPLICIT NONE

  REAL, INTENT(IN) :: p,x(4),vin(4)
  REAL, INTENT(OUT) :: vout

  INTEGER :: i,j
  REAL :: e(4),r,b,c

  ! Check the 4 grid points:
  DO i=1,4
    DO j=1,4
      IF ((i .NE. j) .AND. &
        (ABS(x(i)-x(j)) .LT. 1.0e-5*x(i) ) ) THEN
        PRINT*,'Intplt4: There are overlap gridpoints, STOP'
	STOP
      ENDIF
    ENDDO
  ENDDO

  DO i=1,4
    IF (ABS(p-x(i)) .LT. 1.0e-5*MAXVAL(x) ) THEN
      e = 0.0
      e(i) = 1.0
      GOTO 1
    ENDIF
  ENDDO

  ! e4:
  r = 1.0
  c = 1.0
  DO i=1,3
    r = r*(p   -x(i))
    c = c*(x(4)-x(i))
  ENDDO
  e(4) = r/c

  ! e3:
  r = 1.0
  b = 1.0
  c = 1.0
  DO i=1,2
    r = r*(p   -x(i))
    c = c*(x(4)-x(i))
    b = b*(x(3)-x(i))
  ENDDO
  e(3) = (r-c*e(4))/b

  ! e2:
  e(2) = (p-x(1)-(x(4)-x(1))*e(4)-(x(3)-x(1))*e(3))/(x(2)-x(1))

  ! e1:
  e(1) = 1.0-e(2)-e(3)-e(4)

1 CONTINUE

  ! Interpolate:
  vout = 0.0
  DO i=1,4
    vout = vout+e(i)*vin(i)
  ENDDO

END SUBROUTINE Intplt4


        SUBROUTINE LQMNS(M,N,X,QM,QD)
c**************************************************************
C
C       ========================================================
C       Purpose: Compute associated Legendre functions Qmn(x)
C                and Qmn'(x) for a given order
C       Input :  x --- Argument of Qmn(x)
C                m --- Order of Qmn(x),  m = 0,1,2,...
C                n --- Degree of Qmn(x), n = 0,1,2,...
C       Output:  QM(n) --- Qmn(x)
C                QD(n) --- Qmn'(x)
C       ========================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION QM(0:N),QD(0:N)
        DO 10 K=0,N
           QM(K)=0.0D0
10         QD(K)=0.0D0
        IF (DABS(X).EQ.1.0D0) THEN
           DO 15 K=0,N
              QM(K)=1.0D+300
15            QD(K)=1.0D+300
           RETURN
        ENDIF
        LS=1
        IF (DABS(X).GT.1.0D0) LS=-1
        XQ=DSQRT(LS*(1.0D0-X*X))
        Q0=0.5D0*DLOG(DABS((X+1.0)/(X-1.0)))
        Q00=Q0
        Q10=-1.0D0/XQ
        Q01=X*Q0-1.0D0
        Q11=-LS*XQ*(Q0+X/(1.0D0-X*X))
        QF0=Q00
        QF1=Q10
        DO 20 K=2,M
           QM0=-2.0D0*(K-1.0)/XQ*X*QF1-LS*(K-1.0)*(2.0-K)*QF0
           QF0=QF1
20         QF1=QM0
        IF (M.EQ.0) QM0=Q00
        IF (M.EQ.1) QM0=Q10
        QM(0)=QM0
        IF (DABS(X).LT.1.0001D0) THEN
           IF (M.EQ.0.AND.N.GT.0) THEN
              QF0=Q00
              QF1=Q01
              DO 25 K=2,N
                 QF2=((2.0*K-1.0D0)*X*QF1-(K-1.0)*QF0)/K
                 QM(K)=QF2
                 QF0=QF1
25               QF1=QF2
           ENDIF
           QG0=Q01
           QG1=Q11
           DO 30 K=2,M
              QM1=-2.0D0*(K-1.0)/XQ*X*QG1-LS*K*(3.0-K)*QG0
              QG0=QG1
30            QG1=QM1
           IF (M.EQ.0) QM1=Q01
           IF (M.EQ.1) QM1=Q11
           QM(1)=QM1
           IF (M.EQ.1.AND.N.GT.1) THEN
              QH0=Q10
              QH1=Q11
              DO 35 K=2,N
                 QH2=((2.0*K-1.0D0)*X*QH1-K*QH0)/(K-1.0)
                 QM(K)=QH2
                 QH0=QH1
35               QH1=QH2
           ELSE IF (M.GE.2) THEN
              QG0=Q00
              QG1=Q01
              QH0=Q10
              QH1=Q11
              DO 45 L=2,N
                 Q0L=((2.0D0*L-1.0D0)*X*QG1-(L-1.0D0)*QG0)/L
                 Q1L=((2.0*L-1.0D0)*X*QH1-L*QH0)/(L-1.0D0)
                 QF0=Q0L
                 QF1=Q1L
                 DO 40 K=2,M
                    QMK=-2.0D0*(K-1.0)/XQ*X*QF1-LS*(K+L-1.0)*
     &                  (L+2.0-K)*QF0
                    QF0=QF1
40                  QF1=QMK
                 QM(L)=QMK
                 QG0=QG1
                 QG1=Q0L
                 QH0=QH1
45               QH1=Q1L
           ENDIF
        ELSE
           IF (DABS(X).GT.1.1) THEN
              KM=40+M+N
           ELSE
              KM=(40+M+N)*INT(-1.0-1.8*LOG(X-1.0))
           ENDIF
           QF2=0.0D0
           QF1=1.0D0
           DO 50 K=KM,0,-1
              QF0=((2.0*K+3.0D0)*X*QF1-(K+2.0-M)*QF2)/(K+M+1.0)
              IF (K.LE.N) QM(K)=QF0
              QF2=QF1
50            QF1=QF0
           DO 55 K=0,N
55            QM(K)=QM(K)*QM0/QF0
        ENDIF
        IF (DABS(X).LT.1.0D0) THEN
           DO 60 K=0,N
60            QM(K)=(-1)**M*QM(K)
        ENDIF
        QD(0)=((1.0D0-M)*QM(1)-X*QM(0))/(X*X-1.0)
        DO 65 K=1,N
65         QD(K)=(K*X*QM(K)-(K+M)*QM(K-1))/(X*X-1.0)
        RETURN
        END


	SUBROUTINE SNDRHF ( prs, tmp, dwp, relh )
C************************************************************************
C* SNDRHF								*
C*									*
C* This routine will compute the relative humidity.			*
C*									*
C* SNDRHF ( PRS, TMP, DWP, RELH )					*
C*									*
C* Input parameters:							*
C*	PRS		REAL		Pressure			*
C*	TMP		REAL		Temperature			*
C*	DWP		REAL		Dewpoint			*
C*									*
C* Output parameters:							*
C*	RELH		REAL		Relative humidity		*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		prs, tmp, dwp, relh
C*
	DATA		const3 / 0.003661 /
C------------------------------------------------------------------------
C*	Functions.
C
	XLEVAP(t) = 597.3 - .566 * (t - 273.15)
	SATVAP(t) = 6.11 * EXP( 9.045 * xlevap(t) * (const3 - 1. / t) )
	WFUN(e)   = .622 * e / ( p - e )
C
	p  = FLOAT ( prs )
	t  = FLOAT ( tmp )
	td = FLOAT ( dwp )
C
	esat = SATVAP ( t )
	e    = SATVAP ( td )
	wsat = WFUN ( esat )
	w    = WFUN ( e )
	relh = INT ( ( w / wsat ) * 100. )
C*
	RETURN
	END


	SUBROUTINE initialdata(Nx,Ny,Nz,x,y,z,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets initial data for nonlinear Klein-Gordon equation
	! in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*u^3+
	!
	! The boundary conditions are u(x=-Lx*\pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*\pi,z)=u(x,y=Ly*\pi,z),u(x,y,z=-Ly*\pi)=u(x,y,z=Ly*\pi)
	! The initial condition is u=0.5*exp(-x^2-y^2-z^2)*sin(10*x+12*y)
	!
	! INPUT
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	! .. Vectors ..
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= initial solution
	!  uold 			= approximate solution based on time derivative of
	!					initial solution
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny,Nz
	REAL(KIND=8), DIMENSION(1:NX), INTENT(IN) 			:: x
	REAL(KIND=8), DIMENSION(1:NY), INTENT(IN) 			:: y
	REAL(KIND=8), DIMENSION(1:NZ), INTENT(IN) 			:: z
	COMPLEX(KIND=8), DIMENSION(1:NX,1:NY,1:NZ), INTENT(OUT)	:: u,uold
	INTEGER(kind=4)										:: i,j,k
	!$OMP PARALLEL DO PRIVATE(i,j) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				u(i,j,k)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))!*&
					!sin(10.0d0*x(i)+12.0d0*y(j))
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO PRIVATE(i,j) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				uold(i,j,k)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))!*&
					!sin(10.0d0*x(i)+12.0d0*y(j))
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO

	END SUBROUTINE initialdata


! Copyright 2019 NREL

! Licensed under the Apache License, Version 2.0 (the "License"); you may not use
! this file except in compliance with the License. You may obtain a copy of the
! License at http://www.apache.org/licenses/LICENSE-2.0

! Unless required by applicable law or agreed to in writing, software distributed
! under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
! CONDITIONS OF ANY KIND, either express or implied. See the License for the
! specific language governing permissions and limitations under the License.
! -------------------------------------------------------------------------------------------
! This module contains all the filters and related subroutines

! Filters:
!       LPFilter: Low-pass filter
!       SecLPFilter: Second order low-pass filter
!       HPFilter: High-pass filter
!       NotchFilter: Notch filter
!       NotchFilterSlopes: Notch Filter with descending slopes
!       PreFilterMeasuredSignals: Pre-filter signals during each run iteration

MODULE Filters
!...............................................................................................................................
    USE Constants
    IMPLICIT NONE

CONTAINS
!-------------------------------------------------------------------------------------------------------------------------------
    REAL FUNCTION LPFilter(InputSignal, DT, CornerFreq, iStatus, reset, inst)
    ! Discrete time Low-Pass Filter of the form:
    !                               Continuous Time Form:   H(s) = CornerFreq/(1 + CornerFreq)
    !                               Discrete Time Form:     H(z) = (b1z + b0) / (a1*z + a0)
    !
        REAL(8), INTENT(IN)         :: InputSignal
        REAL(8), INTENT(IN)         :: DT                       ! time step [s]
        REAL(8), INTENT(IN)         :: CornerFreq               ! corner frequency [rad/s]
        INTEGER(4), INTENT(IN)      :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(4), INTENT(INOUT)   :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)      :: reset                    ! Reset the filter to the input signal

            ! Local
        REAL(8), DIMENSION(99), SAVE    :: a1                   ! Denominator coefficient 1
        REAL(8), DIMENSION(99), SAVE    :: a0                   ! Denominator coefficient 0
        REAL(8), DIMENSION(99), SAVE    :: b1                    ! Numerator coefficient 1
        REAL(8), DIMENSION(99), SAVE    :: b0                    ! Numerator coefficient 0

        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast      ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast ! Output signal the last time this filter was called. Supports 99 separate instances.

            ! Initialization
        IF ((iStatus == 0) .OR. reset) THEN
            OutputSignalLast(inst) = InputSignal
            InputSignalLast(inst) = InputSignal
            a1(inst) = 2 + CornerFreq*DT
            a0(inst) = CornerFreq*DT - 2
            b1(inst) = CornerFreq*DT
            b0(inst) = CornerFreq*DT
        ENDIF

        ! Define coefficients

        ! Filter
        LPFilter = 1.0/a1(inst) * (-a0(inst)*OutputSignalLast(inst) + b1(inst)*InputSignal + b0(inst)*InputSignalLast(inst))

        ! Save signals for next time step
        InputSignalLast(inst)  = InputSignal
        OutputSignalLast(inst) = LPFilter
        inst = inst + 1

    END FUNCTION LPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL FUNCTION SecLPFilter(InputSignal, DT, CornerFreq, Damp, iStatus, reset, inst)
    ! Discrete time Low-Pass Filter of the form:
    !                               Continuous Time Form:   H(s) = CornerFreq^2/(s^2 + 2*CornerFreq*Damp*s + CornerFreq^2)
    !                               Discrete Time From:     H(z) = (b2*z^2 + b1*z + b0) / (a2*z^2 + a1*z + a0)
        REAL(8), INTENT(IN)         :: InputSignal
        REAL(8), INTENT(IN)         :: DT                       ! time step [s]
        REAL(8), INTENT(IN)         :: CornerFreq               ! corner frequency [rad/s]
        REAL(8), INTENT(IN)         :: Damp                     ! Dampening constant
        INTEGER(4), INTENT(IN)      :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(4), INTENT(INOUT)   :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)      :: reset                    ! Reset the filter to the input signal

        ! Local
        REAL(8), DIMENSION(99), SAVE    :: a2                   ! Denominator coefficient 2
        REAL(8), DIMENSION(99), SAVE    :: a1                   ! Denominator coefficient 1
        REAL(8), DIMENSION(99), SAVE    :: a0                   ! Denominator coefficient 0
        REAL(8), DIMENSION(99), SAVE    :: b2                   ! Numerator coefficient 2
        REAL(8), DIMENSION(99), SAVE    :: b1                   ! Numerator coefficient 1
        REAL(8), DIMENSION(99), SAVE    :: b0                   ! Numerator coefficient 0
        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast1     ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast2     ! Input signal the next to last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast1    ! Output signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast2    ! Output signal the next to last time this filter was called. Supports 99 separate instances.

        ! Initialization
        IF ((iStatus == 0) .OR. reset )  THEN
            OutputSignalLast1(inst)  = InputSignal
            OutputSignalLast2(inst)  = InputSignal
            InputSignalLast1(inst)   = InputSignal
            InputSignalLast2(inst)   = InputSignal

            ! Coefficients
            a2(inst) = DT**2.0*CornerFreq**2.0 + 4.0 + 4.0*Damp*CornerFreq*DT
            a1(inst) = 2.0*DT**2.0*CornerFreq**2.0 - 8.0
            a0(inst) = DT**2.0*CornerFreq**2.0 + 4.0 - 4.0*Damp*CornerFreq*DT
            b2(inst) = DT**2.0*CornerFreq**2.0
            b1(inst) = 2.0*DT**2.0*CornerFreq**2.0
            b0(inst) = DT**2.0*CornerFreq**2.0
        ENDIF

        ! Filter
        SecLPFilter = 1.0/a2(inst) * (b2(inst)*InputSignal + b1(inst)*InputSignalLast1(inst) + b0(inst)*InputSignalLast2(inst) - a1(inst)*OutputSignalLast1(inst) - a0(inst)*OutputSignalLast2(inst))

        ! SecLPFilter = 1/(4+4*DT*Damp*CornerFreq+DT**2*CornerFreq**2) * ( (8-2*DT**2*CornerFreq**2)*OutputSignalLast1(inst) &
        !                 + (-4+4*DT*Damp*CornerFreq-DT**2*CornerFreq**2)*OutputSignalLast2(inst) + (DT**2*CornerFreq**2)*InputSignal &
        !                     + (2*DT**2*CornerFreq**2)*InputSignalLast1(inst) + (DT**2*CornerFreq**2)*InputSignalLast2(inst) )

        ! Save signals for next time step
        InputSignalLast2(inst)   = InputSignalLast1(inst)
        InputSignalLast1(inst)   = InputSignal
        OutputSignalLast2(inst)  = OutputSignalLast1(inst)
        OutputSignalLast1(inst)  = SecLPFilter

        inst = inst + 1

    END FUNCTION SecLPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL FUNCTION HPFilter( InputSignal, DT, CornerFreq, iStatus, reset, inst)
    ! Discrete time High-Pass Filter

        REAL(8), INTENT(IN)     :: InputSignal
        REAL(8), INTENT(IN)     :: DT                       ! time step [s]
        REAL(8), INTENT(IN)     :: CornerFreq               ! corner frequency [rad/s]
        INTEGER, INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER, INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal
        ! Local
        REAL(8)                         :: K                        ! Constant gain
        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast      ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast ! Output signal the last time this filter was called. Supports 99 separate instances.

        ! Initialization
        IF ((iStatus == 0) .OR. reset)  THEN
            OutputSignalLast(inst) = InputSignal
            InputSignalLast(inst) = InputSignal
        ENDIF
        K = 2.0 / DT

        ! Body
        HPFilter = K/(CornerFreq + K)*InputSignal - K/(CornerFreq + K)*InputSignalLast(inst) - (CornerFreq - K)/(CornerFreq + K)*OutputSignalLast(inst)

        ! Save signals for next time step
        InputSignalLast(inst)   = InputSignal
        OutputSignalLast(inst)  = HPFilter
        inst = inst + 1

    END FUNCTION HPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL FUNCTION NotchFilterSlopes(InputSignal, DT, CornerFreq, Damp, iStatus, reset, inst)
    ! Discrete time inverted Notch Filter with descending slopes, G = CornerFreq*s/(Damp*s^2+CornerFreq*s+Damp*CornerFreq^2)

        REAL(8), INTENT(IN)     :: InputSignal
        REAL(8), INTENT(IN)     :: DT                       ! time step [s]
        REAL(8), INTENT(IN)     :: CornerFreq               ! corner frequency [rad/s]
        REAL(8), INTENT(IN)     :: Damp                     ! Dampening constant
        INTEGER, INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER, INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal
        ! Local
        REAL(8), DIMENSION(99), SAVE :: b2, b0, a2, a1, a0    ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE :: InputSignalLast1    ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE :: InputSignalLast2    ! Input signal the next to last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE :: OutputSignalLast1   ! Output signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE :: OutputSignalLast2   ! Output signal the next to last time this filter was called. Supports 99 separate instances.

        ! Initialization
        IF ((iStatus == 0) .OR. reset) THEN
            OutputSignalLast1(inst)  = InputSignal
            OutputSignalLast2(inst)  = InputSignal
            InputSignalLast1(inst)   = InputSignal
            InputSignalLast2(inst)   = InputSignal
            b2(inst) = 2.0 * DT * CornerFreq
            b0(inst) = -b2(inst)
            a2(inst) = Damp*DT**2.0*CornerFreq**2.0 + 2.0*DT*CornerFreq + 4.0*Damp
            a1(inst) = 2.0*Damp*DT**2.0*CornerFreq**2.0 - 8.0*Damp
            a0(inst) = Damp*DT**2.0*CornerFreq**2.0 - 2*DT*CornerFreq + 4.0*Damp
        ENDIF

        NotchFilterSlopes = 1.0/a2(inst) * (b2(inst)*InputSignal + b0(inst)*InputSignalLast2(inst) &
                            - a1(inst)*OutputSignalLast1(inst)  - a0(inst)*OutputSignalLast2(inst))
        ! Body
        ! NotchFilterSlopes = 1.0/(4.0+2.0*DT*Damp*CornerFreq+DT**2.0*CornerFreq**2.0) * ( (8.0-2.0*DT**2.0*CornerFreq**2.0)*OutputSignalLast1(inst) &
        !                 + (-4.0+2.0*DT*Damp*CornerFreq-DT**2.0*CornerFreq**2.0)*OutputSignalLast2(inst) + &
        !                     (2.0*DT*Damp*CornerFreq)*InputSignal + (-2.0*DT*Damp*CornerFreq)*InputSignalLast2(inst) )

        ! Save signals for next time step
        InputSignalLast2(inst)   = InputSignalLast1(inst)
        InputSignalLast1(inst)   = InputSignal          !Save input signal for next time step
        OutputSignalLast2(inst)  = OutputSignalLast1(inst)      !Save input signal for next time step
        OutputSignalLast1(inst)  = NotchFilterSlopes
        inst = inst + 1

    END FUNCTION NotchFilterSlopes
!-------------------------------------------------------------------------------------------------------------------------------
    REAL FUNCTION NotchFilter(InputSignal, DT, omega, betaNum, betaDen, iStatus, reset, inst)
    ! Discrete time Notch Filter
    !                               Continuous Time Form: G(s) = (s^2 + 2*omega*betaNum*s + omega^2)/(s^2 + 2*omega*betaDen*s + omega^2)
    !                               Discrete Time Form:   H(z) = (b2*z^2 +b1*z^2 + b0*z)/((z^2 +a1*z^2 + a0*z))

        REAL(8), INTENT(IN)     :: InputSignal
        REAL(8), INTENT(IN)     :: DT                       ! time step [s]
        REAL(8), INTENT(IN)     :: omega                    ! corner frequency [rad/s]
        REAL(8), INTENT(IN)     :: betaNum                  ! Dampening constant in numerator of filter transfer function
        REAL(8), INTENT(IN)     :: betaDen                  ! Dampening constant in denominator of filter transfer function
        INTEGER, INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER, INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal
        ! Local
        REAL(8), DIMENSION(99), SAVE    :: K, b2, b1, b0, a1, a0    ! Constant gain
        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast1         ! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: InputSignalLast2         ! Input signal the next to last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast1        ! Output signal the last time this filter was called. Supports 99 separate instances.
        REAL(8), DIMENSION(99), SAVE    :: OutputSignalLast2        ! Output signal the next to last time this filter was called. Supports 99 separate instances.

        ! Initialization
        IF ((iStatus == 0) .OR. reset) THEN
            OutputSignalLast1(inst)  = InputSignal
            OutputSignalLast2(inst)  = InputSignal
            InputSignalLast1(inst)   = InputSignal
            InputSignalLast2(inst)   = InputSignal
            K(inst) = 2.0/DT
            b2(inst) = (K(inst)**2.0 + 2.0*omega*BetaNum*K(inst) + omega**2.0)/(K(inst)**2.0 + 2.0*omega*BetaDen*K(inst) + omega**2.0)
            b1(inst) = (2.0*omega**2.0 - 2.0*K(inst)**2.0)  / (K(inst)**2.0 + 2.0*omega*BetaDen*K(inst) + omega**2.0);
            b0(inst) = (K(inst)**2.0 - 2.0*omega*BetaNum*K(inst) + omega**2.0) / (K(inst)**2.0 + 2.0*omega*BetaDen*K(inst) + omega**2.0)
            a1(inst) = (2.0*omega**2.0 - 2.0*K(inst)**2.0)  / (K(inst)**2.0 + 2.0*omega*BetaDen*K(inst) + omega**2.0)
            a0(inst) = (K(inst)**2.0 - 2.0*omega*BetaDen*K(inst) + omega**2.0)/ (K(inst)**2.0 + 2.0*omega*BetaDen*K(inst) + omega**2.0)
        ENDIF

        ! Body
        NotchFilter = b2(inst)*InputSignal + b1(inst)*InputSignalLast1(inst) + b0(inst)*InputSignalLast2(inst) - a1(inst)*OutputSignalLast1(inst) - a0(inst)*OutputSignalLast2(inst)

        ! Save signals for next time step
        InputSignalLast2(inst)   = InputSignalLast1(inst)
        InputSignalLast1(inst)   = InputSignal                  ! Save input signal for next time step
        OutputSignalLast2(inst)  = OutputSignalLast1(inst)      ! Save input signal for next time step
        OutputSignalLast1(inst)  = NotchFilter
        inst = inst + 1

    END FUNCTION NotchFilter
!-------------------------------------------------------------------------------------------------------------------------------
    SUBROUTINE PreFilterMeasuredSignals(CntrPar, LocalVar, objInst)
    ! Prefilter measured wind turbine signals to separate the filtering from the actual control actions

        USE ROSCO_Types, ONLY : ControlParameters, LocalVariables, ObjectInstances

        TYPE(ControlParameters), INTENT(INOUT)  :: CntrPar
        TYPE(LocalVariables), INTENT(INOUT)     :: LocalVar
        TYPE(ObjectInstances), INTENT(INOUT)    :: objInst

        ! Filter the HSS (generator) and LSS (rotor) speed measurement:
        ! Apply Low-Pass Filter (choice between first- and second-order low-pass filter)
        IF (CntrPar%F_LPFType == 1) THEN
            LocalVar%GenSpeedF = LPFilter(LocalVar%GenSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, LocalVar%iStatus, .FALSE., objInst%instLPF)
            LocalVar%RotSpeedF = LPFilter(LocalVar%RotSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, LocalVar%iStatus, .FALSE., objInst%instLPF)
        ELSEIF (CntrPar%F_LPFType == 2) THEN
            LocalVar%GenSpeedF = SecLPFilter(LocalVar%GenSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, CntrPar%F_LPFDamping, LocalVar%iStatus, .FALSE., objInst%instSecLPF) ! Second-order low-pass filter on generator speed
            LocalVar%RotSpeedF = SecLPFilter(LocalVar%RotSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, CntrPar%F_LPFDamping, LocalVar%iStatus, .FALSE., objInst%instSecLPF) ! Second-order low-pass filter on generator speed
        ENDIF
        ! Apply Notch Fitler
        IF (CntrPar%F_NotchType == 1 .OR. CntrPar%F_NotchType == 3) THEN
            LocalVar%GenSpeedF = NotchFilter(LocalVar%GenSpeedF, LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%iStatus, .FALSE., objInst%instNotch)
        ENDIF

        ! Filtering the tower fore-aft acceleration signal
        IF (CntrPar%Fl_Mode == 1) THEN
            ! Force to start at 0
            IF (LocalVar%iStatus == 0) THEN
                LocalVar%NacIMU_FA_AccF = SecLPFilter(0., LocalVar%DT, CntrPar%F_FlCornerFreq(1), CntrPar%F_FlCornerFreq(2), LocalVar%iStatus, .FALSE., objInst%instSecLPF) ! Fixed Damping
            ELSE
                LocalVar%NacIMU_FA_AccF = SecLPFilter(LocalVar%NacIMU_FA_Acc, LocalVar%DT, CntrPar%F_FlCornerFreq(1), CntrPar%F_FlCornerFreq(2), LocalVar%iStatus, .FALSE., objInst%instSecLPF) ! Fixed Damping
            ENDIF
            LocalVar%NacIMU_FA_AccF = HPFilter(LocalVar%NacIMU_FA_AccF, LocalVar%DT, 0.0167, LocalVar%iStatus, .FALSE., objInst%instHPF)

            IF (CntrPar%F_NotchType >= 2) THEN
                LocalVar%NACIMU_FA_AccF = NotchFilter(LocalVar%NacIMU_FA_AccF, LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%iStatus, .FALSE., objInst%instNotch) ! Fixed Damping
            ENDIF
        ENDIF

        LocalVar%FA_AccHPF = HPFilter(LocalVar%FA_Acc, LocalVar%DT, CntrPar%FA_HPFCornerFreq, LocalVar%iStatus, .FALSE., objInst%instHPF)

        ! Filter Wind Speed Estimator Signal
        LocalVar%We_Vw_F = LPFilter(LocalVar%WE_Vw, LocalVar%DT, 0.209, LocalVar%iStatus,.FALSE.,objInst%instLPF) ! 30 second time constant

        ! Control commands (used by WSE, mostly)
        LocalVar%VS_LastGenTrqF = SecLPFilter(LocalVar%VS_LastGenTrq, LocalVar%DT, CntrPar%F_LPFCornerFreq, 0.7, LocalVar%iStatus, .FALSE., objInst%instSecLPF)
        LocalVar%PC_PitComTF    = SecLPFilter(LocalVar%PC_PitComT, LocalVar%DT, CntrPar%F_LPFCornerFreq*0.25, 0.7, LocalVar%iStatus, .FALSE., objInst%instSecLPF)

    END SUBROUTINE PreFilterMeasuredSignals
    END MODULE Filters


subroutine hist3d(vx,vy,vz,minmax,lenv,nx,ny,nz,dfn,verbose)
   implicit none
   logical, optional, intent(in) :: verbose
   integer*8, intent(in) :: lenv
   integer, intent(in) :: nx, ny, nz
   double precision, intent(in), dimension(lenv) :: vx, vy, vz
   double precision, intent(in), optional, dimension(6) :: minmax
   integer*8, intent(out), dimension(nx,ny,nz) :: dfn
   logical :: verb
   integer :: i,j,k,l,clip_int
   double precision :: dvx, dvy, dvz, mm(6)

   if (present(verbose)) then
      verb = verbose
   else
      verb = .false.
   endif

   if (present(minmax)) then
      mm = minmax
      if (verb) then
        write(*,*) 'using ',mm,' for velocity extrema'
      endif

   else
      if (verb) then
        write(*,*) 'using the min-max of particle array for velocity extrema'
      endif
      mm=(/ minval(vx) , maxval(vx) &
           ,minval(vy) , maxval(vy) &
           ,minval(vz) , maxval(vz) /)
   endif

   dvx = (mm(2) - mm(1))/nx
   dvy = (mm(4) - mm(3))/ny
   dvz = (mm(6) - mm(5))/nz

   if (verb) then
     write(*,*) dvx,dvy,dvz
   endif

   do i=1,lenv
      if ( isnan(vx(i)) .or. isnan(vy(i)) &
      .or. isnan(vz(i)) ) then
         continue
      else
         j=clip_int(floor((vx(i)-mm(1))/dvx + 0.5),1,nx)
         k=clip_int(floor((vy(i)-mm(3))/dvy + 0.5),1,ny)
         l=clip_int(floor((vz(i)-mm(5))/dvz + 0.5),1,nz)

         dfn(j,k,l) = dfn(j,k,l) + 1
      endif
   enddo
end subroutine hist3d

double precision function clip_dp(v,minv,maxv)
   double precision, intent(in) :: v, minv, maxv
   clip_dp = minval((/maxval((/v,minv/)),maxv/))
end function
integer function clip_int(v,minv,maxv)
   integer, intent(in) :: v, minv, maxv
   clip_int = minval((/maxval((/v,minv/)),maxv/))
end function


program problem65
  use fmzm
  implicit none
  integer, parameter    :: n=102,m=100
  integer               :: i
  integer, dimension(n) :: numbers
  type(im)              :: numerator,denomenator,temp

  do i=1,n,3
     numbers(i)=1
     numbers(i+1)=2*((i+2)/3)
     numbers(i+2)=1
  end do

  numerator=to_im(1)
  denomenator=to_im(numbers(m-1))
  do i=m-2,1,-1
     numerator=numbers(i)*denomenator+numerator
     temp=numerator
     numerator=denomenator
     denomenator=temp
  end do
  numerator=numerator+2*denomenator

  ! print *, im_format('i100', numerator)
  i=0
  do while (numerator>0)
     i=to_int(mod(numerator,to_im(10)))+i
     numerator=numerator/10
  end do

  print *, i

end program problem65


program test_mkl
use types, only: dp
use fourier, only: dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
        fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
        fft3_inplace, ifft3_inplace
use utils, only: assert, init_random
use constants, only: i_
use mkl, only: mkl_fft3_inplace => fft3_inplace, &
    mkl_ifft3_inplace => ifft3_inplace
implicit none

complex(dp), allocatable :: x3(:, :, :), x3d(:, :, :)
real(dp) :: tmp
real(dp) :: t1, t2
integer :: l, m, n, i, j, k

allocate(x3(3, 5, 7))
forall(i=1:size(x3, 1), j=1:size(x3, 2), k=1:size(x3, 3))
    x3(i, j, k) = i*j+3*i**2+k*j+k
end forall
call fft3_inplace(x3)
call assert(abs(sum(x3)-630) < 1e-9_dp)

forall(i=1:size(x3, 1), j=1:size(x3, 2), k=1:size(x3, 3))
    x3(i, j, k) = i*j+3*i**2+k*j+k
end forall
call mkl_fft3_inplace(x3)
call assert(abs(sum(x3)-630) < 1e-9_dp)
deallocate(x3)

print *, "fft3 l m n:"
l = 15
m = 17
n = 19
allocate(x3(l, m, n), x3d(l, m, n))
do i = 1, size(x3, 1)
do j = 1, size(x3, 2)
do k = 1, size(x3, 3)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
call cpu_time(t1)
call mkl_fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/(l*m*n)) < 5e-15_dp))
x3d = x3
call cpu_time(t1)
call fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call mkl_ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/(l*m*n)) < 5e-15_dp))
deallocate(x3, x3d)

print *, "fft3:"
n = 16
allocate(x3(n, n, n), x3d(n, n, n))
do k = 1, size(x3, 3)
do j = 1, size(x3, 2)
do i = 1, size(x3, 1)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
call cpu_time(t1)
call mkl_fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/n**3) < 5e-15_dp))
x3d = x3
call cpu_time(t1)
call fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call mkl_ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/n**3) < 5e-15_dp))
deallocate(x3, x3d)

end program


!	Map beta.  First row is item, second is category, third is first dimension, fourth is second dimension, and fifth is
!	predictor number.
!	dimlatin is dimension of latent vector.
!	dimlatout is dimension of transformed latent vector.
!	npred is number of predictors.
!	numcat is number of underlying categories per item.
function mapbeta(dimlatin,dimlatout, npred,numcat)
implicit none
integer,intent(in)::dimlatin,dimlatout,npred,numcat(:)
integer::mapbeta(5,sum(numcat)*(dimlatout+1)+npred*dimlatin*(dimlatin+3)/2)
!	position, position1, cat, item, dimno, dim1, and pred are used as counters.
integer::cat,dimno,dim1,item,position,position1, pred

position=1
mapbeta=0
!	Intercepts.
do item=1,size(numcat)
	do cat=1,numcat(item)
		mapbeta(1,position)=item
		mapbeta(2,position)=position
		position=position+1
	end do
end do
!	Slopes.
position1=1
do item=1,size(numcat)
	do cat=1,numcat(item)
		do dimno=1,dimlatout
			mapbeta(1,position)=item
			mapbeta(2,position)=position1
			mapbeta(3,position)=dimno
			position=position+1
		end do
		position1=position1+1
	end do
end do
!	Linear components
do pred=1,npred
	do dimno=1,dimlatin
		mapbeta(3,position)=dimno
		mapbeta(5,position)=pred
		position=position+1
	end do
end do
!	Quadratic components
do pred=1,npred
	do dimno=1,dimlatin
		do dim1=1,dimno
			mapbeta(3,position)=dimno
			mapbeta(4,position)=dim1
			mapbeta(5,position)=pred
			position=position+1
		end do
	end do
end do
return
end function mapbeta


program mfcalc

!  input
!     inft: data file including temperature and its 1st and 2nd derivatives
!     infm: mask file
!     nbin: binning number
!     numin: minimum threshold nu
!     numax: maximum threshold nu
!  output
!     outf: output file of Minkowski Functionals

  use mf_tools
  implicit none

  integer :: nbin,npix
  real, pointer :: m(:)
  double precision, pointer :: f(:,:),mf(:,:)
  double precision :: sig(0:1),sk(0:2),numin,numax,dnu,fsky
  character(100) :: inft,infm,outf
  character(10) :: cnbin,cnumin,cnumax

  call getarg(1,inft)
  call getarg(2,infm)
  call getarg(3,outf)
  call getarg(4,cnbin)
  read(cnbin,*) nbin
  call getarg(5,cnumin)
  read(cnumin,*) numin
  call getarg(6,cnumax)
  read(cnumax,*) numax
  allocate(mf(nbin,0:2))
  dnu=(numax-numin)/float(nbin)

  call read_synfast(inft,f,npix)
  call convert_covderiv(f,npix)
  call readmask(infm,m,npix,fsky)
  call norm(f,m,sig(0),npix)
  call calcmoment(f,m,npix,sig,sk)
  call calcmf(f,m,npix,mf,numin,dnu,nbin)
  deallocate(f,m)
  call correct_binning(mf,sig,numin,dnu,nbin)
  call out_mf(outf,mf,sig,sk,numin,dnu,nbin)
  deallocate(mf)

end program mfcalc