!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testStochasticSampler
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE ExceptionHandler
USE ParallelEnv
USE StochasticSampling

IMPLICIT NONE

TYPE(StochasticSamplingType) :: myRNG
TYPE(ExceptionHandlerType),TARGET :: e
TYPE(MPI_EnvType) :: MPIEnv
TYPE(OMP_EnvType) :: OMPEnv

INTERFACE
  FUNCTION linear(x)
    IMPORT :: SDK
    REAL(SDK),INTENT(IN) :: x
    REAL(SDK) :: linear
  ENDFUNCTION
ENDINTERFACE

INTERFACE
  FUNCTION lineararg(x,arg)
    IMPORT :: SDK
    REAL(SDK),INTENT(IN) :: x
    REAL(SDK),INTENT(IN) :: arg(:)
    REAL(SDK) :: lineararg
  ENDFUNCTION
ENDINTERFACE

INTERFACE
  FUNCTION quadfunc(x)
    IMPORT :: SDK
    REAL(SDK),INTENT(IN) :: x
    REAL(SDK) :: quadfunc
  ENDFUNCTION
ENDINTERFACE

CREATE_TEST("StochasticSampler")

REGISTER_SUBTEST('Initialize',TestInit)
REGISTER_SUBTEST('RNG Performance',TestRNG)
REGISTER_SUBTEST('Uniform Dist',TestUniform)
REGISTER_SUBTEST('Exp Dist',TestExp)
REGISTER_SUBTEST('Normal Dist',TestNormal)
REGISTER_SUBTEST('Maxwellian Dist',TestMaxwellian)
REGISTER_SUBTEST('Watt Dist',TestWatt)
REGISTER_SUBTEST('Evap Dist',TestEvap)
REGISTER_SUBTEST('Norm Histogram',TestNormHist)
REGISTER_SUBTEST('Unnorm Hist',TestUnnormHist)
REGISTER_SUBTEST('Cont Hist',TestNormContHist)
REGISTER_SUBTEST('UnnormCont Hist',TestUnnormContHist)
REGISTER_SUBTEST('Norm PWL Dist',TestNormPWLinear)
REGISTER_SUBTEST('Unnorm PWL Dist',TestUnnormPWLinear)
REGISTER_SUBTEST('Rejection',TestRejection)
REGISTER_SUBTEST('Rejct w Arg',TestRejectionArg)
REGISTER_SUBTEST('Clear',TestClear)

CALL MPIEnv%finalize()
CALL myRNG%clear()

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE TestInit
  TYPE(StochasticSamplingType) :: myRNG2
  TYPE(StochasticSamplingType) :: myRNG3
  INTEGER :: i
  INTEGER(SLK) :: firstten(11)
  REAL(SDK) :: x

  CALL e%setQuietMode(.TRUE.)
  CALL eStochasticSampler%addSurrogate(e)
  ! Test Manager Init
  CALL myRNG%init(RNG_LEcuyer2)
  SET_PREFIX('RNG Init')
  ! Test Initialize
  ASSERT(myRNG%isInit,'isInit')
  ASSERT(myRNG%counter == 0,'counter')
  ASSERT(myRNG%RNmult == 2806196910506780709_SLK,'mult')
  ASSERT(myRNG%RNadd == 1_SLK,'add')
  ASSERT(myRNG%RNnorm == 1.0_SDK/2.0_SDK**63,'norm')

  firstten(1)=1_SLK
  firstten(2)=2806196910506780710_SLK
  firstten(3)=6924308458965941631_SLK
  firstten(4)=7093833571386932060_SLK
  firstten(5)=4133560638274335821_SLK
  firstten(6)= 678653069250352930_SLK
  firstten(7)= 682142755826100203_SLK
  firstten(8)=8445772606699617528_SLK
  firstten(9)=4656810573858967513_SLK
  firstten(10)=5251754594274751070_SLK
  firstten(11)=2039497501229545367_SLK

  DO i=1,11
    ASSERT(myRNG%RNseed == firstten(i),'RNG did not reproduce first 10 random numbers')
    FINFO() 'Failed at random number: ', i
    x=myRNG%rng()
  ENDDO

  DO i=1,100
    x=myRNG%rng()
  ENDDO

  CALL myRNG2%init(RNG_LEcuyer2,SKIP=myRNG%counter)
  ASSERT(myRNG%rng() == myRNG2%rng(),'RNG did not skip ahead properly.')
  FINFO() "RNG 1:         ", myRNG%rng()
  FINFO() "RNG 2 Skipped: ", myRNG2%rng()
  CALL myRNG2%clear()

  !  Set up case wehre parallel env is not initialized
  CALL myRNG2%init(RNG_LEcuyer2,MPIparallelEnv=MPIEnv,OMPparallelEnv=OMPEnv)
  CALL myRNG3%init(RNG_LEcuyer2)
  ASSERT(myRNG2%RNseed==myRNG3%RNseed,'RNG did not handle uninitialized parallel env properly.')
  CALL myRNG2%clear()
  CALL myRNG3%clear()

  ! Set up parallel environment for initialization test
  !   Initialize null MPI env then sets it to appear as 100 processors and of rank 22
  CALL MPIEnv%init(PE_COMM_SELF)
  MPIEnv%nproc=100
  MPIEnv%rank=22

  CALL myRNG2%init(RNG_LEcuyer2,MPIparallelEnv=MPIEnv)

  ! Set up parallel environment for initialization test
  !   Initialize null MPI env then sets it to appear as 10 processors and of rank 2
  MPIEnv%nproc=10
  MPIEnv%rank=2
  ! Set up parallel environment for initialization test
  !   Initialize null MPI env then sets it to appear as 10 processors and of rank 2
  CALL OMPEnv%init(1)
  OMPEnv%nproc=10
  OMPEnv%rank=2
  CALL myRNG3%init(RNG_LEcuyer2,MPIparallelEnv=MPIEnv,OMPparallelEnv=OMPEnv)

  ASSERT(myRNG2%RNseed==myRNG3%RNseed,'RNG Parallel Decomposition did not initialize properly.')

  CALL myRNG2%clear()
  CALL myRNG3%clear()
ENDSUBROUTINE TestInit
!
!-------------------------------------------------------------------------------
SUBROUTINE TestClear
  CALL myRNG%clear()

  SET_PREFIX('RNG clear')
  ASSERT(.NOT. myRNG%isInit,'isInit')
  ASSERT(myRNG%RNseed==-1,'RNseed')
  ASSERT(myRNG%RNseed==-1,'RNseed')
  ASSERT(myRNG%RNmult==-1,'RNmult')
  ASSERT(myRNG%RNadd==-1,'RNadd')
  ASSERT(myRNG%RNmask==-1,'RNmask')
  ASSERT(myRNG%RNmod==-1,'RNmod')
  ASSERT(myRNG%RNnorm==-1,'RNnorm')
  ASSERT(myRNG%counter==0,'counter')

ENDSUBROUTINE TestClear
!
!-------------------------------------------------------------------------------
SUBROUTINE TestRNG
  USE Times

  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  TYPE(TimerType) :: testTimer

  CALL testTimer%setTimerHiResMode(.TRUE.)

  n=100000000

  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=0.5_SDK
  truestd=1.0_SDK/SQRT(12.0_SDK)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  CALL testTimer%tic()
  DO i=1,n
    x=myRNG%rng()
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  CALL testTimer%toc()
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  WRITE(*,'(A,ES14.7,A)') '     RNG generated ',REAL(n,SRK)/testTimer%elapsedtime, &
      ' random numbers per second'

ENDSUBROUTINE TestRNG
!
!-------------------------------------------------------------------------------
SUBROUTINE TestUniform
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol

  n=1000000

  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=0.5_SDK
  truestd=1.0_SDK/SQRT(12.0_SDK)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%rng()
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=(9.0_SDK+ (-8.0_SDK))/2.0_SDK
  truestd=(9.0_SDK- (-8.0_SDK))/SQRT(12.0)

  DO i=1,n
    x=myRNG%uniform(-8.0_SDK,9.0_SDK)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestUniform
!
!-------------------------------------------------------------------------------
SUBROUTINE TestExp
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol

  n=1000000

  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=1.0_SDK/2.0_SDK
  truestd=1.0_SDK/2.0_SDK
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%exponential(2.0_SDK)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestExp
!
!-------------------------------------------------------------------------------
SUBROUTINE TestNormal
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol

  n=1000000

  COMPONENT_TEST('Normal Distribution')
  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=2.0_SDK
  truestd=0.5_SDK
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%normal(2.0_SDK,0.5_SDK)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  COMPONENT_TEST('Log-Normal Distribution')
  inicount=myRNG%counter
  mean=0.0
  stdev=0.0
  truemean=EXP(2.0_SDK+0.5_SDK**2/2.0_SDK)
  truestd=SQRT((EXP(0.5_SDK**2)-1.0_SDK)*EXP(2.0_SDK*2.0_SDK+0.5_SDK**2))

  DO i=1,n
    x=myRNG%lognormal(2.0_SDK,0.5_SDK)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestNormal
!
!-------------------------------------------------------------------------------
SUBROUTINE TestMaxwellian
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,T,truemean,truestd,tol

  n=1000000

  inicount=myRNG%counter
  T=600.0_SDK
  mean=0.0
  stdev=0.0
  truemean=3.0_SDK/2.0_SDK*T
  truestd=SQRT(3.0_SDK/2.0_SDK)*T
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%maxwellian(T)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==3*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)/truemean<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)/truestd<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestMaxwellian
!
!-------------------------------------------------------------------------------
SUBROUTINE TestWatt
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,a,b,truemean,truestd,tol

  n=1000000

  inicount=myRNG%counter
  a=2.0_SDK
  b=0.5_SDK
  truemean=a**2.5*SQRT(b)*(6.0_SDK+a*b)/(4.0_SDK*SQRT(a**3*b))
  truestd=SQRT((a**2*(-36.0*SQRT(a**3*b)+a*SQRT(b)*(12.0+a*b)* &
      (4.0*SQRT(a)+a**1.5*b-SQRT(b)*SQRT(a**3*b))))/SQRT(a**3*b))/(2.0*SQRT(2.0))
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  mean=0.0
  stdev=0.0
  DO i=1,n
    x=myRNG%watt(a,b)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==4*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestWatt
!
!-------------------------------------------------------------------------------
SUBROUTINE TestEvap
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x, theta,mean,stdev,truemean,truestd,tol

  n=1000000

  inicount=myRNG%counter
  theta=0.8_SDK
  truemean=8.0_SDK/5.0_SDK
  truestd=SQRT(32.0_SDK)/5.0_SDK
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  mean=0.0
  stdev=0.0
  DO i=1,n
    x=myRNG%evaporation(theta)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestEvap
!
!-------------------------------------------------------------------------------
SUBROUTINE TestNormHist
  INTEGER(SLK) :: i,j,n,inicount
  REAL(SDK) :: mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:), iii(:)

  ALLOCATE(y(5))
  ALLOCATE(iii(5))

  n=1000000

  inicount=myRNG%counter
  y=(/ 0.2, 0.4, 0.1, 0.05, 0.25 /)
  mean=0.0_SDK
  stdev=0.0_SDK
  iii=0.0_SDK
  truemean=2.75_SRK
  truestd=SQRT(9.75_SRK-2.75_SRK**2)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    j=myRNG%histogram(y)
    iii(j)=iii(j)+1
    mean=mean+REAL(j,SDK)/REAL(n,SDK)
    stdev=stdev+REAL(j,SDK)**2/REAL(n,SDK)
  ENDDO

  DO i=1,5
    ASSERT(ABS(REAL(iii(i))/REAL(n,SDK)-y(i))<tol,'RNG histogram bin test.')
    FINFO() i,REAL(iii(i))/REAL(n,SDK),y(i)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(iii)
ENDSUBROUTINE TestNormHist
!
!-------------------------------------------------------------------------------
SUBROUTINE TestUnnormHist
  INTEGER(SLK) :: i,j,n,inicount
  REAL(SDK) :: mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),iii(:)

  ALLOCATE(y(5))
  ALLOCATE(iii(5))
  n=1000000

  inicount=myRNG%counter
  y=(/ 2.0, 4.0, 1.0, 0.5, 2.5 /)
  iii=0
  mean=0.0_SDK
  stdev=0.0_SDK
  truemean=2.75_SRK
  truestd=SQRT(9.75_SRK-2.75_SRK**2)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    j=myRNG%unnormhistogram(y)
    iii(j)=iii(j)+1
    mean=mean+REAL(j,SDK)/REAL(n,SDK)
    stdev=stdev+REAL(j,SDK)**2/REAL(n,SDK)
  ENDDO

  DO i=1,5
    ASSERT(ABS(REAL(iii(i))/REAL(n,SDK)-y(i)/SUM(y))<tol,'RNG histogram bin test.')
    FINFO() i,REAL(iii(i))/REAL(n,SDK),y(i)/SUM(y)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(iii)
ENDSUBROUTINE TestUnnormHist
!
!-------------------------------------------------------------------------------
SUBROUTINE TestNormContHist
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(5))
  ALLOCATE(z(6))
  n=1000000

  inicount=myRNG%counter
  y=(/ 0.2, 0.4, 0.1, 0.05, 0.25 /)
  z=(/ 1.0, 2.0, 3.0, 4.0, 5.0, 7.0 /)
  mean=0.0_SDK
  stdev=0.0_SDK
  truemean=3.375_SRK
  truestd=SQRT(43.0_SRK/3.0_SRK-3.375_SRK**2)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%conthistogram(y,z)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(z)
ENDSUBROUTINE TestNormContHist
!
!-------------------------------------------------------------------------------
SUBROUTINE TestUnnormContHist
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(5))
  ALLOCATE(z(6))
  n=1000000

  inicount=myRNG%counter
  y=(/ 2.0, 4.0, 1.0, 0.5, 2.5 /)
  z=(/ 1.0, 2.0, 3.0, 4.0, 5.0, 7.0 /)
  mean=0.0_SDK
  stdev=0.0_SDK
  truemean=3.375_SRK
  truestd=SQRT(43.0_SRK/3.0_SRK-3.375_SRK**2)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%unnormconthistogram(y,z)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(z)
ENDSUBROUTINE TestUnnormContHist
!
!-------------------------------------------------------------------------------
SUBROUTINE TestNormPWLinear
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x, mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(3))
  ALLOCATE(z(3))
  n=1000000

  inicount=myRNG%counter
  y=(/ 0.0, 1.0, 0.0 /)
  z=(/ 0.0, 1.0, 2.0 /)
  mean=0.0
  stdev=0.0
  truemean=1.0_SDK
  truestd=1.0_SDK/SQRT(6.0_SDK)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%pwlinear(y,z)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(z)
ENDSUBROUTINE TestNormPWLinear
!
!-------------------------------------------------------------------------------
SUBROUTINE TestUnnormPWLinear
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(3))
  ALLOCATE(z(3))
  n=1000000

  inicount=myRNG%counter
  y=(/ 0.0, 2.0, 0.0 /)
  z=(/ 0.0, 1.0, 3.0 /)
  mean=0.0
  stdev=0.0
  truemean=4.0_SDK/3.0_SDK
  truestd=SQRT(7.0_SDK)/SQRT(18.0_SDK)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%unnormpwlinear(y,z)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount==2*n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

  DEALLOCATE(y)
  DEALLOCATE(z)
ENDSUBROUTINE TestUnnormPWLinear
!
!-------------------------------------------------------------------------------
SUBROUTINE TestRejection
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(3))
  ALLOCATE(z(3))
  n=1000000

  inicount=myRNG%counter
  y=(/ 0.0, 2.0, 0.0 /)
  z=(/ 0.0, 1.0, 3.0 /)
  mean=0.0
  stdev=0.0
  truemean=10.0_SDK/3.0_SDK
  truestd=5.0_SDK/SQRT(18.0_SDK)
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%rejection(linear,0.0_SDK,5.0_SDK,7.0_SDK)
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount>n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestRejection
!
!-------------------------------------------------------------------------------
SUBROUTINE TestRejectionArg
  INTEGER(SLK) :: i,n,inicount
  REAL(SDK) :: x,mean,stdev,truemean,truestd,tol
  REAL(SRK),ALLOCATABLE :: y(:),z(:)

  ALLOCATE(y(3))
  ALLOCATE(z(3))
  n=1000000

  inicount=myRNG%counter
  y=(/ 0.0, 2.0, 0.0 /)
  z=(/ 0.0, 1.0, 3.0 /)
  mean=0.0
  stdev=0.0
  truemean=11.0_SDK/9.0_SDK
  truestd=SQRT(23.0_SDK)/9.0_SDK
  tol=5.0_SDK/SQRT(REAL(n,SDK))

  DO i=1,n
    x=myRNG%rejectionarg(lineararg,0.0_SDK,2.0_SDK,7.0_SDK,(/2.0_SDK,1.0_SDK/))
    mean=mean+x/REAL(n,SDK)
    stdev=stdev+x**2/REAL(n,SDK)
  ENDDO
  stdev=SQRT(stdev-mean**2)

  ASSERT(myRNG%counter-inicount>n,'Check counter increment.')
  ASSERT(ABS(mean-truemean)<tol,'RNG mean does not meet criteria')
  FINFO() mean,truemean,ABS(mean-truemean)
  ASSERT(ABS(stdev-truestd)<tol,'RNG standard deviation does not meet criteria')
  FINFO() stdev,truestd,ABS(stdev-truestd)

ENDSUBROUTINE TestRejectionArg
!
ENDPROGRAM testStochasticSampler
!
!-------------------------------------------------------------------------------
FUNCTION linear(x) RESULT(y)
USE IntrType
REAL(SDK),INTENT(IN) :: x
REAL(SDK) :: y

y=x
ENDFUNCTION
!
!-------------------------------------------------------------------------------
FUNCTION lineararg(x,arg) RESULT(y)
USE IntrType
REAL(SDK),INTENT(IN) :: x
REAL(SDK),INTENT(IN) :: arg(:)
REAL(SDK) :: y
y=arg(1)*x+arg(2)
ENDFUNCTION lineararg
!
!-------------------------------------------------------------------------------
FUNCTION quadfunc(x) RESULT(y)
USE IntrType
REAL(SDK),INTENT(IN) :: x
REAL(SDK) :: y

y=x**2+x+1.0_SDK
ENDFUNCTION


      include 'fac.f'
c
      program test
c
c     Exercise A, section 11.
c     Main program to test factorial function.
c
      integer n, fac

 10   continue
      write(*,*) 'Give n: '
      read (*,*) n
      if (n.gt.0) then
         write(*,*) n, ' factorial is', fac(n)
         goto 10
      endif
c     End of loop

      stop
      end


c     Subroutine to identify complete months in record
c     AJ_Kettle, Nov09/2017

      SUBROUTINE identify_complete_months(l_prod,s_day_date)

      IMPLICIT NONE
c************************************************************************
      INTEGER             :: l_prod
      CHARACTER(LEN=8)    :: s_day_date(100000)

      INTEGER             :: i,j,k,ii,jj,kk

      INTEGER             :: n_monthdays_expect(12)
      INTEGER             :: n_monthdays_expect2(12)
      INTEGER             :: i_vec_year(300)
      REAL                :: f_vec_year(300)
      REAL                :: f_result
      INTEGER             :: i_refyear
      INTEGER             :: i_matrix_monthdays(300,12)
      INTEGER             :: i_matrix_truedaycnt(300,12)
      INTEGER             :: i_loc_year
      INTEGER             :: i_loc_month
      INTEGER             :: ii1,ii2,ii3

      INTEGER             :: l_cnt_month
      INTEGER             :: l_cnt_month_bad
      INTEGER             :: l_cnt_month_good

      CHARACTER(LEN=4)    :: s_day_year(100000)
      CHARACTER(LEN=2)    :: s_day_month(100000)
      CHARACTER(LEN=2)    :: s_day_day(100000)
      REAL                :: f_day_year(100000)
      REAL                :: f_day_month(100000)
      REAL                :: f_day_day(100000)
      INTEGER             :: i_day_year(100000)
      INTEGER             :: i_day_month(100000)
      INTEGER             :: i_day_day(100000)

      CHARACTER(LEN=8)    :: s_date_single
      CHARACTER(LEN=2)    :: s_mon_ref

      INTEGER             :: i_monend(10000)
      INTEGER             :: i_monstart(10000)
      INTEGER             :: i_monlength(10000)
      INTEGER             :: i_yearid(10000)
      INTEGER             :: i_monthid(10000)
      INTEGER             :: n_month

      CHARACTER(LEN=2)    :: s_test2
      CHARACTER(LEN=4)    :: s_test4
      REAL                :: f_test
      INTEGER             :: i_test

c************************************************************************
c     Declare expected number of days in each month

      n_monthdays_expect(1)=31
      n_monthdays_expect(2)=28
      n_monthdays_expect(3)=31
      n_monthdays_expect(4)=30
      n_monthdays_expect(5)=31
      n_monthdays_expect(6)=30
      n_monthdays_expect(7)=31
      n_monthdays_expect(8)=31
      n_monthdays_expect(9)=30
      n_monthdays_expect(10)=31
      n_monthdays_expect(11)=30
      n_monthdays_expect(12)=31

      n_monthdays_expect2(1)=31
      n_monthdays_expect2(2)=29
      n_monthdays_expect2(3)=31
      n_monthdays_expect2(4)=30
      n_monthdays_expect2(5)=31
      n_monthdays_expect2(6)=30
      n_monthdays_expect2(7)=31
      n_monthdays_expect2(8)=31
      n_monthdays_expect2(9)=30
      n_monthdays_expect2(10)=31
      n_monthdays_expect2(11)=30
      n_monthdays_expect2(12)=31

      ii1=0
      ii2=0
      ii3=0

      i_refyear=300

      DO i=1,i_refyear
       i_vec_year(i)=1750+(i-1)
       f_vec_year(i)=1750.0+(i-1.0)

       f_result=MODULO(f_vec_year(i),4.0)
c       print*,'f_result=',f_result

c      Ordinary years
       IF (f_result.NE.0.0) THEN
        DO j=1,12
         i_matrix_monthdays(i,j)=n_monthdays_expect(j)
        ENDDO
        ii1=ii1+1
       ENDIF

c      Leap year condition
       IF (f_result.EQ.0.0) THEN
        DO j=1,12
         i_matrix_monthdays(i,j)=n_monthdays_expect2(j)
        ENDDO
        ii2=ii2+1
       ENDIF

c      Hard wire century years
       IF (i_vec_year(i).EQ.1800.OR.i_vec_year(i).EQ.1900) THEN
        DO j=1,12
         i_matrix_monthdays(i,j)=n_monthdays_expect(j)
        ENDDO
        ii3=ii3+1
       ENDIF

      ENDDO

c      print*,'i_vec_year=',(i_vec_year(i),i=1,5)
c      print*,'f_vec_year=',(f_vec_year(i),i=1,5)
c      print*,'ii1,ii2,ii3=',ii1,ii2,ii3
c************************************************************************
c     Extract component fields of date

      DO i=1,l_prod      !cycle through length of file
       s_date_single=s_day_date(i)

       s_day_year(i) =s_date_single(1:4)
       s_day_month(i)=s_date_single(5:6)
       s_day_day(i)  =s_date_single(7:8)
c******
c      Convert string to float
       s_test4=s_day_year(i)
       READ(s_test4,*) f_test
       f_day_year(i)=f_test

       s_test2=s_day_month(i)
       READ(s_test2,*) f_test
       f_day_month(i)=f_test

       s_test2=s_day_year(i)
       READ(s_test2,*) f_test
       f_day_day(i)=f_test
c******
c      Convert string to integer
       s_test4=s_day_year(i)
       READ(s_test4,*) i_test
       i_day_year(i)=i_test

       s_test2=s_day_month(i)
       READ(s_test2,*) i_test
       i_day_month(i)=i_test

       s_test2=s_day_year(i)
       READ(s_test2,*) i_test
       i_day_day(i)=i_test
c******
      ENDDO

c      print*,'f_day_year=',(f_day_year(i),i=1,10)
c************************************************************************
c     Count days on standard matrix

c     Initial i_matrix_truedaycnt
      DO j=1,300
       DO k=1,12
        i_matrix_truedaycnt(j,k)=0
       ENDDO
      ENDDO

c     Increment counter
      DO i=1,l_prod      !cycle through length of file
       i_loc_year =i_day_year(i)-1750+1
       i_loc_month=i_day_month(i)

       i_matrix_truedaycnt(i_loc_year,i_loc_month)=
     +    i_matrix_truedaycnt(i_loc_year,i_loc_month)+1

       IF (i_matrix_truedaycnt(i_loc_year,i_loc_month).GT.31) THEN
        print*,'emergency stop at point, month days exceeded',
     +   i_day_year(i),i_day_month(i),
     +   i_matrix_truedaycnt(i_loc_year,i_loc_month)
        CALL SLEEP(50)
       ENDIF
      ENDDO

c     Test to see in number of days in true counts exceeds 31
      DO j=1,300
       DO k=1,12
        IF (i_matrix_truedaycnt(j,k).GT.31) THEN
         print*,'emergency stop, month days exceeded',j,k,
     +     i_matrix_truedaycnt(j,k)
c         CALL SLEEP(5)
        ENDIF
       ENDDO
      ENDDO

c     Count number of months with deficient days
      l_cnt_month     =0
      l_cnt_month_bad =0
      l_cnt_month_good=0
      DO j=1,300
       DO k=1,12
        IF (i_matrix_truedaycnt(j,k).GT.0) THEN
         l_cnt_month=l_cnt_month+1

         IF (i_matrix_truedaycnt(j,k).EQ.i_matrix_monthdays(j,k)) THEN
          l_cnt_month_good=l_cnt_month_good+1
         ENDIF
         IF (i_matrix_truedaycnt(j,k).LT.i_matrix_monthdays(j,k)) THEN
          l_cnt_month_bad =l_cnt_month_bad+1
         ENDIF
        ENDIF
       ENDDO
      ENDDO

c      print*,'matrix comparison l_cnt_month...',
c     +  l_cnt_month,l_cnt_month_good,l_cnt_month_bad
c      IF (l_cnt_month_bad.GT.0) THEN
c       CALL SLEEP(5)
c      ENDIF
c************************************************************************
c     Test if first year before 1750
      IF (i_day_year(1).LT.1750) THEN
       print*,'emergency stop; 1st year before 1750',i_day_year(1)
       CALL SLEEP(100)
      ENDIF
c************************************************************************
c     Count number of month changes in record
      ii=1
      i_monstart(ii)=ii         !first month start indicator
      s_mon_ref=s_day_month(1)
      i_yearid(ii) =i_day_year(1)
      i_monthid(ii)=i_day_month(1)

      DO i=2,l_prod

c      Condition for month switch
       IF (s_day_month(i).NE.s_mon_ref) THEN
        s_mon_ref=s_day_month(i)
        i_monend(ii)=i-1
        ii=ii+1
        i_monstart(ii)=i
        i_yearid(ii) =i_day_year(i)
        i_monthid(ii)=i_day_month(i)

        IF (ii.GT.10000) THEN
         print*,'Month storage array exceeded'
         CALL SLEEP(10)
        ENDIF
       ENDIF
      ENDDO
      i_monend(ii)=l_prod      !last month end indicator

      n_month=ii

c     Find lengths of months
      DO i=1,n_month
       i_monlength(i)=i_monend(i)-i_monstart(i)+1

c       IF (i_monlength(i).GT.31) THEN
c        print*,'i_monlength exceeded',i_monlength(i)
c        print*,'i_monstart(i)=',i_monstart(i)
c        print*,'i_monend(i)=',  i_monend(i)
c       ENDIF
      ENDDO

c      print*,'ii nmonth=',n_month
c      print*,'i_monstart start=',(i_monstart(i),i=1,5)
c      print*,'i_monend   start=',(i_monend(i),i=1,5)
c      print*,'i_monstart end=',  (i_monstart(i),i=n_month-5,n_month)
c      print*,'i_monend   end=',  (i_monend(i),i=n_month-5,n_month)
c      print*,'i_monlength=',     (i_monlength(i),i=1,5)

c      print*,'i_yearid=',        (i_yearid(i),i=1,14)
c      print*,'i_monthid=',       (i_monthid(i),i=1,14)

c      print*,'s_day_month=',(s_day_month(i),i=1,5)

c************************************************************************
c     Test to see if day counts complete

      DO i=1,n_month         !cycle through sequential month list

c      Cycle through leap year list
       DO j=1,i_refyear
c       test if sequential year matches vec_year
        IF (i_yearid(i).EQ.i_vec_year(j)) THEN
c        Cycle through matrix months
         DO k=1,12
c         Test if match between months
          IF (i_monthid(i).EQ.k) THEN
c          Test if number of days good
           IF (i_monlength(i).EQ.i_matrix_monthdays(j,k)) THEN
c            print*,'good match',j,k,i_matrix_monthdays(j,k)
c            CALL SLEEP(1)
           ENDIF

c           IF (i_monlength(i).NE.i_matrix_monthdays(j,k)) THEN
c            print*,'months incomplete'
c            print*,'i_matrix_monthdays ref=',i_matrix_monthdays(j,k)
c            print*,'year/month index=',j,k
c            print*,'i_monlength test=',      i_monlength(i)
cc            CALL SLEEP(5)
c           ENDIF

          ENDIF
         ENDDO
        ENDIF
       ENDDO                 !close j
      ENDDO

c      CALL SLEEP(5)
c************************************************************************
      RETURN
      END


submodule (modsparse) modsparse_gen
 !$ use omp_lib
 implicit none

 real(wp),parameter:: tolerance = 1.e-6

contains

!DESTROY
!> @brief Subroutine to reset/destroy a generic object
module subroutine destroy_gen_gen(sparse)
 class(gen_sparse),intent(inout)::sparse

 sparse%namemat='UNKNOWN'
 sparse%dim1=-1
 sparse%dim2=-1
 sparse%unlog=6
 sparse%lsymmetric=.false.
 sparse%lupperstorage=.false.
 if(allocated(sparse%perm))deallocate(sparse%perm)

end subroutine

!**CONJUGATE GRADIENT
module subroutine cg_gen(sparse,x,y,maxiter,tol)
 !sparse*x=y
 class(gen_sparse),intent(in)::sparse
 integer(kind=int32),intent(inout),optional::maxiter
 real(kind=wp),intent(inout)::x(:)
 real(kind=wp),intent(in)::y(:)
 real(kind=wp),intent(inout),optional::tol

 integer(kind=int32)::i,maxiter_
 real(kind=wp)::r(size(x))
 real(kind=wp)::p(size(x))
 real(kind=wp)::Ap(size(x))
 real(kind=wp)::rsnew,rsold,tol_,alpha
 real(kind=wp)::ynorm

 if(.not.sparse%issquare().or..not.sparse%lsymmetric&
    .or.size(x).ne.size(y)&
    .or.size(x).ne.sparse%getdim(2)&
    .or.size(y).ne.sparse%getdim(1)&
     )then
  write(sparse%unlog,'(a)')' ERROR: one of multiple arguments are not conform'
  error stop
 endif

 maxiter_ = min(1000,size(x)-1)
 if(present(maxiter))then
  if(maxiter.gt.0)maxiter_ = min(maxiter,size(x)-1)
 endif

 tol_ = tolerance
 if(present(tol))tol_=tol
 ynorm = norm2(y)
 tol_ = tol_ * ynorm

 Ap=0._wp
 call sparse%mult(1._wp,'n',x,0._wp,Ap)
 r = y - Ap
 p = r
 rsold = sum(r**2)

 do i=1, maxiter_
  call sparse%mult(1._wp,'n',p,0._wp,Ap)
  alpha = rsold / dot_product(p,Ap)
  x = x + alpha * p
  r = r - alpha * Ap
  rsnew = sum(r**2)
  if(sqrt(rsnew) < tol_)exit
  p = r +(rsnew / rsold) * p
  rsold = rsnew
 enddo

 if(present(maxiter)) maxiter = i
 if(present(tol)) tol = sqrt(rsnew) / ynorm

end subroutine

!**GET ELEMENTS
pure module function getdim_gen(sparse,dim1) result(dimget)
 class(gen_sparse),intent(in)::sparse
 integer(kind=int32),intent(in)::dim1
 integer(kind=int32)::dimget

 select case(dim1)
  case(1)
   dimget=sparse%dim1
  case(2)
   dimget=sparse%dim2
  case default
   dimget=-1
!   write(sparse%unlog,'(a)')' Warning: a sparse matrix has only 2 dimensions!'
 end select

end function

!GET MEMORY
module function getmem_gen(sparse) result(getmem)
 class(gen_sparse),intent(in)::sparse
 integer(kind=int64)::getmem

 getmem=sizeof(sparse%unlog)+sizeof(sparse%dim1)+sizeof(sparse%dim2)+sizeof(sparse%namemat)&
        +sizeof(sparse%lsymmetric)+sizeof(sparse%lupperstorage)
 if(allocated(sparse%perm))getmem=getmem+sizeof(sparse%perm)

end function

!INITIATE GEN SPARSE
module subroutine init_gen(sparse,namemat,dim1,dim2)
 class(gen_sparse),intent(inout)::sparse
 integer(kind=int32),intent(in)::dim1,dim2
 character(len=*),intent(in)::namemat

 sparse%namemat=namemat

 sparse%dim1=dim1
 sparse%dim2=dim2

 sparse%lsorted=.false.
 sparse%lsymmetric=.false.
 sparse%lupperstorage=.false.

end subroutine

!**PRINT
module subroutine print_dim_gen(sparse)
 class(gen_sparse),intent(in)::sparse

 write(sparse%unlog,'(/" Type of the matrix           : ",a)')trim(sparse%namemat)
 write(sparse%unlog,'( "  Output unit                 : ",i0)')sparse%unlog
 write(sparse%unlog,'( "  Dimension of the matrix     : ",i0," x ",i0)')sparse%dim1,sparse%dim2
 write(sparse%unlog,'( "  Number of non-zero elements : ",i0)')sparse%nonzero()
 write(sparse%unlog,'( "  Sorted                      : ",l1)')sparse%issorted()
 write(sparse%unlog,'( "  Symmetrix                   : ",l1)')sparse%lsymmetric
 write(sparse%unlog,'( "  Upper storage               : ",l1)')sparse%lupperstorage
 write(sparse%unlog,'( "  Permutation array provided  : ",l1)')allocated(sparse%perm)

 select type(sparse)
  type is(coosparse)
   write(sparse%unlog,'( "  Memory (B)                  : ",i0)')sparse%getmem()
   write(sparse%unlog,'( "  Size of the array           : ",i0)')sparse%nel
  type is(crssparse)
   write(sparse%unlog,'( "  Memory (B)                  : ",i0)')sparse%getmem()
#if (_PARDISO==1)
   write(sparse%unlog,'( "  PARDISO status              : ",i0)')sparse%lpardisofirst
#endif
  class default
 end select
 write(sparse%unlog,'(a)')' '

end subroutine

module subroutine printtofile_gen(sparse,namefile,lint)
 class(gen_sparse),intent(in)::sparse
 character(len=*),intent(in)::namefile
 logical,intent(in),optional::lint

 integer(kind=int32)::un
 logical::linternal

 linternal=.true.
 if(present(lint))linternal=lint

 open(newunit=un,file=namefile,status='replace',action='write')
 call sparse%print(lint=linternal,output=un)
 close(un)

end subroutine

module subroutine printsquaretofile_gen(sparse,namefile)
 class(gen_sparse),intent(inout)::sparse
 character(len=*),intent(in)::namefile

 integer(kind=int32)::un

 open(newunit=un,file=namefile,status='replace',action='write')
 call sparse%printsquare(output=un)
 close(un)

end subroutine

!**SET OUTPUT UNIT
module subroutine setoutputunit(sparse,unlog)
 class(gen_sparse),intent(inout)::sparse
 integer(kind=int32)::unlog

 sparse%unlog=unlog

end subroutine

!** SET PERMUTATION VECTOR
module subroutine setpermutation(sparse,array)
 class(gen_sparse),intent(inout)::sparse
 integer(kind=int32)::array(:)

 if(size(array).ne.sparse%getdim(1))then
  write(sparse%unlog,'(a)')' ERROR: The permutation array has a wrong size.'
  error stop
 endif

 !Probably pointer would be better???
 if(.not.allocated(sparse%perm))allocate(sparse%perm(sparse%getdim(1)))
 sparse%perm=array

end subroutine

! SET THE STATUS SORTED
module subroutine setsorted(sparse,ll)
 class(gen_sparse),intent(inout)::sparse
 logical,intent(in)::ll

 sparse%lsorted=ll

end subroutine

! SET THE STATUS SYMMETRIC
module subroutine setsymmetric(sparse,ll)
 class(gen_sparse),intent(inout)::sparse
 logical,intent(in),optional::ll

 logical::lll

 if(.not.sparse%issquare().and..not.present(ll))then
  write(sparse%unlog,'(a)')' ERROR: the sparse matrix is not square and cannot be set to symmetric!'
  error stop
 elseif(.not.sparse%issquare().and.present(ll))then
  if(ll)then
   write(sparse%unlog,'(a)')' ERROR: the sparse matrix is not square and cannot be set to symmetric as requested!'
   error stop
  endif
 endif

 lll=.true.
 if(present(ll))lll=ll

 sparse%lsymmetric=lll

end subroutine

!**OTHER
module function issorted(sparse) result(ll)
 class(gen_sparse),intent(in)::sparse
 logical::ll

 ll=sparse%lsorted

end function

module function issquare(sparse) result(ll)
 class(gen_sparse),intent(in)::sparse
 logical::ll

 ll=.true.
 if(sparse%dim1.ne.sparse%dim2)ll=.false.

end function

!CHECKS
module function validvalue_gen(sparse,row,col) result(lvalid)
 class(gen_sparse),intent(in)::sparse
 integer(kind=int32),intent(in)::row,col
 logical::lvalid

 lvalid=.true.
 if((row.lt.1.or.row.gt.sparse%dim1).or.(col.lt.1.or.col.gt.sparse%dim2))lvalid=.false.

end function

module function validnonzero_gen(sparse,val) result(lvalid)
 class(gen_sparse),intent(in)::sparse
 real(kind=wp),intent(in)::val
 logical::lvalid

 lvalid=.true.
 if((abs(val)<epsilon(val)))lvalid=.false.

end function

module function uppervalue_gen(row,col) result(lvalid)
 integer(kind=int32),intent(in)::row,col
 logical::lvalid

 lvalid=.true.
 if(row.gt.col)lvalid=.false.

end function

end submodule


C Read two ints and two floats from a file using one FORMAT,
C then write them out to another file using a different FORMAT.
C The expected output written to file 'outfile3' are the
C following four lines:
C
C F =  23.5; I =  456
C
C F =  67.9; I =  123

      PROGRAM MAIN

      REAL X,Y
      OPEN (10, FILE="infile3")
      OPEN (20, FILE="outfile3", STATUS="REPLACE")
 30   FORMAT(/,'F = ', F5.1, '; I = ', I4)
      READ (10,10) I,X,J,Y
      WRITE (20,30) X,J
      WRITE (20,30) Y,I
 10   FORMAT (2(I3,X,F5.2,X))
      STOP
      END PROGRAM MAIN


program p1

  integer :: c= 10, d = 29
  print *, (2.0 + (c+d))
end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Test_Math_mod

    use Math_mod
    use Err_mod, only: Err_type
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Math

    type(Test_type) :: Test

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

contains

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

    subroutine test_Math()
        implicit none
        Test = Test_type(moduleName=MODULE_NAME)
        call test_getLowerGamma()
        call test_getUpperGamma()
        call Test%finalize()
#ifdef CAF_ENABLED
        sync all
#endif
    end subroutine test_Math

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

    subroutine test_getLowerGamma()

        use Constants_mod, only: RK, IK

        implicit none
        integer, parameter      :: ntest = 3
        real(RK)                :: Exponent(ntest), UpperLim(ntest), LowerGamma(ntest)
        real(RK), parameter     :: LowerGammaRef(ntest) = [0.632120558828558_RK,0.184736755476228_RK,0.999817189367018_RK]
        real(RK)                :: difference
        integer                 :: i

        if (Test%Image%isFirst) call Test%testing("getLowerGamma")

        Exponent = [1.0_RK, 5.0_RK, 0.5_RK]
        UpperLim = [1.0_RK, 3.0_RK, 7.0_RK]

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

        do i = 1,ntest
            LowerGamma(i) = getLowerGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , upperLim = UpperLim(i) &
                                            , tolerance = 1.e-7_RK &
                                            )
            difference = 2 * abs(LowerGammaRef(i) - LowerGamma(i)) / (LowerGammaRef(i) + LowerGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, UpperLim, Reference LowerGamma, Computed LowerGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), UpperLim(i), LowerGamma(i), LowerGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < 1.e-7_RK
            call Test%verify()
        end do
        !call Test%skipping()

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

        do i = 1,ntest
            LowerGamma(i) = getLowerGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , upperLim = UpperLim(i) &
                                            , tolerance = 1.e-3_RK &
                                            )
            difference = 2 * abs(LowerGammaRef(i) - LowerGamma(i)) / (LowerGammaRef(i) + LowerGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, UpperLim, Reference LowerGamma, Computed LowerGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), UpperLim(i), LowerGamma(i), LowerGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < 1.e-3_RK
            call Test%verify()
        end do
        !call Test%skipping()

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

        do i = 1,ntest
            LowerGamma(i) = getLowerGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , upperLim = UpperLim(i) &
                                           !, tolerance = 1.e-3_RK &
                                            )
            difference = 2 * abs(LowerGammaRef(i) - LowerGamma(i)) / (LowerGammaRef(i) + LowerGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, UpperLim, Reference LowerGamma, Computed LowerGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), UpperLim(i), LowerGamma(i), LowerGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < epsilon(1._RK) * 1.e1_RK
            call Test%verify()
        end do
        !call Test%skipping()

    end subroutine test_getLowerGamma

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

    subroutine test_getUpperGamma()

        use Constants_mod, only: RK, IK

        implicit none
        integer, parameter      :: ntest = 3
        real(RK)                :: Exponent(ntest), LowerLim(ntest), UpperGamma(ntest)
        real(RK), parameter     :: UpperGammaRef(ntest) = [0.367879441171442_RK,0.815263244523772_RK,1.828106329818355e-04_RK]
        real(RK)                :: difference
        integer                 :: i

        if (Test%Image%isFirst) call Test%testing("getUpperGamma")

        Exponent = [1.0_RK, 5.0_RK, 0.5_RK]
        LowerLim = [1.0_RK, 3.0_RK, 7.0_RK]

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

        do i = 1,ntest
            UpperGamma(i) = getUpperGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , LowerLim = LowerLim(i) &
                                            , tolerance = 1.e-7_RK &
                                            )
            difference = 2 * abs(UpperGammaRef(i) - UpperGamma(i)) / (UpperGammaRef(i) + UpperGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, LowerLim, Reference UpperGamma, Computed UpperGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), LowerLim(i), UpperGamma(i), UpperGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < 1.e-7_RK
            call Test%verify()
        end do
        !call Test%skipping()

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

        do i = 1,ntest
            UpperGamma(i) = getUpperGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , LowerLim = LowerLim(i) &
                                            , tolerance = 1.e-3_RK &
                                            )
            difference = 2 * abs(UpperGammaRef(i) - UpperGamma(i)) / (UpperGammaRef(i) + UpperGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, LowerLim, Reference UpperGamma, Computed UpperGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), LowerLim(i), UpperGamma(i), UpperGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < 1.e-3_RK
            call Test%verify()
        end do
        !call Test%skipping()

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

        do i = 1,ntest
            UpperGamma(i) = getUpperGamma   ( exponent = Exponent(i) &
                                            , logGammaExponent = log_gamma(Exponent(i)) &
                                            , LowerLim = LowerLim(i) &
                                           !, tolerance = 1.e-3_RK &
                                            )
            difference = 2 * abs(UpperGammaRef(i) - UpperGamma(i)) / (UpperGammaRef(i) + UpperGamma(i))
            if (Test%isDebugMode .and. Test%Image%isFirst) then
                write(Test%outputUnit,"(*(g0,:,', '))")
                write(Test%outputUnit,"(*(g0,:,', '))") "Exponent, LowerLim, Reference UpperGamma, Computed UpperGamma, difference:"
                write(Test%outputUnit,"(*(g0,:,', '))") Exponent(i), LowerLim(i), UpperGamma(i), UpperGammaRef(i), difference
                write(Test%outputUnit,"(*(g0,:,', '))")
            end if
            Test%assertion = difference < epsilon(1._RK) * 1.e2_RK
            call Test%verify()
        end do
        !call Test%skipping()

    end subroutine test_getUpperGamma

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

end module Test_Math_mod


!DECK D1MACH
      DOUBLE PRECISION FUNCTION D1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      DOUBLE PRECISION :: B, X
!***BEGIN PROLOGUE  D1MACH
!***PURPOSE  Return floating point machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      SINGLE PRECISION (D1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   D1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        A = D1MACH(I)
!
!   where I=1,...,5.  The (output) value of A above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   D1MACH(3) = B**(-T), the smallest relative spacing.
!   D1MACH(4) = B**(1-T), the largest relative spacing.
!   D1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
!   EMIN .LE. E .LE. EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by EHG)
!***END PROLOGUE  D1MACH
!
      X = 1.0D0
      B = RADIX(X)
      SELECT CASE (I)
        CASE (1)
          D1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
        CASE (2)
          D1MACH = HUGE(X)               ! the largest magnitude.
        CASE (3)
          D1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
        CASE (4)
          D1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
        CASE (5)
          D1MACH = LOG10(B)
        CASE DEFAULT
          WRITE (*, FMT = 9000)
 9000     FORMAT ('1ERROR    1 IN D1MACH - I OUT OF BOUNDS')
          STOP
      END SELECT
      RETURN
      END


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

 subroutine s( a )
  integer a(10,10)
  do i = 1,10
  do j = 1,10
   a(i,j) = a(i,j) + 1
  enddo
  enddo
 end subroutine

module m
 integer,pointer :: x(:,:)
end module

subroutine t
 use m
 allocate(x(10,10))
 do i = 1,10
 do j = 1,10
  x(i,j) = i+1 + (j-1)*100
 enddo
 enddo
 call s(x)
end subroutine

program p
 use m
 integer res(10,10),exp(10,10)
 data exp/ &
    3,  4,  5,  6,  7,  8,  9, 10, 11, 12, &
  103,104,105,106,107,108,109,110,111,112, &
  203,204,205,206,207,208,209,210,211,212, &
  303,304,305,306,307,308,309,310,311,312, &
  403,404,405,406,407,408,409,410,411,412, &
  503,504,505,506,507,508,509,510,511,512, &
  603,604,605,606,607,608,609,610,611,612, &
  703,704,705,706,707,708,709,710,711,712, &
  803,804,805,806,807,808,809,810,811,812, &
  903,904,905,906,907,908,909,910,911,912/
 call t()
 do i = 1,10
 do j = 1,10
  res(i,j) = x(i,j)
 enddo
 enddo
 call check(res,exp,100)
end program


    program demo_range
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    real(kind=sp)    :: x(2)
    complex(kind=dp) :: y
       print *, precision(x), range(x)
       print *, precision(y), range(y)
    end program demo_range


C File: test_module_09.f
C Purpose: This code is taken from the DSSAT file ModuleDefs.for.  It tests
C          the handling of multiple constant declarations.
C
C Compile and run this program as follows:
C
C    gfortran -c test_module_09.f     # << this will create a file "mymod9.mod"
C    gfortran test_module_09.f        # << this will create a file "a.out"
C
C The output generated by this program is (see test_module_09-OUT.txt):
C
C    20      24    9000     300       3
C  1000      42      40     500     500
C  3.1416   0.0175   1   2   2   3   3

!-------------------------------------------------------------------------------
      MODULE MYMOD9
      INTEGER, PARAMETER ::
     &    NL       = 20,  !Maximum number of soil layers
     &    TS       = 24,  !Number of hourly time steps per day
     &    NAPPL    = 9000,!Maximum number of applications or operations
     &    NCOHORTS = 300, !Maximum number of cohorts
     &    NELEM    = 3,   !Number of elements modeled (currently N & P)
!            Note: set NELEM to 3 for now so Century arrays will match
     &    NumOfDays = 1000, !Maximum days in sugarcane run (FSR)
     &    NStalks = 42,   !Maximum stalks per sugarcane stubble (FSR)
     &    EvalNum = 40,   !Number of evaluation variables
     &    MaxFiles = 500, !Maximum number of output files
     &    MaxPest = 500   !Maximum number of pest operations

      REAL, PARAMETER ::
     &    PI = 3.14159265,
     &    RAD=0.0174532925

      INTEGER, PARAMETER ::
         !Dynamic variable values
     &    RUNINIT  = 1,
     &    INIT     = 2,  !Will take the place of RUNINIT & SEASINIT
                         !     (not fully implemented)
     &    SEASINIT = 2,
     &    RATE     = 3,
     &    EMERG    = 3
      END MODULE MYMOD9

!-------------------------------------------------------------------------------
      PROGRAM PGM
      USE mymod9

 10   FORMAT (5(I6,2X))
 15   FORMAT (2(F8.4,X),5(I3,X))

      write (*,10) NL, TS, NAPPL, NCOHORTS, NELEM
      write (*,10) NumOfDays, NStalks, EvalNum, MaxFiles, MaxPest
      write (*,15) PI, RAD, RUNINIT, INIT, SEASINIT, RATE, EMERG

      stop
      end program PGM
!-------------------------------------------------------------------------------


      SUBROUTINE ENCODE( II )
C
C     THIS SUBROUTINE CONVERTS THE DEGREE OF FREEDOM CODES AS GIVEN
C     IN BULK DATA FORM ( INTEGERS FROM 1-6 ) TO THE BIT PATTERN
C     USED IN SUBSTRUCTURE ANALYSIS.
C
      DIMENSION IDIV(6)
      DATA IDIV/ 100000 , 10000 , 1000 , 100 , 10 , 1 /
C
      ISUM = 0
      DO 1 I=1,6
      J = II/IDIV(I)
      IF( J .EQ. 0 ) GO TO 1
      ISUM = ISUM + 2 ** (J-1)
      II = II - J*IDIV(I)
 1    CONTINUE
      II = ISUM
      RETURN
      END


!
! Module containing averaging procedures
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 17-Feb-2009
!                       paul.vandelst@noaa.gov
!

MODULE Average_Utility

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE Type_Kinds,            ONLY: fp
  USE Message_Handler,       ONLY: SUCCESS, FAILURE, Display_Message
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Boxcar_Average

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
  ! Default message length
  INTEGER, PARAMETER :: ML = 256
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp
  REAL(fp), PARAMETER :: TWO  = 2.0_fp
  REAL(fp), PARAMETER :: ONEpointFIVE = 1.5_fp

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Boxcar_Average
!
! PURPOSE:
!       Function to compute the boxcar average for an input y-vector given
!       a specified bin size for an input x-vector.
!
! CALLING SEQUENCE:
!       Error_Status = Boxcar_Average( x_in, y_in, x1, x2, dx, &  ! Input
!                                      y_out, n_out,           &  ! Output
!                                      RCS_Id     =RCS_Id,     &  ! Revision control
!                                      Message_Log=Message_Log )  ! Error messaging
!
!
! INPUT ARGUMENTS:
!       x_in, y_in:   The tabulated (x,y) vector pairs to be averaged.
!                     The x-spacing doesn't need to be uniform (but it
!                     is recommended).
!                     UNITS:      Argument dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1
!                     ATTRIBUTES: INTENT(IN)
!
!       x1, x2:       The first and last output x-value to report.
!                     UNITS:      Same as input x_in.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1
!                     ATTRIBUTES: INTENT(IN)
!
!       dx:           The width of the averaging window.
!                     UNITS:      Same as input x_in.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1
!                     ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       y_out:        The boxcar average of the y_in data.
!                     UNITS:      Same as input y_in.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
!       n_out:        The number of output averaged points.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:  Character string specifying a filename in which any
!                     messages will be logged. If not specified, or if an
!                     error occurs opening the log file, the default action
!                     is to output messages to standard output.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:       Character string containing the Revision Control
!                     System Id field for the module.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status: The return value is an integer defining the error status.
!                     The error codes are defined in the Message_Handler module.
!                     If == SUCCESS the function executed normally.
!                        == FAILURE an unrecoverable error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 17-Feb-2009
!                       paul.vandelst@noaa.gov
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Boxcar_Average( x_in        , &  ! Input
                           y_in        , &  ! Input
                           x1          , &  ! Input
                           x2          , &  ! Input
                           dx          , &  ! Input
                           y_out       , &  ! Input
                           n_out       , &  ! Output
                           RCS_Id      , &  ! Revision control
                           Message_Log ) &  ! Error messaging
                         RESULT( Error_Status )
    ! Arguments
    REAL(fp)              , INTENT(IN)  :: x_in(:), y_in(:)
    REAL(fp)              , INTENT(IN)  :: x1, x2, dx
    REAL(fp)              , INTENT(OUT) :: y_out(:)
    INTEGER               , INTENT(OUT) :: n_out
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Boxcar_Average'
    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER :: i, n_in, n_avg, j_start, j1, j2, j
    REAL(fp) :: min_dx_in, dx2, max_x_in, x, xb, xe

    ! Setup
    Error_Status = SUCCESS
    IF ( PRESENT(RCS_Id) ) RCS_Id = MODULE_RCS_ID

    ! Compute and check the averaging parameters
    n_in = SIZE(x_in)
    IF ( SIZE(y_in) /= n_in ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X_IN and Y_IN have different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF
    min_dx_in = MINVAL(x_in(2:n_in) - x_in(1:n_in-1))
    IF ( dx < TWO*min_dx_in ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Requested DX output is too small given input X_IN.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF
    n_avg = INT(dx/min_dx_in) + 5  !...plus some slop
    dx2 = dx/TWO
    max_x_in = MAXVAL(x_in)
    IF ( x1-dx2 < x_in(1) .OR. x2+dx2 > max_x_in ) THEN
      Error_Status = FAILURE
      WRITE( msg,'("Input data range (",es13.6,",",es13.6,") insufficient to produce ",&
                  &"average output. Range of at least (",es13.6,",",es13.6,") required")' ) &
                  x_in(1), max_x_in, x1-dx2, x2+dx2
      CALL Display_Message( ROUTINE_NAME,TRIM(msg),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF
    n_out = INT((x2 - x1)/dx + ONEpointFIVE)
    IF ( SIZE(y_out) < n_out ) THEN
      Error_Status = FAILURE
      WRITE( msg,'("Y_OUT size too small (",i0,") for result (",i0,").")' ) SIZE(y_out),n_out
      CALL Display_Message( ROUTINE_NAME,TRIM(msg),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF

    ! Initialise search start point for input
    j_start = 1

    ! Begin the averaging loop over the binned output
    Average: DO i = 1, n_out
      x = x1 + REAL(i-1,fp)*dx
      xb = x - dx2 - SPACING(x); xe = x + dx2 + SPACING(x)
      ! ..Linear search for averaging boundary indices
      ! ..since input x-spacing may not be uniform
      j1_Search: DO j = j_start, n_in
        IF ( x_in(j) >= xb ) THEN
          j1 = j
          j_start = j
          EXIT j1_Search
        END IF
      END DO j1_Search
      j2_Search: DO j = j_start, n_in
        IF ( x_in(j) > xe ) THEN
          j2 = j-1
          j_start = j-1
          EXIT j2_Search
        END IF
      END DO j2_Search
      n_avg = j2-j1+1
      y_out(i) = SUM(y_in(j1:j2)) / REAL(n_avg,fp)
    END DO Average

  END FUNCTION Boxcar_Average

END MODULE Average_Utility


!-------------!
 module system
!-------------!

 integer :: nn
 integer :: nst

 real(8), allocatable :: mat(:,:)
 real(8), allocatable :: vec(:,:)
 real(8), allocatable :: enr(:)
 real(8), allocatable :: spn(:)
 real(8), allocatable :: mag(:)

 end module system
!-----------------!

!================!
 program hchain_0
!================!
 use system; implicit none

 open(10,file='read.in',status='old')
 read(10,*)nn
 close(10)

 nst=2**nn
 allocate(mat(0:nst-1,0:nst-1))
 allocate(vec(0:nst-1,0:nst-1))
 allocate(enr(0:nst-1))
 allocate(spn(0:nst-1))
 allocate(mag(0:nst-1))

 call hamiltonian()
 call diagonalize(nst,mat,vec,enr)

 call spinsquared()
 call transform(nst,mat,vec,spn)
 spn(:)=0.5d0*abs(sqrt(1.d0+4.d0*spn(:))-1.d0)

 call magnetization()

 call writedata()

 deallocate(mat)
 deallocate(vec)
 deallocate(enr)
 deallocate(spn)
 deallocate(mag)

 end program hchain_0
!====================!

!----------------------!
 subroutine writedata()
!----------------------!
 use system; implicit none

 integer :: i

 open(10,file='eig.dat',status='unknown')
 do i=0,nst-1
    write(10,'(i5,3f18.10)')i,enr(i),spn(i),mag(i)
 enddo
 close(10)

 end subroutine writedata
!------------------------!

!------------------------!
 subroutine hamiltonian()
!------------------------!
 use system; implicit none

 integer :: i,j,a,b

 mat(:,:)=0.d0
 do a=0,nst-1
    do i=0,nn-1
       j=mod(i+1,nn)
       if (btest(a,i).eqv.btest(a,j)) then
          mat(a,a)=mat(a,a)+0.25d0
       else
          mat(a,a)=mat(a,a)-0.25d0
          b=ieor(a,2**i+2**j)
          mat(a,b)=mat(a,b)+0.5d0
       endif
    enddo
 enddo

 end subroutine hamiltonian
!--------------------------!

!------------------------!
 subroutine spinsquared()
!------------------------!
 use system; implicit none

 integer :: i,j,a,b,m

 mat(:,:)=0.d0
 do a=0,nst-1
    m=0
    do i=0,nn-1
       if (btest(a,i)) m=m+1
    enddo
    mat(a,a)=dfloat(m-nn/2)**2+0.5d0*dfloat(nn)
    do i=0,nn-1
    do j=i+1,nn-1
       if (btest(a,i).neqv.btest(a,j)) then
          b=ieor(a,2**i+2**j)
          mat(a,b)=mat(a,b)+1.d0
       endif
    enddo
    enddo
 enddo

 end subroutine spinsquared
!--------------------------!

!--------------------------!
 subroutine magnetization()
!--------------------------!
 use system; implicit none

 integer :: i,j,a,b
 integer, allocatable :: mz(:)

 allocate(mz(0:nst-1))
 do a=0,nst-1
    mz(a)=0
    do i=0,nn-1
       if (btest(a,i)) mz(a)=mz(a)+1
    enddo
 enddo
 do a=0,nst-1
    mag(a)=0.d0
    do b=0,nst-1
       mag(a)=mag(a)+mz(b)*vec(b,a)**2
    enddo
 enddo
 mag(:)=(mag(:)-nn/2)*0.5d0
 deallocate(mz)

 end subroutine magnetization
!----------------------------!

!-------------------------------------!
 subroutine diagonalize(n,mat,vec,eig)
!-------------------------------------!
 implicit none

 integer :: n,info
 real(8) :: mat(n,n),vec(n,n),eig(n),work(n*(3+n/2))

 vec=mat
 call dsyev('V','U',n,vec,n,eig,work,n*(3+n/2),info)

 end subroutine diagonalize
!--------------------------!

!-----------------------------------!
 subroutine transform(n,mat,vec,dia)
!-----------------------------------!
 implicit none

 integer :: i,n
 real(8) :: mat(n,n),vec(n,n),dia(n)

 mat=matmul(mat,vec)
 mat=matmul(transpose(vec),mat)
 do i=1,n
    dia(i)=mat(i,i)
 enddo

 end subroutine transform
!------------------------!


PROGRAM F022

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER           :: CH
    CHARACTER (LEN=50)  :: NAME_VAL = ACHAR(0)
    CHARACTER (LEN=50), DIMENSION(5500) :: NAMES_LIST = ACHAR(0)
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/022/p022_names.txt"

    LOGICAL   :: IS_INCREMENTED = .FALSE.

    INTEGER   :: FILE_POS       = 2
    INTEGER   :: COUNT_VAL      = 1
    INTEGER   :: INDEX_VAL      = 1

    INTEGER   :: I, J, N, ALPHA_VAL

    OPEN (2, FILE = FILENAME, STATUS = 'OLD', ACCESS='DIRECT', RECL=1, FORM='UNFORMATTED')

    DO
        READ (2, REC=FILE_POS, ERR=10) CH
        FILE_POS = FILE_POS + 1

        IF ((CH >= 'A' .AND. CH <= 'Z') .OR. (CH >= 'a' .AND. CH <= 'z')) THEN
            IS_INCREMENTED = .FALSE.
            NAME_VAL(INDEX_VAL:INDEX_VAL) = CH
            INDEX_VAL = INDEX_VAL + 1
        ELSE
            IF (.NOT. IS_INCREMENTED) THEN
                INDEX_VAL = 1
                IS_INCREMENTED = .TRUE.

                NAMES_LIST(COUNT_VAL) = NAME_VAL

                COUNT_VAL = COUNT_VAL + 1
                NAME_VAL  = ACHAR(0)
            END IF
        END IF
    END DO

    10 CLOSE(2)

    COUNT_VAL = COUNT_VAL - 1

    DO I = 1, (COUNT_VAL - 1)
        DO J = (I + 1), COUNT_VAL
            IF (NAMES_LIST(I) > NAMES_LIST(J)) THEN
                NAME_VAL      = ACHAR(0)
                NAME_VAL      = NAMES_LIST(I)
                NAMES_LIST(I) = NAMES_LIST(J)
                NAMES_LIST(J) = NAME_VAL
            END IF
        END DO
    END DO

    N = 0

    DO I = 1, COUNT_VAL
        ALPHA_VAL = 0

        DO J = 1, LEN_TRIM(NAMES_LIST(I))
            ALPHA_VAL = ALPHA_VAL + IACHAR(NAMES_LIST(I)(J:J)) - 64
        END DO

        N = N + (I * ALPHA_VAL);
    END DO

    PRINT ('(I0)'), N

END PROGRAM F022


      subroutine splintd(xa,ya,y2a,n,x,y)
      integer n
      real*4 x,y,xa(n),y2a(n),ya(n)
      integer k,khi,klo
      real*4 a,b,h
      data klo,khi /1,1/
      save khi,klo
c     check first of previous klo and khi are still ok.
      if (khi.le.n) then
         if (xa(khi).gt.x .and. xa(klo).lt.x .and. khi-klo.eq.1) goto 2
      endif
c     if not, search by bisection
      klo=1
      khi=n
 1    if (khi-klo.gt.1) then
         k=(khi+klo)/2
         if(xa(k).gt.x)then
            khi=k
         else
            klo=k
         endif
         goto 1
      endif
 2    h=xa(khi)-xa(klo)
      if (h.le.0.) pause 'bad xa input in splint'
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*
     *     (h**2)/6.
      return
      END


!-----------------------------------------------------------------------------
! Copyright (c) 2014, Jared L. Deutsch, Matthew V. Deutsch and Clayton V. Deutsch
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
! THE POSSIBILITY OF SUCH DAMAGE.
!-----------------------------------------------------------------------------

module varsubs
  public :: distance,expgam,setrotmat
contains

  real(kind=8) function distance(xyz_a,xyz_b)
!-----------------------------------------------------------------------
!
!                  Distance given 2 x,y,z vectors
!
! (c) Jared Deutsch, 2014
!-----------------------------------------------------------------------
    real(kind=8), dimension(3), intent(in) :: xyz_a,xyz_b
    distance = sqrt((xyz_a(1)-xyz_b(1))**2 + &
                    (xyz_a(2)-xyz_b(2))**2 + &
                    (xyz_a(3)-xyz_b(3))**2)
  end function distance

  real(kind=8) function expgam(variotail,variohead,variotype, &
                               variotail2,variohead2,variocutcat1,variocutcat2)
!-----------------------------------------------------------------------
!
! Intermediate experimental variogram value given head, tail and type
! values
!
! Notes:
!   - The cross variogram definition used is the full definition
!     where head and tail values are required at u and u+h lags!
!     This is the definition used in GSLIB.
!
! (c) Jared Deutsch, 2014
!-----------------------------------------------------------------------
    implicit none
    real(kind=8), intent(in) :: variotail,variohead
    ! Optional cross variogram and indicator variogram parameters
    real(kind=8), intent(in), optional :: variotail2,variohead2,variocutcat2,variocutcat1
    integer, intent(in) :: variotype
    integer :: tailind,headind,tail2ind,head2ind

    select case (variotype)
      case(1) ! Traditional semivariogram
        expgam = (variotail-variohead)*(variotail-variohead)
      case(2) ! Traditional cross semivariogram
        expgam = (variotail-variohead)*(variotail2-variohead2)
      case(3) ! Covariance (non-ergodic covariance)
        expgam = variotail*variohead
      case(4) ! Correlogram
        expgam = variotail*variohead
      case(5) ! General relative semivariogram
        expgam = (variotail-variohead)*(variotail-variohead)
      case(6) ! Pairwise relative semivariogram
        expgam = (variotail-variohead)*(variotail-variohead)/((variotail+variohead)/2)**2
      case(7) ! Semivariogram of logarithms (ln)
        expgam = (log(variotail)-log(variohead))**2
      case(8) ! Semimadogram
        expgam = abs(variotail-variohead)
      case(9) ! Indicator semivariogram - continuous
        if (variotail .lt. variocutcat1) then
          tailind = 0
        else
          tailind = 1
        end if
        if (variohead .lt. variocutcat1) then
          headind = 0
        else
          headind = 1
        end if
        expgam = (tailind-headind)*(tailind-headind)
      case(10) ! Indicator semivariogram - categorical
        if (int(variotail) .eq. int(variocutcat1)) then
          tailind = 1
        else
          tailind = 0
        end if
        if (int(variohead) .eq. int(variocutcat1)) then
          headind = 1
        else
          headind = 0
        end if
        expgam = (tailind-headind)*(tailind-headind)
      case(11) ! Traditional cross indicator semivariogram - continuous
        if (variotail .lt. variocutcat1) then
          tailind = 0
        else
          tailind = 1
        end if
        if (variohead .lt. variocutcat1) then
          headind = 0
        else
          headind = 1
        end if
        if (variotail2 .lt. variocutcat2) then
          tail2ind = 0
        else
          tail2ind = 1
        end if
        if (variohead2 .lt. variocutcat2) then
          head2ind = 0
        else
          head2ind = 1
        end if
        expgam = (tailind-headind)*(tail2ind-head2ind)
      case(12) ! Traditional cross indicator semivariogram - categorical
        if (int(variotail) .eq. int(variocutcat1)) then
          tailind = 1
        else
          tailind = 0
        end if
        if (int(variohead) .eq. int(variocutcat1)) then
          headind = 1
        else
          headind = 0
        end if
        if (int(variotail2) .eq. int(variocutcat2)) then
          tail2ind = 1
        else
          tail2ind = 0
        end if
        if (int(variohead2) .eq. int(variocutcat2)) then
          head2ind = 1
        else
          head2ind = 0
        end if
        expgam = (tailind-headind)*(tail2ind-head2ind)
      case default
        write(*,*) 'ERROR: Invalid variogram type',variotype
        stop
    end select

  end function expgam

  subroutine setrotmat(azm,dip,tilt,forwardrotmat,reverserotmat)
!-----------------------------------------------------------------------
!
!        Sets up the forward rotation matrix and reverse matrix
!
! (c) Jared Deutsch, 2014
!-----------------------------------------------------------------------
  implicit none
  real(kind=8), parameter :: PI = 4*atan(1.0d0)
  real(kind=8), intent(in) :: azm,dip,tilt
  real(kind=8), dimension(3,3) :: azmrotmat,diprotmat,tiltrotmat
  real(kind=8), dimension(3,3), intent(out) :: forwardrotmat,reverserotmat
  real(kind=8) :: angle

! Get the angle to rotate about the Z axis in radians
  angle = (90d0-azm)*PI/180d0
! Rotation matrix for azimuth correction
  azmrotmat = 0d0
  azmrotmat(3,3) = 1d0
  azmrotmat(1,1) = cos(angle)
  azmrotmat(1,2) = -1d0*sin(angle)
  azmrotmat(2,1) = sin(angle)
  azmrotmat(2,2) = cos(angle)

! Get the angle to rotate about the new X' axis
  angle = -1d0*(dip)*PI/180d0
! Rotation matrix for dip correction
  diprotmat = 0d0
  diprotmat(2,2) = 1d0
  diprotmat(1,1) = cos(angle)
  diprotmat(1,3) = sin(angle)
  diprotmat(3,1) = -1d0*sin(angle)
  diprotmat(3,3) = cos(angle)

! Get the angle to rotate about the new Y' axis
  angle = -1d0*(tilt)*PI/180d0
! Rotation matrix for tilt correction
  tiltrotmat = 0d0
  tiltrotmat(1,1) = 1d0
  tiltrotmat(2,2) = cos(angle)
  tiltrotmat(2,3) = sin(angle)
  tiltrotmat(3,2) = -1d0*sin(angle)
  tiltrotmat(3,3) = cos(angle)

! Complete forward rotation matrix is the product of these 2 matrices
  forwardrotmat = matmul(matmul(azmrotmat,diprotmat),tiltrotmat)
! Reverse rotation matrix is the transpose of the forward matrix
! as these matrices are orthogonal
  reverserotmat = transpose(forwardrotmat)
  end subroutine setrotmat

end module varsubs


      SUBROUTINE FRMLTD (IFILE,DZ,DY,ZM)
C
C     FEER MATRIX TRANSPOSE MULTIPLY  (DOUBLE PREC)
C               T
C     DY = IFILE * DZ        WHERE DZ IS A VECTOR ALREADY IN CORE
C                            IFILE IS A GINO MATIRX FILE
C
C     LAST REVISED  11/91, BY C.CHAN/UNISYS
C     ADDITION OF A NEW TRANSPOSE MULTIPLY METHOD WHICH IS MORE
C     EFFECIENT, AND IS ALREADY GOOD FOR VECTORIZATION
C
CDB   LOGICAL          DEBUG
      DOUBLE PRECISION DZ(1)    ,DY(1)    ,ZM(1)    ,DP     ,DSUM
      DIMENSION        IFILE(7) ,IDP(2)   ,NAM(2)
      COMMON  /UNPAKX/ ITYP     ,IP       ,NP       ,INCR
      COMMON  /SYSTEM/ IBUF     ,NOUT
      COMMON  /FEERXX/ DUM18(18),NZM
      COMMON  /ZZZZZZ/ IZ(1)
      EQUIVALENCE      (DP,IDP(1))
      DATA     NAM   / 4HFRML   ,4HTD    /
CDB   DATA     DEBUG , ITER     ,MAX     / .FALSE.  ,0      ,4       /
C
CDB   IF (.NOT.DEBUG) GO TO 20
C     ITER = ITER + 1
C     IF (ITER .GT. MAX) DEBUG = .FALSE.
C     IF (DEBUG) WRITE (NOUT,10) NZM,IFILE(5)
C  10 FORMAT ('  .... IN FRMLTD DEBUG.   NZM,IFILE(5) =',2I8)
C  20 CONTINUE
      N    = IFILE(2)
      IFL  = IFILE(1)
      IF (IFILE(7) .LT. 0) IFL = -IFILE(7)
      CALL REWIND (IFL)
      CALL SKPREC (IFL,1)
      IF (IFILE(7) .LT. 0) GO TO 50
      ITYP = IFILE(5)
C
C     NASTRAN ORIGIANL METHOD
C
      INCR  = 1
      DO 40 I = 1,N
      DY(I) = 0.0D+0
      IP    = 0
      CALL UNPACK (*40,IFL,ZM(1))
      DSUM  = 0.0D+0
      II    = 0
      DO 30 J = IP,NP
      II    = II + 1
   30 DSUM  = DSUM + ZM(II)*DZ(J)
      DY(I) = DSUM
   40 CONTINUE
      GO TO 200
C
C     NEW METHOD, READ ONLY AND NO UNPACK
C
C     UNLIKE FRMLTX, IFL WAS UNPACKED FORWARD BY UNPSCR
C
   50 NREC = 0
      NWDS = IFILE(5)
CDB   N20  = N - 20
C     IF (DEBUG) WRITE (NOUT,60) NWDS,NZM
C  60 FORMAT ('  /@60   NWDS,NZM =',2I8)
      LL2  = 0
      NEXT = 1
      DO 140 I = 1,N
      IF (NEXT .LT. LL2) GO TO 100
      NREC = NREC + 1
CDB   IF (DEBUG) WRITE (NOUT,70) NREC,I
C  70 FORMAT ('  ...READING RECORD',I5,'.  I =',I7)
      CALL READ (*150,*80,IFL,ZM,NZM,1,LL)
      CALL MESAGE (-8,0,NAM)
   80 LL2  = LL/NWDS
CDB   IF (DEBUG) WRITE (NOUT,90) LL,NREC,LL2
C  90 FORMAT (1X,I10,' WORDS READ FROM RECORD NO.',I5,'   LL2 =',I10)
      NEXT = 1
  100 DP   = ZM(NEXT)
      II   = IDP(1)
      JJ   = IDP(2)
CDB   IF (DEBUG .AND. (I.LT.20 .OR. I.GT.N20)) WRITE (NOUT,110) I,II,JJ,
C     1                                                         NEXT
C 110 FORMAT ('   @110  I,II,JJ,NEXT =',4I8)
      IF (II .EQ. JJ) GO TO 130
      DSUM = 0.0D+0
      LL   = NEXT
      DO 120 J = II,JJ
      LL   = LL + 1
  120 DSUM = DSUM + ZM(LL)*DZ(J)
      DY(I)= DSUM
      GO TO 140
  130 DY(I)= ZM(NEXT+1)*DZ(II)
  140 NEXT = NEXT + JJ - II + 2
      GO TO 200
C
  150 J = IFILE(4)/10
      WRITE  (NOUT,160) NREC,I,N,J
  160 FORMAT ('0*** TRY TO READ RECORD',I5,'.   I,N,IFILE(4) =',2I7,I5)
      CALL MESAGE (-2,IFL,NAM)
C
  200 RETURN
      END


C *****************************************************************************
C FILE: ser_array.f
C DESCRIPTION:
C   Serial Example - Array Assignment - Fortran Version
C   In this simple example, an array is initialized and values assigned.
C AUTHOR: Blaise Barney
C LAST REVISED:  04/15/05
C **************************************************************************

      program array

      integer   ARRAYSIZE
      parameter (ARRAYSIZE = 16000000)
      integer  index, i, tmp
      real*4   data(ARRAYSIZE)

      print *, 'Starting serial array example...'
      tmp = ARRAYSIZE
      print *, 'Using array of',tmp,' real*4. Requires',tmp*4,' bytes'

C     Initialize the array
      print *, 'Initializing array...'
      do 20 i=1, ARRAYSIZE
        data(i) =  i * 1.0
 20   continue

      print *, 'Performing computation on array elements...'
      do 50 i=1, ARRAYSIZE
        data(i) = data(i) + i * 1.0
 50   continue

C     Print some results
      print *, 'Sample Results '
      print *, '   data[',1, ']=', data(1)
      print *, '   data[',100, ']=', data(100)
      print *, '   data[',1000, ']=', data(1000)
      print *, '   data[',10000, ']=', data(10000)
      print *, '   data[',100000, ']=', data(100000)
      print *, '   data[',1000000, ']=', data(1000000)
      print *, ' '
      print *, 'All Done!'

      end


program example1
	implicit none
	integer :: i
    real, dimension(10) :: in, out

	open(1, file = "datos.dat", status = 'new')
	do i = 1, 10
    	write(1,*) (i*2)**2
	end do
    close(1)

    open(2, file = "datos.dat", status = 'old')

    do i = 1, 10
      read(2,*) out(i)
    end do
    close(2)
    do i = 1, 10
      write(*,*) out(i)
    end do
end program example1


program test_conv2d_layer

  use iso_fortran_env, only: stderr => error_unit
  use nf, only: conv2d, input, layer
  use nf_input3d_layer, only: input3d_layer

  implicit none

  type(layer) :: conv_layer, input_layer
  integer, parameter :: filters = 32, kernel_size=3
  real, allocatable :: sample_input(:,:,:), output(:,:,:)
  real, parameter :: tolerance = 1e-7
  logical :: ok = .true.

  conv_layer = conv2d(filters, kernel_size)

  if (.not. conv_layer % name == 'conv2d') then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer has its name set correctly.. failed'
  end if

  if (conv_layer % initialized) then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer should not be marked as initialized yet.. failed'
  end if

  if (.not. conv_layer % activation == 'sigmoid') then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer is defaults to sigmoid activation.. failed'
  end if

  input_layer = input([3, 32, 32])
  call conv_layer % init(input_layer)

  if (.not. conv_layer % initialized) then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer should now be marked as initialized.. failed'
  end if

  if (.not. all(conv_layer % input_layer_shape == [3, 32, 32])) then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer input layer shape should be correct.. failed'
  end if

  if (.not. all(conv_layer % layer_shape == [filters, 30, 30])) then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer input layer shape should be correct.. failed'
  end if

  ! Minimal conv2d layer: 1 channel, 3x3 pixel image;
  allocate(sample_input(1, 3, 3))
  sample_input = 0

  input_layer = input([1, 3, 3])
  conv_layer = conv2d(filters, kernel_size)
  call conv_layer % init(input_layer)

  select type(this_layer => input_layer % p); type is(input3d_layer)
    call this_layer % set(sample_input)
  end select

  call conv_layer % forward(input_layer)
  call conv_layer % get_output(output)

  if (.not. all(abs(output - 0.5) < tolerance)) then
    ok = .false.
    write(stderr, '(a)') 'conv2d layer with zero input and sigmoid function must forward to all 0.5.. failed'
  end if

  if (ok) then
    print '(a)', 'test_conv2d_layer: All tests passed.'
  else
    write(stderr, '(a)') 'test_conv2d_layer: One or more tests failed.'
    stop 1
  end if

end program test_conv2d_layer


!
! FT verification routine.
!
      subroutine verify(n1, n2, n3, nt, cksum, verified)
        implicit none
        include 'npbparams.h'
!
! Arguments.
!

         integer n1, n2, n3, nt
         double complex cksum(0:nt)
         logical verified

!
! Local variables.
!
         integer kt
         double complex cexpd(25)
         real*8 epsilon, err
!
! Initialize tolerance level and success flag.
!
         epsilon = 1.0d-12
         verified = .true.
!
         if ((n1 .eq. 64) .and. (n2 .eq. 64) .and.
     &            (n3 .eq. 64) .and. (nt .eq. 6)) then
!
! Class S reference values.
!
            cexpd(1) = dcmplx(554.6087004964D0, 484.5363331978D0)
            cexpd(2) = dcmplx(554.6385409189D0, 486.5304269511D0)
            cexpd(3) = dcmplx(554.6148406171D0, 488.3910722336D0)
            cexpd(4) = dcmplx(554.5423607415D0, 490.1273169046D0)
            cexpd(5) = dcmplx(554.4255039624D0, 491.7475857993D0)
            cexpd(6) = dcmplx(554.2683411902D0, 493.2597244941D0)

         else if ((n1 .eq. 128) .and. (n2 .eq. 128) .and.
     &            (n3 .eq. 32) .and. (nt .eq. 6)) then
!
! Class W reference values.
!
            cexpd(1) = dcmplx(567.3612178944D0, 529.3246849175D0)
            cexpd(2) = dcmplx(563.1436885271D0, 528.2149986629D0)
            cexpd(3) = dcmplx(559.4024089970D0, 527.0996558037D0)
            cexpd(4) = dcmplx(556.0698047020D0, 526.0027904925D0)
            cexpd(5) = dcmplx(553.0898991250D0, 524.9400845633D0)
            cexpd(6) = dcmplx(550.4159734538D0, 523.9212247086D0)
!
         else if ((n1 .eq. 256) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 128) .and. (nt .eq. 6)) then
!
! Class A reference values.
!
            cexpd(1) = dcmplx(504.6735008193D0, 511.4047905510D0)
            cexpd(2) = dcmplx(505.9412319734D0, 509.8809666433D0)
            cexpd(3) = dcmplx(506.9376896287D0, 509.8144042213D0)
            cexpd(4) = dcmplx(507.7892868474D0, 510.1336130759D0)
            cexpd(5) = dcmplx(508.5233095391D0, 510.4914655194D0)
            cexpd(6) = dcmplx(509.1487099959D0, 510.7917842803D0)
!
         else if ((n1 .eq. 512) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 256) .and. (nt .eq. 20)) then
!
! Class B reference values.
!
            cexpd(1)  = dcmplx(517.7643571579D0, 507.7803458597D0)
            cexpd(2)  = dcmplx(515.4521291263D0, 508.8249431599D0)
            cexpd(3)  = dcmplx(514.6409228649D0, 509.6208912659D0)
            cexpd(4)  = dcmplx(514.2378756213D0, 510.1023387619D0)
            cexpd(5)  = dcmplx(513.9626667737D0, 510.3976610617D0)
            cexpd(6)  = dcmplx(513.7423460082D0, 510.5948019802D0)
            cexpd(7)  = dcmplx(513.5547056878D0, 510.7404165783D0)
            cexpd(8)  = dcmplx(513.3910925466D0, 510.8576573661D0)
            cexpd(9)  = dcmplx(513.2470705390D0, 510.9577278523D0)
            cexpd(10) = dcmplx(513.1197729984D0, 511.0460304483D0)
            cexpd(11) = dcmplx(513.0070319283D0, 511.1252433800D0)
            cexpd(12) = dcmplx(512.9070537032D0, 511.1968077718D0)
            cexpd(13) = dcmplx(512.8182883502D0, 511.2616233064D0)
            cexpd(14) = dcmplx(512.7393733383D0, 511.3203605551D0)
            cexpd(15) = dcmplx(512.6691062020D0, 511.3735928093D0)
            cexpd(16) = dcmplx(512.6064276004D0, 511.4218460548D0)
            cexpd(17) = dcmplx(512.5504076570D0, 511.4656139760D0)
            cexpd(18) = dcmplx(512.5002331720D0, 511.5053595966D0)
            cexpd(19) = dcmplx(512.4551951846D0, 511.5415130407D0)
            cexpd(20) = dcmplx(512.4146770029D0, 511.5744692211D0)
!
         else if ((n1 .eq. 512) .and. (n2 .eq. 512) .and.
     &            (n3 .eq. 512) .and. (nt .eq. 20)) then
!
! Class C reference values.
!
            cexpd(1)  = dcmplx(519.5078707457D0, 514.9019699238D0)
            cexpd(2)  = dcmplx(515.5422171134D0, 512.7578201997D0)
            cexpd(3)  = dcmplx(514.4678022222D0, 512.2251847514D0)
            cexpd(4)  = dcmplx(514.0150594328D0, 512.1090289018D0)
            cexpd(5)  = dcmplx(513.7550426810D0, 512.1143685824D0)
            cexpd(6)  = dcmplx(513.5811056728D0, 512.1496764568D0)
            cexpd(7)  = dcmplx(513.4569343165D0, 512.1870921893D0)
            cexpd(8)  = dcmplx(513.3651975661D0, 512.2193250322D0)
            cexpd(9)  = dcmplx(513.2955192805D0, 512.2454735794D0)
            cexpd(10) = dcmplx(513.2410471738D0, 512.2663649603D0)
            cexpd(11) = dcmplx(513.1971141679D0, 512.2830879827D0)
            cexpd(12) = dcmplx(513.1605205716D0, 512.2965869718D0)
            cexpd(13) = dcmplx(513.1290734194D0, 512.3075927445D0)
            cexpd(14) = dcmplx(513.1012720314D0, 512.3166486553D0)
            cexpd(15) = dcmplx(513.0760908195D0, 512.3241541685D0)
            cexpd(16) = dcmplx(513.0528295923D0, 512.3304037599D0)
            cexpd(17) = dcmplx(513.0310107773D0, 512.3356167976D0)
            cexpd(18) = dcmplx(513.0103090133D0, 512.3399592211D0)
            cexpd(19) = dcmplx(512.9905029333D0, 512.3435588985D0)
            cexpd(20) = dcmplx(512.9714421109D0, 512.3465164008D0)
!
         else if ((n1 .eq. 2048) .and. (n2 .eq. 1024) .and.
     &            (n3 .eq. 1024) .and. (nt .eq. 25)) then
!
! Class D reference values.
!
            cexpd(1)  = dcmplx(512.2230065252D0, 511.8534037109D0)
            cexpd(2)  = dcmplx(512.0463975765D0, 511.7061181082D0)
            cexpd(3)  = dcmplx(511.9865766760D0, 511.7096364601D0)
            cexpd(4)  = dcmplx(511.9518799488D0, 511.7373863950D0)
            cexpd(5)  = dcmplx(511.9269088223D0, 511.7680347632D0)
            cexpd(6)  = dcmplx(511.9082416858D0, 511.7967875532D0)
            cexpd(7)  = dcmplx(511.8943814638D0, 511.8225281841D0)
            cexpd(8)  = dcmplx(511.8842385057D0, 511.8451629348D0)
            cexpd(9)  = dcmplx(511.8769435632D0, 511.8649119387D0)
            cexpd(10) = dcmplx(511.8718203448D0, 511.8820803844D0)
            cexpd(11) = dcmplx(511.8683569061D0, 511.8969781011D0)
            cexpd(12) = dcmplx(511.8661708593D0, 511.9098918835D0)
            cexpd(13) = dcmplx(511.8649768950D0, 511.9210777066D0)
            cexpd(14) = dcmplx(511.8645605626D0, 511.9307604484D0)
            cexpd(15) = dcmplx(511.8647586618D0, 511.9391362671D0)
            cexpd(16) = dcmplx(511.8654451572D0, 511.9463757241D0)
            cexpd(17) = dcmplx(511.8665212451D0, 511.9526269238D0)
            cexpd(18) = dcmplx(511.8679083821D0, 511.9580184108D0)
            cexpd(19) = dcmplx(511.8695433664D0, 511.9626617538D0)
            cexpd(20) = dcmplx(511.8713748264D0, 511.9666538138D0)
            cexpd(21) = dcmplx(511.8733606701D0, 511.9700787219D0)
            cexpd(22) = dcmplx(511.8754661974D0, 511.9730095953D0)
            cexpd(23) = dcmplx(511.8776626738D0, 511.9755100241D0)
            cexpd(24) = dcmplx(511.8799262314D0, 511.9776353561D0)
            cexpd(25) = dcmplx(511.8822370068D0, 511.9794338060D0)
!
         else if ((n1 .eq. 4096) .and. (n2 .eq. 2048) .and.
     &            (n3 .eq. 2048) .and. (nt .eq. 25)) then
!
! Class E reference values.
!
            cexpd(1)  = dcmplx(512.1601045346D0, 511.7395998266D0)
            cexpd(2)  = dcmplx(512.0905403678D0, 511.8614716182D0)
            cexpd(3)  = dcmplx(512.0623229306D0, 511.9074203747D0)
            cexpd(4)  = dcmplx(512.0438418997D0, 511.9345900733D0)
            cexpd(5)  = dcmplx(512.0311521872D0, 511.9551325550D0)
            cexpd(6)  = dcmplx(512.0226088809D0, 511.9720179919D0)
            cexpd(7)  = dcmplx(512.0169296534D0, 511.9861371665D0)
            cexpd(8)  = dcmplx(512.0131225172D0, 511.9979364402D0)
            cexpd(9)  = dcmplx(512.0104767108D0, 512.0077674092D0)
            cexpd(10) = dcmplx(512.0085127969D0, 512.0159443121D0)
            cexpd(11) = dcmplx(512.0069224127D0, 512.0227453670D0)
            cexpd(12) = dcmplx(512.0055158164D0, 512.0284096041D0)
            cexpd(13) = dcmplx(512.0041820159D0, 512.0331373793D0)
            cexpd(14) = dcmplx(512.0028605402D0, 512.0370938679D0)
            cexpd(15) = dcmplx(512.0015223011D0, 512.0404138831D0)
            cexpd(16) = dcmplx(512.0001570022D0, 512.0432068837D0)
            cexpd(17) = dcmplx(511.9987650555D0, 512.0455615860D0)
            cexpd(18) = dcmplx(511.9973525091D0, 512.0475499442D0)
            cexpd(19) = dcmplx(511.9959279472D0, 512.0492304629D0)
            cexpd(20) = dcmplx(511.9945006558D0, 512.0506508902D0)
            cexpd(21) = dcmplx(511.9930795911D0, 512.0518503782D0)
            cexpd(22) = dcmplx(511.9916728462D0, 512.0528612016D0)
            cexpd(23) = dcmplx(511.9902874185D0, 512.0537101195D0)
            cexpd(24) = dcmplx(511.9889291565D0, 512.0544194514D0)
            cexpd(25) = dcmplx(511.9876028049D0, 512.0550079284D0)
!
         else
!
            write (*,    120) 'not performed'
            verified = .false.
!
         end if
!
! Verification test for results.
!
         if (verified) then

            do kt = 1, nt
              err = abs((cksum(kt)-cexpd(kt))/cexpd(kt))
              if (.not.(err.le.epsilon)) then
                verified = .false.
                goto 100
              endif
            end do
  100       continue

            if (verified) then
               write (*,    120) 'successful'
            else
               write (*,    120) 'failed'
            end if

  120       format (' Verification test for FT ', a)
         end if
!
         return
      end