      SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the (scrambled) discrete Hartley transform of
C     a real signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SCR     CHARACTER*1
C             Indicates whether the signal is scrambled on input or
C             on output as follows:
C             = 'N':  the signal is not scrambled at all;
C             = 'I':  the input signal is bit-reversed;
C             = 'O':  the output transform is bit-reversed.
C
C     WGHT    CHARACTER*1
C             Indicates whether the precomputed weights are available
C             or not, as follows:
C             = 'A':  available;
C             = 'N':  not available.
C             Note that if N > 1 and WGHT = 'N' on entry, then WGHT is
C             set to 'A' on exit.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             Number of real samples. N must be a power of 2.
C             N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry with SCR = 'N' or SCR = 'O', this array must
C             contain the input signal.
C             On entry with SCR = 'I', this array must contain the
C             bit-reversed input signal.
C             On exit with SCR = 'N' or SCR = 'I', this array contains
C             the Hartley transform of the input signal.
C             On exit with SCR = 'O', this array contains the
C             bit-reversed Hartley transform.
C
C     W       (input/output) DOUBLE PRECISION array,
C                            dimension (N - LOG2(N))
C             On entry with WGHT = 'A', this array must contain the long
C             weight vector computed by a previous call of this routine
C             with the same value of N. If WGHT = 'N', the contents of
C             this array on entry is ignored.
C             On exit, this array contains the long weight vector.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     This routine uses a Hartley butterfly algorithm as described
C     in [1].
C
C     REFERENCES
C
C     [1] Van Loan, Charles.
C         Computational frameworks for the fast Fourier transform.
C         SIAM, 1992.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable and requires O(N log(N))
C     floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, April 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     KEYWORDS
C
C     Digital signal processing, fast Hartley transform, real signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO, FOUR
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SCR, WGHT
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), W(*)
C     .. Local Scalars ..
      INTEGER           I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2,
     $                  WPOS
      LOGICAL           LFWD, LSCR, LWGHT
      DOUBLE PRECISION  CF, SF, T1, T2, TH
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, COS, DBLE, MOD, SIN
C     .. Executable Statements ..
C
      INFO  = 0
      LFWD  = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' )
      LSCR  = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' )
      LWGHT = LSAME( WGHT, 'A' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.( LFWD .OR. LSCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN
         INFO = -2
      ELSE
         M = 0
         J = 0
         IF( N.GE.1 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               M = M + 1
               GO TO 10
            END IF
C           END WHILE 10
            IF ( J.NE.1 ) INFO = -3
         ELSE IF ( N.LT.0 ) THEN
            INFO = -3
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DG01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.LE.1 )
     $   RETURN
C
      IF ( .NOT. LWGHT ) THEN
C
C        Compute the long weight vector via subvector scaling.
C
         R1  = 1
         LEN = 1
         TH  = FOUR*ATAN( ONE ) / DBLE( N )
C
         DO 30 L = 1, M - 2
            LEN = 2*LEN
            TH  = TWO*TH
            CF  = COS(TH)
            SF  = SIN(TH)
            W(R1)   = CF
            W(R1+1) = SF
            R1 = R1 + 2
C
            DO 20 I = 1, LEN - 2, 2
               W(R1)   = CF*W(I) - SF*W(I+1)
               W(R1+1) = SF*W(I) + CF*W(I+1)
               R1 = R1 + 2
   20       CONTINUE
C
   30    CONTINUE
C
         P1 = 3
         Q1 = R1 - 2
C
         DO 50 L = M - 2, 1, -1
C
            DO 40 I = P1, Q1, 4
               W(R1)   = W(I)
               W(R1+1) = W(I+1)
               R1 = R1 + 2
   40       CONTINUE
C
            P1 = Q1 + 4
            Q1 = R1 - 2
   50    CONTINUE
C
         WGHT = 'A'
C
      END IF
C
      IF ( LFWD .AND. .NOT.LSCR ) THEN
C
C        Inplace shuffling of data.
C
         J = 1
C
         DO 70 I = 1, N
            IF ( J.GT.I ) THEN
               T1   = A(I)
               A(I) = A(J)
               A(J) = T1
            END IF
            L = N/2
C           REPEAT
   60       IF ( J.GT.L ) THEN
               J = J - L
               L = L/2
               IF ( L.GE.2 ) GO TO 60
            END IF
C           UNTIL ( L.LT.2 )
            J = J + L
   70    CONTINUE
C
      END IF
C
      IF ( LFWD ) THEN
C
C        Compute Hartley transform with butterfly operators.
C
         DO 110 J = 2, N, 2
            T1 = A(J)
            A(J)   = A(J-1) - T1
            A(J-1) = A(J-1) + T1
  110    CONTINUE
C
         LEN  = 1
         WPOS = N - 2*M + 1
C
         DO 140 L = 1, M - 1
            LEN = 2*LEN
            P2  = 1
            Q2  = LEN + 1
            R2  = LEN / 2 + 1
            S2  = R2 + Q2 - 1
C
            DO 130 I = 0, N/( 2*LEN ) - 1
               T1    = A(Q2)
               A(Q2) = A(P2) - T1
               A(P2) = A(P2) + T1
               T1    = A(S2)
               A(S2) = A(R2) - T1
               A(R2) = A(R2) + T1
C
               P1 = P2 + 1
               Q1 = P1 + LEN
               R1 = Q1 - 2
               S1 = R1 + LEN
C
               DO 120 J = WPOS, WPOS + LEN - 3, 2
                  CF = W(J)
                  SF = W(J+1)
                  T1 =  CF*A(Q1) + SF*A(S1)
                  T2 = -CF*A(S1) + SF*A(Q1)
                  A(Q1) = A(P1) - T1
                  A(P1) = A(P1) + T1
                  A(S1) = A(R1) - T2
                  A(R1) = A(R1) + T2
                  P1 = P1 + 1
                  Q1 = Q1 + 1
                  R1 = R1 - 1
                  S1 = S1 - 1
  120          CONTINUE
C
               P2 = P2 + 2*LEN
               Q2 = Q2 + 2*LEN
               R2 = R2 + 2*LEN
               S2 = S2 + 2*LEN
  130       CONTINUE
C
            WPOS = WPOS - 2*LEN + 2
  140    CONTINUE
C
      ELSE
C
C        Compute Hartley transform with transposed butterfly operators.
C
         WPOS = 1
         LEN  = N
C
         DO 230 L = M - 1, 1, -1
            LEN = LEN / 2
            P2  = 1
            Q2  = LEN + 1
            R2  = LEN / 2 + 1
            S2  = R2 + Q2 - 1
C
            DO 220 I = 0, N/( 2*LEN ) - 1
               T1    = A(Q2)
               A(Q2) = A(P2) - T1
               A(P2) = A(P2) + T1
               T1    = A(S2)
               A(S2) = A(R2) - T1
               A(R2) = A(R2) + T1
C
               P1 = P2 + 1
               Q1 = P1 + LEN
               R1 = Q1 - 2
               S1 = R1 + LEN
C
               DO 210 J = WPOS, WPOS + LEN - 3, 2
                  CF = W(J)
                  SF = W(J+1)
                  T1 = A(P1) - A(Q1)
                  T2 = A(R1) - A(S1)
                  A(P1) = A(P1) + A(Q1)
                  A(R1) = A(R1) + A(S1)
                  A(Q1) =  CF*T1 + SF*T2
                  A(S1) = -CF*T2 + SF*T1
                  P1 = P1 + 1
                  Q1 = Q1 + 1
                  R1 = R1 - 1
                  S1 = S1 - 1
  210          CONTINUE
C
               P2 = P2 + 2*LEN
               Q2 = Q2 + 2*LEN
               R2 = R2 + 2*LEN
               S2 = S2 + 2*LEN
  220       CONTINUE
C
            WPOS = WPOS + LEN - 2
  230    CONTINUE
C
         DO 240 J = 2, N, 2
            T1 = A(J)
            A(J)   = A(J-1) - T1
            A(J-1) = A(J-1) + T1
  240    CONTINUE
C
      END IF
      RETURN
C *** Last line of DG01OD ***
      END


      SUBROUTINE pearsn(x,y,n,r,prob,z)
      INTEGER n
      REAL prob,r,z,x(n),y(n),TINY
      PARAMETER (TINY=1.e-20)
CU    USES betai
      INTEGER j
      REAL ax,ay,df,sxx,sxy,syy,t,xt,yt,betai
      ax=0.
      ay=0.
      do 11 j=1,n
        ax=ax+x(j)
        ay=ay+y(j)
11    continue
      ax=ax/n
      ay=ay/n
      sxx=0.
      syy=0.
      sxy=0.
      do 12 j=1,n
        xt=x(j)-ax
        yt=y(j)-ay
        sxx=sxx+xt**2
        syy=syy+yt**2
        sxy=sxy+xt*yt
12    continue
      r=sxy/(sqrt(sxx*syy)+TINY)
      z=0.5*log(((1.+r)+TINY)/((1.-r)+TINY))
      df=n-2
      t=r*sqrt(df/(((1.-r)+TINY)*((1.+r)+TINY)))
      prob=betai(0.5*df,0.5,df/(df+t**2))
C     prob=erfcc(abs(z*sqrt(n-1.))/1.4142136)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/pearsn.for


use SeismicAnalysisClass

type(SeismicAnalysis_) :: seismic
real(real64) :: u(1),v(1),a(1),u_n(1),v_n(1),a_n(1)
real(real64) :: u_upd(1),v_upd(1),a_upd(1)
real(real64) :: beta, gamma, dt, T
real(real64) :: M(1,1), K(1,1), C(1,1),force(1)
real(real64) :: Amat(1,1),bvec(1),omega

integer(int32) :: i
type(Math_) :: math
type(IO_) :: f,fu,fv,fa
! 1-D problem
! with sin wave

M = 1.0d0
K = 2000.0d0
!C =0.0d0
C = 0.52400d0*M + 0.00129d0*K
C = 0.50d0*C
omega = sqrt( K(1,1)/M(1,1) ) ! natural period
T = 2.0d0*math%PI/omega

beta = 0.250d0
gamma = 0.50d0

u_n = 1.0d0
v_n = 0.0d0
a_n = 0.0d0

call f%open("1D_seismic_result.csv")
call fu%open("seismic_u.txt")
call fv%open("seismic_v.txt")
call fa%open("seismic_a.txt")
! V&V
! fix time = t=smt, caluculate numerical/analytical solution, plot errors.

do i=1,30000

    dt = dble(1.0e-4)

    ! do not destroy the second order accuracy.
    !force =0.10d0*sin(dble(i)*dt/T)
    force = 0.0d0
    !if(i<10)then
    !    force = 1.0d0
    !else
    !    force = 0.0d0
    !endif

    Amat = seismic%getNewmarkBetaMatrix(M=M, C=C,K=K,beta=beta,gamma=gamma,dt=dt)
    bvec = seismic%getNewmarkBetaVector(M=M,C=C,u_n=u_n,v_n=v_n, a_n=a_n, &
        force=force,beta=beta,gamma=gamma,dt=dt)

    ! update
    ! Solve Au = b
    u_upd = 1.0d0/Amat(1,1)*bvec(1)

    v_upd = seismic%updateVelocityNewmarkBeta(u=u_upd,u_n=u_n,v_n=v_n,a_n=a_n,&
        gamma=gamma,beta=beta,dt=dt)
    a_upd = seismic%updateAccelNewmarkBeta(u=u_upd,u_n=u_n,v_n=v_n,a_n=a_n,&
        gamma=gamma,beta=beta,dt=dt)

    u_n = u_upd
    v_n = v_upd
    a_n = a_upd

    write(fu%fh,*)dble(i-1)*dt,u_n
    write(fv%fh,*)dble(i-1)*dt,v_n
    write(fa%fh,*)dble(i-1)*dt,a_n

    write(f%fh,*)dble(i-1)*dt,",",u_n,",",v_n,",",a_n,",",force
enddo
call f%close()
call fu%close()
call fv%close()
call fa%close()
print *, "Natural period : ",T," sec."

end


module loglikelihood_module
    use utils_module, only: dp

    real(dp), parameter :: sigma = 0.1  ! width of peak

    real(dp), allocatable, dimension(:,:)  :: invcovmat    ! inverse covariance matrix
    real(dp), allocatable, dimension(:)    :: mu           ! Mean
    real(dp)                               :: logdetcovmat ! log(det(covariance matrix))

    contains
    !> Random Correlated gaussian loglikelihood
    !!
    !! It is normalised so that it should output an evidence of 1.0 for
    !! effectively infinite priors.

    function loglikelihood(theta,phi)
        use utils_module, only: log_gauss
        implicit none
        !> Input parameters
        real(dp), intent(in), dimension(:)   :: theta
        !> Output derived parameters
        real(dp), intent(out),  dimension(:) :: phi

        real(dp) :: loglikelihood

        ! Compute log likelihood
        loglikelihood = log_gauss(theta,mu,invcovmat,logdetcovmat)

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
#ifdef MPI
        use mpi_module
#endif
        use settings_module,   only: program_settings
        use random_module,     only: random_inverse_covmat
        implicit none
        type(program_settings), intent(in) :: settings

        integer :: nDims

        ! Get the dimensionality from settings
        nDims = settings%nDims

        ! Allocate the mean vector and inverse covariance matrix
        allocate(mu(nDims),invcovmat(nDims,nDims))

        ! Create a mean vector at the center of the space
        mu = 0.5d0

        ! Generate a random covariance matrix, its inverse and logdet on the root node
        call initialise_mpi
        call random_inverse_covmat(invcovmat,logdetcovmat,sigma,nDims)

#ifdef MPI
        ! Broadcast the covariance matrix and normalisation data to the
        ! rest of the nodes
        ! Covariance matrix:
        call MPI_BCAST(           &
            invcovmat,            & ! inverse covariance matrix data to be broadcast
            nDims*nDims,          & ! size of the data
            MPI_DOUBLE_PRECISION, & ! type of data
            0,                    & ! root node id
            MPI_COMM_WORLD,       & ! communication info
            mpierror)               ! error (from mpiutils)
        ! normalisation logdet covmat
        call MPI_BCAST(           &
            logdetcovmat,         & ! log(determinant of inverse covariance matrix) data to be broadcast
            1,                    & ! size of the data
            MPI_DOUBLE_PRECISION, & ! type of data
            0,                    & ! root node id
            MPI_COMM_WORLD,       & ! communication info
            mpierror)               ! error (from mpiutils)
#endif

    end subroutine setup_loglikelihood

end module loglikelihood_module


program Primes

    use ISO_FORTRAN_ENV

    implicit none

    integer(int64), dimension(7) :: data = (/2099726827, 15780709, 1122725370, 15808973, 576460741, 12878611, 12757923/)
    integer(int64), dimension(100) :: outprimes
    integer(int64) :: largest_factor = 0, largest = 0, minim = 0, val = 0
    integer(int16) :: count = 0, OMP_GET_THREAD_NUM

    call omp_set_num_threads(4);
    !$omp parallel do private(val,outprimes,count) shared(data,largest_factor,largest)
    do val = 1, 7
        outprimes = 0
        call find_factors(data(val), outprimes, count)
        minim = minval(outprimes(1:count))
        if (minim > largest_factor) then
            largest_factor = minim
            largest = data(val)
        end if
        write(*, fmt = '(A7,i0,A2,i12,100i12)') 'Thread ', OMP_GET_THREAD_NUM(), ': ', data(val), outprimes(1:count)
    end do
    !$omp end parallel do

    write(*, fmt = '(i0,A26,i0)') largest, ' have the Largest factor: ', largest_factor

    return

contains

    subroutine find_factors(n, d, count)
        integer(int64), intent(in) :: n
        integer(int64), dimension(:), intent(out) :: d
        integer(int16), intent(out) :: count
        integer(int16) :: i
        integer(int64) :: div, next, rest

        i = 1
        div = 2; next = 3; rest = n

        do while (rest /= 1)
            do while (mod(rest, div) == 0)
                d(i) = div
                i = i + 1
                rest = rest / div
            end do
            div = next
            next = next + 2
        end do
        count = i - 1
    end subroutine find_factors

end program Primes


module Const
    implicit none

    integer,parameter    :: mpc=8  ! Параметр разновидности типа для real
    real(mpc), parameter :: EPS = epsilon(1.0_mpc)
    real(mpc), parameter :: phi = (1.0_mpc + sqrt(5.0_mpc))/2.0_mpc
    real(mpc), parameter :: Pi  = atan(1.0_mpc)*4.0_mpc

    !> error codes
    integer,parameter :: &
        &EXIT_SUCCESS = 0&
        &,EXIT_FAILURE = 1&
        &;
end module Const


program test
    ! gfortran -O3 matr4.f90 -o matr4
    implicit none
    integer :: n, stat, i, j
    character(len=32) :: nstr
    real, allocatable :: fs(:), sines(:, :), res(:)
    real :: dt, tic, toc
    real, parameter :: pi = 4*atan(1.)

    if (command_argument_count() < 1) then
        stop 'ERROR must supply array size as command line argument'
    endif
    call get_command_argument(1, nstr)
    read(nstr, *, iostat=stat) n

    allocate(fs(n), sines(n, n), res(n))
    do j = 1, n
        fs(j) = j
        do i = 1, n
            sines(i, j) = sin(i*j*pi/real(n + 1, 8))
        enddo
    enddo

    call cpu_time(tic)
    res = matmul(sines, fs)
    call cpu_time(toc)
    dt = toc - tic
    print *,'matr4 n = ', n, ' time = ', dt, ' secs res = ', sum(res)
end program test