module sw_core
    use sw_utils
    implicit none
    private
    public swInitialize
    public swRK4SolveStep

contains
    subroutine swInitialize()
        implicit none
        ! integrating variables
        integer :: idx

        ! creating dimensions
        do idx=1, NX
            xdata(idx) = XLOWER + DX * dble(idx-1)
        enddo

        do idx=1, NY
            ydata(idx) = YLOWER + DY * dble(idx-1)
        enddo

        ! Initialize 2D meshgrid
        call swMeshgrid(xdata, ydata, xxdata, yydata, NX, NY)

        do idx=1, NT
            tdata(idx) = TSTART + DT * dble(idx-1)
        enddo

        write(*, *) "Initialized dimensions!"

        ! fill the coriolis data array
        do idx=1, NY
            fdata(:, idx) = 2.0_idp * OMEGA * sin(PI*ydata(idx)/YLENGTH)
        enddo

        write(*, *) "Computed corilios parameters array!"

        !udata(:, :, 1) = 0.0_idp
        vdata(:, :, 1) = 0.0_idp
        call random_number(udata(:, :, 1))
        !call random_number(vdata(:, :, 1))
        hdata(:, :, 1) = H0 - PERTURB*exp(-(xxdata**2.0_idp + yydata**2.0_idp))

        write(*, *) "Initialized data variables!"

    end subroutine swInitialize

    ! ---
    subroutine swRK4SolveStep(t)
        !use sw_utils
        implicit none
        integer, intent(in) :: t
        ! time multiplier constants
        real(idp), parameter :: DT6 = DT/6.0_idp
        real(idp), parameter :: DT2 = DT*0.5_idp
        ! create trends
        real(idp), dimension(:, :), allocatable :: uo, un
        real(idp), dimension(:, :), allocatable :: vo, vn
        real(idp), dimension(:, :), allocatable :: ho, hn
        real(idp), dimension(:, :), allocatable :: ku1, ku2, ku3, ku4
        real(idp), dimension(:, :), allocatable :: kv1, kv2, kv3, kv4
        real(idp), dimension(:, :), allocatable :: kh1, kh2, kh3, kh4

        if (.not. allocated(uo)) then
            allocate(uo(NX, NY))
        endif
        if (.not. allocated(un)) then
            allocate(un(NX, NY))
        endif
        if (.not. allocated(vo)) then
            allocate(vo(NX, NY))
        endif
        if (.not. allocated(vn)) then
            allocate(vn(NX, NY))
        endif
        if (.not. allocated(ho)) then
            allocate(ho(NX, NY))
        endif
        if (.not. allocated(hn)) then
            allocate(hn(NX, NY))
        endif
        if (.not. allocated(ku1)) then
            allocate(ku1(NX, NY))
        endif
        if (.not. allocated(ku2)) then
            allocate(ku2(NX, NY))
        endif
        if (.not. allocated(ku3)) then
            allocate(ku3(NX, NY))
        endif
        if (.not. allocated(ku4)) then
            allocate(ku4(NX, NY))
        endif
        if (.not. allocated(kv1)) then
            allocate(kv1(NX, NY))
        endif
        if (.not. allocated(kv2)) then
            allocate(kv2(NX, NY))
        endif
        if (.not. allocated(kv3)) then
            allocate(kv3(NX, NY))
        endif
        if (.not. allocated(kv4)) then
            allocate(kv4(NX, NY))
        endif
        if (.not. allocated(kh1)) then
            allocate(kh1(NX, NY))
        endif
        if (.not. allocated(kh2)) then
            allocate(kh2(NX, NY))
        endif
        if (.not. allocated(kh3)) then
            allocate(kh3(NX, NY))
        endif
        if (.not. allocated(kh4)) then
            allocate(kh4(NX, NY))
        endif

        ! old values
        uo = udata(:, :, t)
        vo = vdata(:, :, t)
        ho = hdata(:, :, t)

        ! RK4 Step
        ! step 1
        call solveGrid(ku1, kv1, kh1, uo, vo, ho)
        ! step 2
        call solveGrid(ku2, kv2, kh2, uo+ku1*DT2, vo+kv1*DT2, ho+kh1*DT2)
        ! step 3
        call solveGrid(ku3, kv3, kh3, uo+ku2*DT2, vo+kv2*DT2, ho+kh2*DT2)
        ! step 4
        call solveGrid(ku4, kv4, kh4, uo+ku3*DT, vo+kv3*DT, ho+kh3*DT)

        ! final step and time marching
        un = uo + (ku1 + 2.0_idp*ku2 + 2.0_idp*ku3 + ku4)*DT6
        vn = uo + (kv1 + 2.0_idp*kv2 + 2.0_idp*kv3 + kv4)*DT6
        hn = uo + (kh1 + 2.0_idp*kh2 + 2.0_idp*kh3 + kh4)*DT6

        ! update
        udata(:, :, t+1) = un
        vdata(:, :, t+1) = vn
        hdata(:, :, t+1) = hn
        deallocate(uo)
        deallocate(un)
        deallocate(vo)
        deallocate(vn)
        deallocate(ho)
        deallocate(hn)
        deallocate(ku1)
        deallocate(ku2)
        deallocate(ku3)
        deallocate(ku4)
        deallocate(kv1)
        deallocate(kv2)
        deallocate(kv3)
        deallocate(kv4)
        deallocate(kh1)
        deallocate(kh2)
        deallocate(kh3)
        deallocate(kh4)

    end subroutine swRK4SolveStep

    ! ---
    subroutine solveGrid(uout, vout, hout, uin, vin, hin)
        implicit none
        real(idp), dimension(1:NX, 1:NY), intent(in):: uin, vin, hin
        real(idp), dimension(1:NX, 1:NY), intent(out):: uout, vout, hout

        ! local variables
        integer :: i, j
        integer :: xb, xc, xf, yb, yc, yf
        real(idp), parameter :: dx_half = 0.5_idp * DX
        real(idp), parameter :: dy_half = 0.5_idp * DY
        ! G x ...
        real(idp), parameter :: gdx_half = (G * dx_half)
        real(idp), parameter :: gdy_half = (G * dy_half)
        ! diffusion multipliers
        real(idp), parameter :: nudxx = nu / (DX * DX)
        real(idp), parameter :: nudyy = nu / (DY * DY)
        ! advection terms
        real(idp) :: hx, hy, ux, uy, vx, vy
        ! coriolis terms
        real(idp) :: fu, fv
        ! gravity/pressure gradient terms
        real(idp) :: gx, gy
        ! viscosity terms
        real(idp) :: bu, bv
        ! diffusion terms
        real(idp) :: uxx, uyy, vxx, vyy

        do j=1, NY
            call getIndices(j, NY, yb, yc, yf)
            do i=1, NX
                call getIndices(i, NX, xb, xc, xf)
                ! hx term in continuity equation
                hx = (hin(xf, yc)*uin(xf, yc) - hin(xb, yc)*uin(xb, yc))*dx_half
                ! hy term int continuty equation
                hy = (hin(xc, yf)*vin(xc, yf) - hin(xc, yb)*vin(xc, yb))*dy_half
                ! ux term in x-momentum equation
                ux = uin(xc, yc)*(uin(xf, yc) - uin(xb, yc))*dx_half
                ! uy term in x-momentum equation
                uy = vin(xc, yc)*(uin(xc, yf) - uin(xc, yb))*dy_half
                ! vx term in x-momentum equation
                vx = uin(xc, yc)*(vin(xf, yc) - vin(xb, yc))*dx_half
                ! vy term in x-momentum equation
                vy = vin(xc, yc)*(vin(xc, yf) - vin(xc, yb))*dy_half
                ! fv term in x-momentum equation
                fv = fdata(xc, yc)*vin(xc, yc)
                ! fu term in y-momentum equation
                fu = fdata(xc, yc)*uin(xc, yc)
                ! ghx term in x-momentum equation
                gx = (hin(xf, yc) - hin(xb, yc))*gdx_half
                ! ghy term in y-momentum equation
                gy = (hin(xc, yf) - hin(xc, yb))*gdy_half
                ! bu term in x-momentum equation
                bu = vd*uin(xc, yc)
                ! bv term in y-momentum equation
                bv = vd*vin(xc, yc)
                ! uxx diffusion term in x-momentum
                uxx = (uin(xf, yc) - 2.0_idp*uin(xc, yc) + uin(xb, yc))*nudxx
                ! uyy diffusion term in x-momentum equation
                uyy = (uin(xc, yf) - 2.0_idp*uin(xc, yc) + uin(xc, yb))*nudyy
                ! vxx diffusion term in y-momentum equation
                vxx = (vin(xf, yc) - 2.0_idp*vin(xc, yc) + vin(xb, yc))*nudxx
                ! vyy diffusion term in y-momentum equation
                vyy = (vin(xc, yf) - 2.0_idp*vin(xc, yc) + vin(xc, yb))*nudyy

                ! summing up all terms in continuity equation
                hout(i, j) = -(hx + hy)
                ! summing up all terms in x-momentum equation
                uout(i, j) = -(ux+uy) + fv - gx - bu + (uxx + uyy)
                ! summing up all terms in y-momentum equation
                vout(i, j) = -(vx + vy) - fu - gy - bv + (vxx + vyy)
            enddo
        enddo
    end subroutine solveGrid

    ! ---
    subroutine getIndices(idx, nx, xb, xc, xf)
        implicit none
        integer, intent(in) :: idx, nx
        integer, intent(out) :: xb, xc, xf

        if( idx == 1) then
            xb = nx
            xc = idx
            xf = idx+1
        else if(idx == nx) then
            xb = idx-1
            xc = idx
            xf = 1
        else
            xb = idx-1
            xc = idx
            xf = idx+1
        endif
    end subroutine getIndices
end module sw_core


MODULE cross_products

! mbp 1/2012

  IMPLICIT NONE

  INTERFACE cross_product
     MODULE PROCEDURE cross_product_sngl, cross_product_dble
  END INTERFACE cross_product

CONTAINS
  FUNCTION cross_product_sngl( a, b )
    REAL (KIND=4), DIMENSION( 3 ) :: cross_product_sngl
    REAL (KIND=4), DIMENSION( 3 ), INTENT(  IN ) :: a, b

    cross_product_sngl( 1 ) = a( 2 ) * b( 3 ) - a( 3 ) * b( 2 )
    cross_product_sngl( 2 ) = a( 3 ) * b( 1 ) - a( 1 ) * b( 3 )
    cross_product_sngl( 3 ) = a( 1 ) * b( 2 ) - a( 2 ) * b( 1 )

  END FUNCTION cross_product_sngl

  FUNCTION cross_product_dble( a, b )
    REAL (KIND=8), DIMENSION( 3 ) :: cross_product_dble
    REAL (KIND=8), DIMENSION( 3 ), INTENT(  IN ) :: a, b

    cross_product_dble( 1 ) = a( 2 ) * b( 3 ) - a( 3 ) * b( 2 )
    cross_product_dble( 2 ) = a( 3 ) * b( 1 ) - a( 1 ) * b( 3 )
    cross_product_dble( 3 ) = a( 1 ) * b( 2 ) - a( 2 ) * b( 1 )

  END FUNCTION cross_product_dble
END MODULE cross_products


        subroutine regrid(a,ar,nx,ny,xref,yref,x0,y0,rmag)

! Regrid array a (nx by ny) onto an array, ar, of the same size, such
! that pixel (x0,y0) gets moved to (xref,yref) with a magnification
! factor of rmag.

        implicit real (a-h,o-z)
        implicit integer (i-n)

        real,   intent(in),                        &
        &       dimension(nx,ny)        ::   a      ! input array

        real,   intent(out),                       &
        &       dimension(nx,ny)        ::   ar     ! output (resampled) array

        real(8),   allocatable             ::   grid(:,:)
        real(8) x,xmin,xmax,y,ymin,ymax,z,zx,zy,zxx,zyy,zxy
        integer(4) xref,yref

        allocate( grid(0:nx, 0:ny) )
        grid = 0.
        do j = 1,ny
        do i = 1,nx
            grid(i,j) = a(i,j)
        enddo
        enddo
        do j = 1,ny
        do i = 1,nx
            x = x0 + (i-xref)/rmag     ! these are the original x and y values
            y = y0 + (j-yref)/rmag     ! sampled by i and j in the new array
            if (x >=1.d0 .and. x <= nx*1.d0 .and. &
                y >=1.d0 .and. y <= ny*1.d0) then
                call intrp2(x, 0.d0, nx*1.d0, nx, y, 0.d0, &
                    ny*1.d0, ny, grid, z,zx,zy,zxx,zyy,zxy)
            else
                z = 0.
            endif

            ar(i,j) = z
        enddo
        enddo

        deallocate(grid)
        return

        end subroutine regrid


subroutine ff_ellipsoid(q,Rx,RzRatio,Nalf,ff,aff,M)
    !***************************************************************************
    !Subroutine to calculate the form factor of an ellipsoid
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Rx = Major Radius of ellipsoid in Angstroms
    !RzRatio = Rz/Rx ratio for the minor axis of the ellipsoid
    !Nalf = Number of distict azimuthal angles for angular integration from 0 to pi/2
    !ff = azimuthally averaged form factor
    !aff= azimuthally averaged form factor amplitude
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j, Nalf
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1), aff(0:M-1)
    double precision :: Rx, RzRatio, Rx2, Rz2
    double precision :: rt, ft, alf, dalf, V
    dalf=3.14159/Nalf
    Rx2=Rx*Rx
    Rz2=Rx2*RzRatio*RzRatio
    V=4*3.14159*Rx**3*RzRatio/3
    do i = 0,M-1
        ff(i)=0.0d0
        aff(i)=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
            ft=(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
            aff(i)=aff(i)+ft*dsin(alf)
            ff(i)=ff(i)+ft*ft*dsin(alf)
        end do
        aff(i)=3*V*dalf*aff(i)
        ff(i)=(3*V)**2*ff(i)*dalf
    end do

end subroutine ff_ellipsoid

subroutine ff_ellipsoid_ml(q,Rx,RzRatio,rho,Nalf,ff,aff,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of sphere with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radius and shell thicknesses of sphere in Angstroms
    !rho = Array of electron densities  of core and the shells
    !Rdist = Probablity distribution of radii
    !Nlayers = Number of shells plus the core
    !aff = amplitude of form factor
    !ff = Form factor of sphere
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j, k, Nalf, Nlayers
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1), aff(0:M-1)
    double precision :: Rx(0:Nlayers-1), RzRatio(0:Nlayers-1), rho(0:Nlayers-1)
    double precision :: rt, ft, tRx, tRz, Rx2, Rz2, alf, dalf, V, taff
    dalf=3.14159/Nalf
    do i = 0,M-1
        ff(i)=0.0d0
        aff(i)=0.0d0
        tRx=0.0d0
        tRz=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            tRx=0.0d0
            tRz=0.0d0
            taff=0.0d0
            do k = 0, Nlayers-2
                tRx=tRx+Rx(k)
                tRz=tRz+Rx(k)*RzRatio(k)
                Rx2=tRx*tRx
                Rz2=tRz*tRz
                rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
                ft=(rho(k)-rho(k+1))*(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
                taff=taff+ft
            end do
            aff(i)=aff(i)+taff*dsin(alf)
            ff(i)=ff(i)+taff*taff*dsin(alf)
        end do
        V=4*3.14159*tRz*tRx**2/3.0
        aff(i)=3*V*dalf*aff(i)
        ff(i)=(3*V)**2*ff(i)*dalf
    end do

end subroutine ff_ellipsoid_ml

subroutine ff_ellipsoid_ml_asaxs(q,Rx,RzRatio,rho,eirho,adensity,Nalf,fft,ffs,ffc,ffr,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of sphere with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radius and shell thicknesses of sphere in Angstroms
    !rho = Array of electron densities  of core and the shells
    !Rdist = Probablity distribution of radii
    !Nlayers = Number of shells plus the core
    !aff = amplitude of form factor
    !ff = Form factor of sphere
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j, k, Nalf, Nlayers
    double precision :: q(0:M-1)
    double precision :: fft(0:M-1), ffs(0:M-1), ffc(0:M-1), ffr(0:M-1)
    double precision :: Rx(0:Nlayers-1), RzRatio(0:Nlayers-1)
    double complex :: rho(0:Nlayers-1)
    double precision :: eirho(0:Nlayers-1), adensity(0:Nlayers-1)
    double precision :: rt, fs, fc, fr, tRx, tRz, Rx2, Rz2, alf, dalf, V, fac
    double complex :: ft, tft
    double precision :: tfs, tfr
    dalf=3.14159/Nalf
    do i = 0,M-1
        fft(i)=0.0d0
        ffs(i)=0.0d0
        ffc(i)=0.0d0
        ffr(i)=0.0d0
        tRx=0.0d0
        tRz=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            tRx=0.0d0
            tRz=0.0d0
            tft=0.0d0
            tfs=0.0d0
            tfr=0.0d0
            do k = 0, Nlayers-2
                tRx=tRx+Rx(k)
                tRz=tRz+Rx(k)*RzRatio(k)
                Rx2=tRx*tRx
                Rz2=tRz*tRz
                rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
                fac=(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
                ft=(rho(k)-rho(k+1))*fac
                fs=(eirho(k)-eirho(k+1))*fac
                fr=(adensity(k)-adensity(k+1))*fac
                fc=fs*fr
                tft=tft+ft
                tfs=tfs+fs
                tfr=tfr+fr
            end do
            fft(i)=fft(i)+cdabs(tft)**2*dsin(alf)
            ffs(i)=ffs(i)+tfs**2*dsin(alf)
            ffc(i)=ffc(i)+tfs*tfr*dsin(alf)
            ffr(i)=ffr(i)+tfr**2*dsin(alf)
        end do
        V=4*3.14159*tRz*tRx**2/3.0
        fft(i)=(3*V)**2*fft(i)*dalf
        ffs(i)=(3*V)**2*ffs(i)*dalf
        ffc(i)=(3*V)**2*ffc(i)*dalf
        ffr(i)=(3*V)**2*ffr(i)*dalf
    end do

end subroutine ff_ellipsoid_ml_asaxs


c=======================================================================
c
c     subroutine OMEGAB
c
c     Computes the variable omegaB for the RiskBudgetIT (cf. specification)
c     as well as the nbc values of (omegab^T Gamma_i omegab)
c
c-----------------------------------------------------------------------
      SUBROUTINE omegab ( n, cov, covb, nbc, class,
     &                    iwork, dwork,
     &                    omegabench, riskbench, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n          : portfolio size                              integer
c       cov        : covariance matrix (n*n)                      double
c       covb       : covariance assets-index (n)                  double
c       nbc        : nb. risk budgeting constraints (>=1)        integer
c       class      : block definition (n)                        integer
c
c     WORKSPACE
c       iwork      : 12*n+nbc                                    integer
c       dwork      : n*(4*n+28)                                   double
c
c     OUTPUT
c       omegabench : variable omega benchmark (n)                 double
c       riskbench  : nbc-vector of omegab^T Gamma_i omegab        double
c       info       : diagnostic argument                         integer
c
c     CALL
c        IVI, IMX, SCHURS, OMCDMCT, OVTMCV, PMV
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, nbc, class(*)
      DOUBLE PRECISION cov(*), covb(*), omegabench(*), riskbench(*)
c
c     worksoaces
      DOUBLE PRECISION dwork(*)
      INTEGER iwork(*)

c
c     local variables
      INTEGER izero, indk, indj, i, j, k, l, classSize, sumindex,
     &        pdmat, pdcovb, pdeigval, pdvpmat, pdschur, pdtemp,
     &        pdmatinv, piclas, pischur
      DOUBLE PRECISION epsil, temp, zero
c
c     external function
      EXTERNAL IVI, IMX, SCHURS, OMCDMCT, OVTMCV, PMV
c
c     initialization
      epsil = 1.E-15
      izero = 0
      zero = 0.

      pdmat = 1
c needs n*n
c so n*n
      pdcovb = pdmat +n*n
c needs n
c so n*n + n = n*(n+1)

      pdeigval = pdcovb + n
c needs n
c so n*(n+2)
      pdvpmat = pdeigval + n
c needs n*n
c      so n*(2*n+2)
      pdmatinv = pdvpmat + n*n
c needs n*n
c      so n*(3*n+2)
      pdschur = pdmatinv + n*n
c needs n*(n+26)
c so n*(4*n+28)
      pdtemp = pdmatinv + n*n
c needs n*n but is independant from schurs
c           and n*n < n*(n+26)
c       so   n*(4*n+28)

      piclas = 1
c needs nbc
c
      pischur = piclas + nbc
c needs 12*n
c      so 12*n+nbc

c     computation of the size of each class
      CALL ivi(nbc, iwork(piclas), izero)
      DO i = 1,n
        iwork(piclas+class(i)-1)=iwork(piclas+class(i)-1) + 1
      ENDDO
      sumindex = 0
      DO i = 1,nbc
        indj = 0
        classSize = iwork(piclas+i-1)
        CALL IMX(classSize, classSize, dwork(pdmat), zero)
c       initialization of the matrix(classSize,classSize)
c       corresponding to the i-th class
c
        DO j = 1,n
            IF (class(j) .EQ. i) THEN
                indj = indj+1
                indk = 0
                DO k = 1,n
                    IF (class(k) .EQ. i) THEN
                        indk = indk+1
                        dwork(pdmat+indk-1+classSize*(indj-1))
     &                   = cov(k+(j-1)*n)
                    ENDIF
                ENDDO
                dwork(pdcovb+indj-1) = covb(j)
            ENDIF
        ENDDO
c
c       Matrix Schur decomposition of a symmetric matrix
        CALL SCHURS(classSize, dwork(pdmat), iwork(pischur),
     &              dwork(pdschur), dwork(pdeigval), dwork(pdvpmat),
     &              info )
        IF (info .LT. 0) RETURN
c
c
        DO l = 1,classSize
            temp = dwork(pdeigval+l-1)
            IF ((temp .GT. epsil) .OR. (temp .LT. -epsil)) THEN
                dwork(pdeigval+l-1) = 1./temp
            ENDIF
        ENDDO
c
c     computation of P'*inv(Diag(sector(i))*P
        CALL OMCDMCT(classSize, dwork(pdvpmat), dwork(pdeigval),
     &               dwork(pdtemp), dwork(pdmatinv))
        CALL PMV(classSize, classSize, dwork(pdmatinv),
     &           dwork(pdcovb), omegabench(sumindex+1))
        CALL OVTMCV(classSize, dwork(pdmat), omegabench(sumindex+1),
     &              riskbench(i))
        sumindex =  sumindex + classSize
      ENDDO
      RETURN
      END


      SUBROUTINE cdftnc(which,p,q,t,df,pnonc,status,bound)
C***********************************************************************
C
C      SUBROUTINE CDFTNC( WHICH, P, Q, T, DF, PNONC, STATUS, BOUND )
C               Cumulative Distribution Function
C                  Non-Central T distribution
C
C                               Function
C
C     Calculates any one parameter of the noncentral t distribution give
C     values for the others.
C
C                               Arguments
C
C     WHICH --> Integer indicating which  argument
C               values is to be calculated from the others.
C               Legal range: 1..3
C               iwhich = 1 : Calculate P and Q from T,DF,PNONC
C               iwhich = 2 : Calculate T from P,Q,DF,PNONC
C               iwhich = 3 : Calculate DF from P,Q,T
C               iwhich = 4 : Calculate PNONC from P,Q,DF,T
C                    INTEGER WHICH
C
C        P <--> The integral from -infinity to t of the noncentral t-den
C              Input range: (0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C        T <--> Upper limit of integration of the noncentral t-density.
C               Input range: ( -infinity, +infinity).
C               Search range: [ -1E100, 1E100 ]
C                    DOUBLE PRECISION T
C
C        DF <--> Degrees of freedom of the noncentral t-distribution.
C                Input range: (0 , +infinity).
C                Search range: [1e-100, 1E10]
C                    DOUBLE PRECISION DF
C
C     PNONC <--> Noncentrality parameter of the noncentral t-distributio
C                Input range: [-infinity , +infinity).
C                Search range: [-1e4, 1E4]
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C                                Method
C
C     Upper tail    of  the  cumulative  noncentral t is calculated usin
C     formulae  from page 532  of Johnson, Kotz,  Balakrishnan, Coninuou
C     Univariate Distributions, Vol 2, 2nd Edition.  Wiley (1995)
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C***********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tent4
      PARAMETER (tent4=1.0D4)
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,one,inf
      PARAMETER (zero=1.0D-100,one=1.0D0-1.0D-16,inf=1.0D100)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,df,p,pnonc,q,t
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx
      LOGICAL qhi,qleft
C     ..
C     .. External Subroutines ..
      EXTERNAL cumtnc,dinvr,dstinv
C     ..
      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 5.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.one))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = one
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.3) GO TO 90
      IF (.NOT. (df.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      status = -5
      RETURN

   80 CONTINUE
   90 IF (which.EQ.4) GO TO 100
  100 IF ((1).EQ. (which)) THEN
          CALL cumtnc(t,df,pnonc,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
          t = 5.0D0
          CALL dstinv(-inf,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,t,fx,qleft,qhi)
  110     IF (.NOT. (status.EQ.1)) GO TO 120
          CALL cumtnc(t,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,t,fx,qleft,qhi)
          GO TO 110

  120     IF (.NOT. (status.EQ.-1)) GO TO 150
          IF (.NOT. (qleft)) GO TO 130
          status = 1
          bound = -inf
          GO TO 140

  130     status = 2
          bound = inf
  140     CONTINUE
  150     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          df = 5.0D0
          CALL dstinv(zero,tent4,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,df,fx,qleft,qhi)
  160     IF (.NOT. (status.EQ.1)) GO TO 170
          CALL cumtnc(t,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,df,fx,qleft,qhi)
          GO TO 160

  170     IF (.NOT. (status.EQ.-1)) GO TO 200
          IF (.NOT. (qleft)) GO TO 180
          status = 1
          bound = zero
          GO TO 190

  180     status = 2
          bound = inf
  190     CONTINUE
  200     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
          pnonc = 5.0D0
          CALL dstinv(-tent4,tent4,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,pnonc,fx,qleft,qhi)
  210     IF (.NOT. (status.EQ.1)) GO TO 220
          CALL cumtnc(t,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,pnonc,fx,qleft,qhi)
          GO TO 210

  220     IF (.NOT. (status.EQ.-1)) GO TO 250
          IF (.NOT. (qleft)) GO TO 230
          status = 1
          bound = 0.0D0
          GO TO 240

  230     status = 2
          bound = tent4
  240     CONTINUE
  250 END IF

      RETURN

      END


C      +----------------------+
C      !     LITT splines     !
C      !    point anguleux    !
C      +----------------------+
C                      06.03.95

       integer n,m,I
       parameter (n=9)
       parameter (m=100)
       double precision x(m),y(m),Y1(m),XN(n),YN(n),DN(n),W(3*n)
       double precision vals(4), dy(m), ERREUR, h

C      ------------------------
C               Data
C      ------------------------

       DATA YN/1.0, 0.8, 0.3, 0.1, 0.0, 0.1, 0.3, 0.8, 1.0/

       DATA XN/0.0, 0.2, 0.7, 0.9, 1.0, 1.1, 1.3, 1.8, 2.0/

C      ------------------------
C               SPLINE
C      ------------------------

       call TB04AD(n,XN,YN,DN,W)

C      ------------------------
C        Interpolation SPLINE
C      ------------------------

       x(1)=0.0
       y(1)=YN(1)
       y1(1)=YN(1)

       do 10 I=2,m
          x(I)  = 2.*I/m
          CALL  TG02AD(1,n,XN,YN,DN,x(I),vals)
          y(I)  = vals(1)
          dy(I) = vals(2)
          if(I.lt.m/2) then
             Y1(I)=-x(I)+1
          else
             Y1(I)=x(I)-1
          endif
10     continue

       h=2./m
       ERREUR=0
       do 5 I=1,m-1
          ERREUR=ERREUR+(abs(y(I)-Y1(I))+abs(y(I+1)-Y1(I+1)))*h/2
5      continue

       call tomat(n,m,XN,YN,x,y,Y1,dy,ERREUR)

       end

C      ------------------------
C             -> Matlab
C      ------------------------

       subroutine tomat(n,m,XX,YY,X,Y,Y1,DY,ERREUR)

       integer m,n,I
       double precision X(m),Y(m),Y1(m),XX(n),YY(n),DY(m),ERREUR

       open(UNIT = 2, FILE = 'ptang9e.m')

          do 100 I=1,m
             write(2,*)'x(',I,')=',X(I),';'
             write(2,*)'y(',I,')=',Y(I),';'
             write(2,*)'y1(',I,')=',Y1(I),';'
             write(2,*)'dy(',I,')=',DY(I),';'
100       continue

          do 200 I=1,n
             write(2,*)'xn(',I,')=',XX(I),';'
             write(2,*)'yn(',I,')=',YY(I),';'
200       continue
          write(2,*)'erreur=',ERREUR
          write(2,*)'figure(1);'
          write(2,*)'plot(xn,yn,''w+'',x,y,''w-'',x,y1,''w-'')'
          write(2,*)'axis(''equal'');grid;figure(2)'
          write(2,*)'plot(x,abs(y1-y),''w-'')'
          write(2,*)'grid;figure(3);'
          write(2,*)'plot(x,dy,''w-'');axis(''equal'');grid'
          write(2,*)'err(',n,')=max(abs(y1-y));'

       close (UNIT = 2)

       return

       end


! { dg-do run }
!
! PR fortran/36158
! PR fortran/33197
!
! Run-time tests for transformations BESSEL_JN
!
implicit none
real,parameter :: values(*) = [0.0, 0.5, 1.0, 0.9, 1.8,2.0,3.0,4.0,4.25,8.0,34.53, 475.78]
real,parameter :: myeps(size(values)) = epsilon(0.0) &
                  * [2, 7, 5, 6, 9, 12, 12, 7, 7, 8, 75, 15 ]
! The following is sufficient for me - the values above are a bit
! more tolerant
!                  * [0, 5, 3, 4, 6, 7, 7, 5, 5, 6, 66, 4 ]
integer,parameter :: mymax(size(values)) =  &
                 [100, 17, 23, 21, 27, 28, 32, 35, 36, 41, 47, 37 ]
integer, parameter :: Nmax = 100
real :: rec(0:Nmax), lib(0:Nmax)
integer :: i

do i = 1, ubound(values,dim=1)
  call compare(mymax(i), values(i), myeps(i))
end do

contains

subroutine compare(mymax, X, myeps)

integer :: i, nit, mymax
real X, myeps, myeps2

rec(0:mymax) = BESSEL_JN(0, mymax, X)
lib(0:mymax) = [ (BESSEL_JN(i, X), i=0,mymax) ]

!print *, 'YN for X = ', X, ' -- Epsilon = ',epsilon(x)
do i = 0, mymax
!  print '(i2,2e17.9,e12.2,f18.10,2l3)', i, rec(i), lib(i), &
!        rec(i)-lib(i),           ((rec(i)-lib(i))/rec(i))/epsilon(x), &
!        rec(i) == lib(i) .or. abs((rec(i)-lib(i))/rec(i)) < myeps
if (.not. (rec(i) == lib(i) .or. abs((rec(i)-lib(i))/rec(i)) < myeps)) &
  call abort()
end do

end
end


! error_calc.f90
! Estimated error in correlated data
PROGRAM error_calc

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! In this program we analyse synthetic data, a time series whose properties are exactly known.
  ! Define underlying process by generalized Langevin equation (GLE)
  ! with memory function expressed as a decaying exponential
  ! See G Ciccotti and JP Ryckaert Mol Phys 40 141 (1980)
  ! and AD Baczewski and SD Bond J Chem Phys 139 044107 (2013)

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE               maths_module,    ONLY : random_normal, init_random_seed

  IMPLICIT NONE

  REAL    :: m      ! GLE memory function coefficients
  REAL    :: kappa  ! GLE memory function decay rates
  REAL    :: s      ! GLE auxiliary variable
  REAL    :: delta  ! Time step
  REAL    :: at     ! Dynamical variable at time t
  INTEGER :: nstep  ! Number of timesteps in run
  INTEGER :: nequil ! Number of equilibration timesteps
  INTEGER :: t      ! Time (equivalent to step number in file)

  REAL, DIMENSION(:), ALLOCATABLE :: a ! Stored data values (nstep)

  INTEGER :: ioerr, tblock, i_repeat, nblock, blk, stp1, stp2, trun, n_repeat
  REAL    :: average, variance, stddev, err, si, tcor, x, e, b, d
  REAL    :: a_blk, a_run, a_avg, a_var, a_var_1, a_err

  ! Taylor series coefficients
  REAL, PARAMETER :: b1 = 2.0, b2 = -2.0,     b3 = 4.0/3.0, b4 = -2.0/3.0  ! b = 1.0 - EXP(-2.0*x)
  REAL, PARAMETER :: d1 = 1.0, d2 = -1.0/2.0, d3 = 1.0/6.0, d4 = -1.0/24.0 ! d = 1.0 - EXP(-x)

  NAMELIST /nml/ nstep, nequil, n_repeat, delta, variance, average

  ! Example default values
  nstep    = 2**16 ! Number of steps, about 60,000 for example
  nequil   = 10000 ! Number of equilibration timesteps
  n_repeat = 50    ! Number of simulation repeats for brute force empirical calculation
  delta    = 0.01  ! Timestep for simulation
  variance = 1.0   ! Desired variance of data (equivalent to temperature)
  average  = 1.0   ! Desired average value of data

  ! Namelist from standard input
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in error_calc'
  END IF

  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps in run',        nstep
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Equilibration steps',           nequil
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of brute-force repeats', n_repeat
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Time step delta',               delta
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Desired average value',         average
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Desired variance',              variance

  ALLOCATE ( a(nstep) )

  ! The memory function model is defined here
  ! Values used by Baczewski and Bond in their example are
  ! (m,kappa)
  ! (1.0,1.0)  (underdamped)
  ! (0.5,2.0)  (critically damped)
  ! (0.25,4.0) (overdamped)
  m     = 0.25
  kappa = 4.0
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'm ',     m
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'kappa ', kappa

  ! Coefficients used in algorithm
  x = delta*kappa
  e = EXP(-x) ! theta in B&B paper
  IF ( x > 0.0001 ) THEN
     b = 1.0 - EXP(-2.0*x)
     d = 1.0 - EXP(-x)
  ELSE ! Taylor expansions for low x
     b = x * ( b1 + x * ( b2 + x * ( b3 + x * b4 ) ) )
     d = x * ( d1 + x * ( d2 + x * ( d3 + x * d4 ) ) )
  END IF
  b      = SQRT ( b )
  b      = b * sqrt ( kappa/2.0 ) ! alpha in B&B paper
  stddev = SQRT(2.0*variance)     ! NB stddev of random forces, not data

  ! For this process, the results of interest can be calculated exactly
  ! The time correlation function is known, and hence the statistical inefficiency (SI)
  ! From this, the error in the mean for a run of any length can be calculated

  tcor = 1.0 / m      ! Correlation time is determined by memory function
  tcor = tcor / delta ! Express this in timesteps
  si   = 2*tcor       ! Statistical inefficiency (SI)
  err  = SQRT(si*variance/REAL(nstep))
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Exact correlation time in steps = ', tcor
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Run length / correlation time = ',   REAL(nstep) / tcor
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Exact value of SI = ',               si
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Exact error estimate = ',            err

  ! Data generation

  CALL init_random_seed

  ! For comparison, we do n_repeat independent runs and estimate the error in run averages directly from these
  ! This is to give an empirical idea of the distribution from which the run average is sampled
  ! Of course, we expect the results to be similar to the exact values just calculated

  a_avg = 0.0 ! Zero average accumulator
  a_var = 0.0 ! Zero mean-squared accumulator

  DO i_repeat = 1, n_repeat ! Loop over repeats of simulation

     ! Initial values, hopefully not critical
     at = 0.0
     s  = 0.0

     DO t = -nequil, nstep ! Loop over steps including an equilibration period

        ! Velocity Verlet type algorithm for at and auxiliary variable s
        at = at + 0.5 * delta * s
        s  = e * s - d * m * at + b * SQRT(m) * random_normal ( 0.0, stddev )
        at = at + 0.5 * delta * s

        IF ( t > 0 ) a(t) = average + at ! Store values (after equilibration, adding average)

     END DO ! End loop over steps including an equilibration period

     a_run = SUM(a) / REAL(nstep) ! The run average
     a_avg = a_avg + a_run        ! Average over runs
     a_var = a_var + a_run**2     ! Mean squared value over runs

  END DO ! End loop over repeats of simulation

  a_avg = a_avg / REAL(n_repeat)                  ! Mean value
  a_var = a_var / REAL(n_repeat)                  ! Mean-squared value
  a_var = a_var - a_avg**2                        ! Mean-squared deviation
  a_var = a_var * REAL(n_repeat)/REAL(n_repeat-1) ! Bias correction
  err   = SQRT(a_var)                             ! Empirical standard deviation in run average
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Empirical error estimate = ', err
  WRITE ( unit=output_unit, fmt='(a)') 'This should be in reasonable agreement with exact error estimate'

  ! Now analyse the last run, as if it were the only one that had been carried out
  ! This is what usually happens; we rarely have the luxury of many independent runs

  ! Simple calculation of average and variance

  a_avg   = SUM ( a ) / REAL(nstep)      ! Sample average
  a       = a - a_avg                    ! Centre the data
  a_var_1 = SUM ( a**2 ) / REAL(nstep-1) ! Bias-corrected sample variance
  a_err   = SQRT(a_var_1 / REAL(nstep))  ! Error estimate neglecting any correlations

  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Sample average value = ',                   a_avg
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Deviation from exact average = ',           a_avg - average
  WRITE ( unit=output_unit, fmt='(a)') 'Deviation should (typically) lie within +/- exact error estimate'
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Sample variance = ',                        a_var_1
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Error estimate neglecting correlations = ', a_err
  WRITE ( unit=output_unit, fmt='(a)') 'This should be very over-optimistic!'

  ! We must take account of the correlations between successive values in time
  ! The two common methods which follow are actually very similar
  ! They differ in the choice of block lengths

  ! Traditional block analysis
  ! The rationale here is that 20 (say) independent block averages should be enough to get a reasonable
  ! estimate of the desired quantities, and that there is not a lot to gain by looking at more (shorter) blocks.
  ! Some workers just assume that the run may be divided into 10 or 20 blocks, which they hope will be independent.
  ! This is exactly what we do in our example programs, just for simplicity.
  ! We cannot recommend this in general, unless there is good reason to support the assumption of independence.
  ! If the 20 blocks are not independent, then attention should be focused on fewer (longer) blocks,
  ! rather than more (shorter) ones, and a plot of squared error estimate, or statistical inefficiency,
  ! vs 1/tblock carried out to extrapolate to tblock=nstep. The loop below provides the data for that plot.

  WRITE ( unit=output_unit, fmt='(4a15)' ) 'tblock', 'nblock', 'error estimate', 'estimate of SI'

  DO nblock = 20, 4, -1 ! Loop over number, and hence length, of blocks

     tblock = nstep / nblock              ! Block length in steps (rounded down)
     trun   = nblock*tblock               ! Run length in steps, accounting for rounding
     a_run  = SUM(a(1:trun)) / REAL(trun) ! Average of data
     a_var  = 0.0                         ! Zero mean-square block average accumulator

     DO blk = 1, nblock ! Loop over blocks
        stp1  = (blk-1)*tblock+1                            ! Start of block
        stp2  = blk*tblock                                  ! End of block
        a_blk = SUM ( a(stp1:stp2) - a_run ) / REAL(tblock) ! Block average of deviation
        a_var = a_var + a_blk**2                            ! Mean-square block average
     END DO ! End loop over blocks

     a_var = a_var / REAL(nblock-1)    ! Bias-corrected variance of block averages
     a_err = SQRT(a_var/REAL(nblock))  ! Estimate of error from block-average variance
     si    = tblock * a_var / a_var_1  ! Statistical inefficiency

     WRITE ( unit=output_unit, fmt='(2i15,3f15.6)' ) tblock, nblock, a_err, si

  END DO ! End loop over number, and hence length, of blocks

  WRITE ( unit=output_unit, fmt='(a)' ) 'Plateau at large tblock (small nblock)'
  WRITE ( unit=output_unit, fmt='(a)' ) 'should agree quite well with exact error estimate'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Can plot SI or error**2 against 1/tblock'

  ! Method of Flyvbjerg and Petersen, J Chem Phys, 91, 461 (1989)
  ! Note that, in this implementation, we over-write the data array a
  ! Advantages of this method are the very neat method for reducing the data
  ! and the formal scaling analysis that accompanies the blocking transformation
  ! The basic calculation is the same as for the traditional block-averaging,
  ! but the block length, and hence tblock, change by a factor 2 each time.
  ! Advocates of Flyvbjerg and Petersen might argue that the additional data points
  ! at low nblock (high tblock) which are calculated in the traditional method
  ! do not actually provide much new (independent) information.
  ! One may attempt an extrapolation of si or a_err**2 as a function of 1/tblock
  ! but F&P suggest estimating a plateau in a plot vs number of blocking transformations
  ! which is essentially log2(tblock)

  nblock = nstep
  tblock = 1
  WRITE ( unit=output_unit, fmt='(4a15)' ) 'tblock', 'nblock', 'error estimate', 'estimate of SI'

  DO ! Loop over number, and hence length, of blocks

     nblock = nblock / 2 ! Halve the number of blocks, rounding down if nblock is odd
     tblock = tblock*2   ! Double the block length
     IF ( nblock < 3 ) EXIT

     a(1:nblock) = ( a(1:2*nblock-1:2) + a(2:2*nblock:2) ) / 2.0 ! Blocking transformation, halving the data set
     a_avg       = SUM ( a(1:nblock) ) / REAL(nblock)            ! Re-compute sample average
     a(1:nblock) = a(1:nblock) - a_avg                           ! Re-centre in case of dropped points (odd nblock)
     a_var       = SUM ( a(1:nblock)**2 ) / REAL(nblock-1)       ! Bias-corrected variance of block averages
     a_err       = SQRT ( a_var / REAL(nblock) )                 ! Estimate of error from block average variance
     si          = tblock * a_var / a_var_1                      ! Statistical inefficiency

     WRITE ( unit=output_unit, fmt='(2i15,3f15.6)' ) tblock, nblock, a_err, si

  END DO ! End loop over number, and hence length, of blocks

  WRITE ( unit=output_unit, fmt='(a)' ) 'Plateau at large tblock (small nblock)'
  WRITE ( unit=output_unit, fmt='(a)' ) 'should agree quite well with exact error estimate'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Can plot SI or error**2 against 1/tblock or log2(tblock)'

END PROGRAM error_calc


program test
  integer :: a
  integer :: b

  a = 6 + 3 + 4 + 4 +  &
    3 + 6
  b = 7 + 6 + 6 + 5   &
    + 5 + 6
  print *, a + b
end program test


MODULE FUN_xyzNORM
!!#### PURPOSE
!! Compute the normalization factor squared for a vector in R^3.

!!#### METHOD
!! Square root of the sum of the squares of x, y, and z components.

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

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzNORM_V
 MODULE PROCEDURE xyzNORM_V_Rsp
 MODULE PROCEDURE xyzNORM_V_Rdp
ENDINTERFACE
PUBLIC :: xyzNORM_V

CONTAINS

PURE FUNCTION xyzNORM_V_Rsp( V ) RESULT(NORM)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyzNORM_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyzNORM_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzNORM_V_Rdp( V ) RESULT(NORM)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyzNORM_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyzNORM_V.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      implicit none
      integer M, numprimes
      integer MAXPRIMES

      parameter (MAXPRIMES=10000)
      integer primes(MAXPRIMES)
      integer makeprimes

      write(*,*) 'Enter ceiling on primes'
      read(*,*) M

C Get list of primes up to M
      numprimes = makeprimes(primes,M,MAXPRIMES)

C Print the primes
      call printarray('Primes',primes,numprimes)

      end

      subroutine printarray(heading,a,n)
      implicit none
      character *(*) heading
      integer i, n, a(1)
      write(*,*) heading
      do i=1,n
         write(*,'(1x,i4,1x,i5)') i, a(i)
      end do
      end

      integer function makeprimes(p,n,max)
C computes array of primes less than or equal to n.
C note: max = limit of number of primes, must be at least 1.
      implicit none
      integer n, max, p(max)
      integer i, numprimes
      logical divisible
C put the even prime into the list
      numprimes = 1
      p(numprimes) = 2
C loop thru odd integers, testing if divisible
      do i=3,n,2
         if( .not. divisible(i,p,numprimes) ) then
            numprimes = numprimes+1
            if( numprimes .gt. max ) then
               write(*,*) 'Ran out of space at p=',i
               stop
            else
               p(numprimes) = i
            end if
         end if
      end do
C return number of primes found
      makeprimes = numprimes
      return
      end
      logical function divisible(n,p,nump)
      implicit none
      integer n, nump, p(1)
      integer i
      do i=1,nump
         if( mod(n,p(i)) .eq. 0 ) then
            divisible = .true.
            return
         end if
      end do
      divisible = .false.
      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

! 2d int array, minloc with dim, mask and back

program main
  integer :: res(4)
  integer, dimension(4,4) :: array
  integer :: expect(4)
  array = reshape((/4,2,9,-7,9,1,5,5,8,-1,-1,5,-7,5,9,-7/),shape(array))
  res = minloc(array, dim = 1, mask = array .lt. 7, back=.true.)
  expect = (/4,2,3,4/)
  call check(res, expect, 4)
  !print *, "base=true:", res
  res = minloc(array, dim = 1, mask = array .lt. 7, back=.false.)
  expect = (/4,2,2,1/)
  call check(res, expect, 4)
  !print *, "back=false:", res
end


        subroutine mmult1(x, y, z, m, n, p)

        integer i, j, k
        integer m, n, p
        integer x(m, p), y(p, n), z(m, n)

        do 10 i=1, m
           do 20 j=1, n
              do 30 k=1, p
                 z(i,j) = z(i,j) + x(i,k) * y(k, j)
   30         continue
   20      continue
   10   continue

        end

        subroutine mmult2(x, y, z, m, n, p)

        integer i, j, k, zz
        integer m, n, p
        integer x(m, p), y(p, n), z(m, n)

        do 10 i=1, m
           do 20 j=1, n
              zz = 0
              do 30 k=1, p
                 zz = zz + x(i,k) * y(k, j)
   30         continue
              z(i,j) = zz
   20      continue
   10   continue

        end


! { dg-do run }
! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
! Test of sign=, decimal=, and blank= .
program iotests
  implicit none
  character(len=45) :: a
  character(len=4) :: mode = "what"
  real, parameter :: pi = 3.14159265358979323846
  real(kind=8), dimension(3) :: b
  !
  write(a,'(f10.3,s,f10.3,sp,f10.3,ss,f10.3)',SIGN='PLUS') pi, pi, pi, pi
  if (a /= "    +3.142     3.142    +3.142     3.142") STOP 1
  !
  open(8,sign="plus")
  write(8,'(f10.3,dc,f10.3,dp,f10.3)',DECIMAL='COMMA',&
        & sign="suppress") pi, pi, pi
  rewind(8)
  read(8,'(a)') a
  if (a /= "     3,142     3,142     3.142") STOP 2
  close(8,status="delete")
  !
  !              "123456789 123456789  12345678901
  write(a,'(a)') "53 256.84, 2 2 2.  ; 33.3 3   1  "
  read(a, '(f9.2,1x,f8.2,2x,f11.7)', blank="zero") b(1),b(2),b(3)
  if (any(abs(b - [530256.84, 20202.00, 33.3030001]) > .03)) STOP 3
end program iotests


! { dg-do run }
! PR 31196 - reshape of transposed derived types generated
!            wront results.
program main
  implicit none
  TYPE datatype
     INTEGER :: I
  END TYPE datatype
  character (len=20) line1, line2
  TYPE(datatype), dimension(2,2) :: data, result
  data(1,1)%i = 1
  data(2,1)%i = 2
  data(1,2)%i = 3
  data(2,2)%i = 4
  write (unit=line1, fmt="(4I4)") reshape(transpose(data),shape(data))
  write (unit=line2, fmt="(4I4)") (/ 1, 3, 2, 4 /)
  if (line1 /= line2) call abort
END program main


module rotflip
!! provides rot90, flipud, fliplr for Fortran like Matlab and NumPy

implicit none (type, external)

contains

pure integer function rot90(A, k)
! https://github.com/numpy/numpy/blob/v1.14.2/numpy/lib/function_base.py#L54-L138

integer, intent(in) :: A(:,:)
integer, intent(in), optional :: k
dimension :: rot90(size(A,1), size(A,2))
integer :: r

r = 1
if (present(k)) r = k

select case (modulo(r,4))
case (0)
  rot90 = A  ! unmodified
case (1)
  rot90 = transpose(flip(A,1))
case (2)
  rot90 = flip(A,0)
case (3)
  rot90 = flip(transpose(A), 1)
end select

end function rot90

pure integer function flip(A, d)

integer, intent(in) :: A(:,:)
integer, intent(in) :: d
dimension :: flip(size(A,1), size(A,2))

integer :: M, N

M = size(A,1)
N = size(A,2)

select case (d)
case (0)  ! flip both dimensions
  flip = A(M:1:-1, N:1:-1)
case (1)
  flip = A(M:1:-1, :)
case (2)
  flip = A(:, N:1:-1)
case default
  error stop 'bad flip dimension, 2-D only  (1 or 2), or 0 for both dimensions'
end select

end function flip

pure integer function flipud(A)

integer, intent(in) :: A(:,:)
dimension :: flipud(size(A,1), size(A,2))

flipud = flip(A,1)

end function flipud

pure integer function fliplr(A)

integer, intent(in) :: A(:,:)
dimension :: fliplr(size(A,1), size(A,2))

fliplr = flip(A,2)

end function fliplr

end module rotflip


MODULE FilterSubs

   ! This module contains routines to filter data.

CONTAINS

!=======================================================================
   SUBROUTINE Filter ( Fi )

      ! This routine implements a general bandpass digital filter.

      ! This routine was originally coded by Norm Weaver of InterWeaver Consulting
      ! for the NWTC.  It has since been converted to free-form Fortran and
      ! ported to Crunch by Marshall Buhl of the NWTC.

      ! The formulation follows the bilinear infinite-impulse recursive (IIR)
      ! filter described in Numerical Recipes, 2nd ed. on pages 553-555.

      ! This recursive filter is stable with a somewhat rounded and asymmetric
      ! filter response below and above the user selected cutoff frequencies.
      ! The data is filtered twice (forward and backward) to remove phase shift.

      ! The filter formulation assumes evenly spaced data, with time in the
      ! first column.

      ! The response function of the filter is defined by the even function:

      !    | H(f) |^2 = (w^2 / (w^2 + a^2)) * (b^2 / (w^2 + b^2))

      !     where the parameter "w" is defined by the change of variable:

      !        w = tan( Pi * freq. * timestep )

      !     and "a" and "b" are the low and high cutoff frequencies.

      !        If freq. "a" is zero this is a low-pass filter.
      !        If freq. "b" is equal to the Nyquist freq., this is a high-pass
      !        filter.

      ! The solution for stable poles of this function define the following
      ! discrete filter coefficients and corresponding recursion relation:

      !    c1 = -b/((1+a)*(1+b))
      !    c2 = -c1
      !    d1 = ((1+a)*(1-b)+(1-a)*(1+b))/((1+a)*(1+b))
      !    d2 = =-((1-a)*(1-b))/((1+a)*(1+b))

      !    Y(n) = c1*X(n) + c2*X(n-2) + d1*Y(n-1) + d2*Y(n-2)

   USE                                DataMod
   USE                                ProgGen

      ! Argument declarations.

   INTEGER, INTENT(IN)             :: Fi

      ! Local declarations.

   REAL(ReKi)                      :: A
   REAL(ReKi)                      :: B
   REAL(ReKi)                      :: C          (2)
   REAL(ReKi)                      :: D          (2)
   REAL(ReKi)                      :: Nyquist
   REAL(ReKi), ALLOCATABLE         :: FiltTemp   (:,:)

   INTEGER                         :: FC
   INTEGER                         :: IC
   INTEGER                         :: IR
   INTEGER                         :: Sttus

      ! Tell user we a filtering the data.

   CALL WrScr ( '  Filtering selected columns.' )

      ! Let's set other frequencies for low-pass and high-pass filters.

   TimeStep = ( ConvData(TimeCol,NumRecs,Fi) - ConvData(TimeCol,1,Fi) )/( NumRecs - 1 )
   Nyquist  = 1.0/( 2.0*TimeStep )

      ! Check to make sure the cut-off frequencies were valid.

   SELECT CASE ( FiltType )

      CASE ( 1 )

         LoCut = 0.0
         IF ( HiCut > Nyquist )  THEN
            CALL ProgAbort ( ' The high cut-off frequency must be less than the Nyquist frequency, ' &
                       //TRIM( Flt2Lstr( Nyquist ) )//' Hz.')
         ENDIF

      CASE ( 2 )

         HiCut = Nyquist
         IF ( LoCut > Nyquist )  THEN
            CALL ProgAbort ( ' The low cut-off frequency must be less than the Nyquist frequency, ' &
                       //TRIM( Flt2Lstr( Nyquist ) )//' Hz.')
         ENDIF

      CASE ( 3 )

         IF ( HiCut > Nyquist )  THEN
            CALL ProgAbort ( ' The high cut-off frequency must be less than the Nyquist frequency, ' &
                       //TRIM( Flt2Lstr( Nyquist ) )//' Hz.')
         ENDIF

   ENDSELECT

      ! Allocate temporary array space

   ALLOCATE ( FiltTemp(TotCols,NumRecs) , STAT=Sttus )

   IF ( Sttus /= 0 )  THEN
      CALL ProgAbort ( ' Error allocating memory for the FiltTemp array.' )
   ENDIF

      ! Compute the filter coefficients

   A = TAN( Pi*LoCut*TimeStep )
   B = TAN( Pi*HiCut*TimeStep )

   C(1) = -B/( ( 1 + A )*( 1 + B ) )
   C(2) = -C(1)
   D(1) =  ( ( 1 + A )*( 1 - B ) + ( 1 - A )*( 1 + B ) )/( ( 1 + A )*( 1 + B ) )
   D(2) = -( ( 1 - A )*( 1 - B ) )/( ( 1 + A )*( 1 + B ) )

      ! Filter selected columns.

   DO IC=1,NumFilt

      FC = FiltCols(IC)

         ! Apply forward filter pass.
         !    Recursion Relation:
         !       Y(n) = c(1)*X(n) + c(2)*X(n-2) + d(1)*Y(n-1) + d(2)*Y(n-2)
         !    Compute the filtered value.  Store it in the temporary array.

      FiltTemp(FC,1) = C(1)*ConvData(FC,1,Fi)
      FiltTemp(FC,2) = C(1)*ConvData(FC,2,Fi) + D(1)*FiltTemp(FC,1)

      DO IR=3,NumRecs
         FiltTemp(FC,IR) = C(1)*ConvData(FC,IR,Fi) + C(2)*ConvData(FC,IR-2,Fi) &
                         + D(1)*FiltTemp(FC,IR-1 ) + D(2)*FiltTemp(FC,IR-2   )
      ENDDO

         ! Compute the filtered value.  Store it in the original array.HC,IR,Fil
         ! Apply reverse filter pass.

      ConvData(FC,NumRecs  ,Fi) = C(1)*FiltTemp(FC,NumRecs)
      ConvData(FC,NumRecs-1,Fi) = C(1)*FiltTemp(FC,NumRecs-1) + D(1)*ConvData(FC,NumRecs,Fi)

      DO IR=NumRecs-2,1,-1
         ConvData(FC,IR,Fi) = C(1)*FiltTemp(FC,IR     ) + C(2)*FiltTemp(FC,IR+2   ) &
                            + D(1)*ConvData(FC,IR+1,Fi) + D(2)*ConvData(FC,IR+2,Fi)
      ENDDO

   ENDDO ! IC

      ! Release FiltTemp storage.

   DEALLOCATE( FiltTemp )

   RETURN
   END SUBROUTINE Filter ! ( Fi )
!=======================================================================

END MODULE FilterSubs


program descriptive_statistics
    use, intrinsic :: iso_fortran_env, only : error_unit, input_unit, output_unit
    use :: stats_mod
    implicit none
    type(descriptive_stats_t) :: stats
    integer :: istat
    character(len=2048) :: msg
    real :: data_value

    do
        read (unit=input_unit, fmt=*, iostat=istat, iomsg=msg) data_value
        if (istat == -1) exit
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'warning: ', trim(msg)
            cycle
        end if
        call stats%add_value(data_value)
    end do
    print '(A, I0)', 'n      = ', stats%get_nr_values()
    print '(A, F10.3)', 'mean   = ', stats%get_mean()
    print '(A, F10.3)', 'stddev = ', stats%get_stddev()
    write (unit=output_unit, fmt='(dt)') stats
    print '(dt(7, 2, 7, 2))', stats

end program descriptive_statistics


!-----------------------------------------------------------------------
! Calculate summation of energy in entire flow field
!-----------------------------------------------------------------------
subroutine sub_energy(sum)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,dx,ustg,vstg
  implicit none
!
  integer :: ic,jc
  real(8) :: vol
  real(8) :: sum
!-----------------------------------------------------------------------
!
  sum = 0.d0
  vol = dx**2
!
  do jc = 1,jmax
  do ic = 1,imax
    sum = sum+vol*0.5d0*(ustg(ic,jc)**2 &
                        +vstg(ic,jc)**2)
  enddo
  enddo
!
  return
end subroutine sub_energy
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
! Define time step size based on CFL number
!-----------------------------------------------------------------------
subroutine sub_timestep(dt)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,ustg,vstg,dx,cfl
  implicit none
!
  integer :: ic,jc
  real(8) :: dt
!-----------------------------------------------------------------------
!
  dt  = 1.d0
!
  do jc = 1,jmax
  do ic = 1,imax
    dt = min(dt,cfl*dx/(abs(ustg(ic,jc)) &
                       +abs(vstg(ic,jc))))
  enddo
  enddo
!
  return
end subroutine sub_timestep
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
! Calculate maximum value of local CFL number
!-----------------------------------------------------------------------
subroutine sub_cfl(cfl)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,ustg,vstg,dx,dt
  implicit none
!
  integer :: ic,jc
  real(8) :: cfl
!-----------------------------------------------------------------------
!
  cfl  = 0.d0
!
  do jc = 1,jmax
  do ic = 1,imax
    cfl = dmax1(cfl,(dabs(ustg(ic,jc)) &
                    +dabs(vstg(ic,jc)))*dt/dx)
  enddo
  enddo
!
  return
end subroutine sub_cfl
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
! Probing u-velocity
!-----------------------------------------------------------------------
subroutine sub_probe(istep)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,xcen,ycen,ustg,vstg,nstep,iprb,jprb,prob
  implicit none
!
  real(8),parameter :: u_inf = 1.d0

  integer :: ic,jc,istep,ierr
!-----------------------------------------------------------------------
!
!
  if(istep==1) then
!
   allocate(prob(3,nstep),stat=ierr)
   prob(:,:) = 0.d0
!
   do ic=1,imax-1
      if(xcen(ic)<3.d0 .and. 3.d0<xcen(ic+1)) then
        iprb(1) = ic
        iprb(2) = ic
        iprb(3) = ic
        exit
      endif
    enddo
    do jc=1,jmax-1
      if(ycen(jc)<0.d0 .and. 0.d0<ycen(jc+1)) then
        jprb(1) = jc
      endif
      if(ycen(jc)<1.d0 .and. 1.d0<ycen(jc+1)) then
        jprb(2) = jc
      endif
      if(ycen(jc)<2.d0 .and. 2.d0<ycen(jc+1)) then
        jprb(3) = jc
      endif
    enddo
!
  endif
!
  prob(1,istep) = dsqrt(ustg(iprb(1),jprb(1))**2+vstg(iprb(1),jprb(1))**2)
  prob(2,istep) = dsqrt(ustg(iprb(2),jprb(2))**2+vstg(iprb(2),jprb(2))**2)
  prob(3,istep) = dsqrt(ustg(iprb(3),jprb(3))**2+vstg(iprb(3),jprb(3))**2)
!
  if(istep==nstep) then
    open(60,file='probe.dat',form='formatted',status='replace',action='write')
    ic = 0
    write(60,'(i6,6f12.7)') ic,xcen(iprb(1)),xcen(iprb(2)),xcen(iprb(3)), &
                               ycen(jprb(1)),ycen(jprb(2)),ycen(jprb(3))
    do ic=1,nstep,8
      write(60,'(i6,3f12.7)') ic,prob(1,ic),prob(2,ic),prob(3,ic)
    enddo
    close(60)
  endif
!
  return
end subroutine sub_probe
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
! Probing u-velocity
!-----------------------------------------------------------------------
subroutine sub_probe2(istep,iter,icycl,char)
!-----------------------------------------------------------------------
  use mod_variables,only : jmax,imx1,xcen,ycen,ustg, &
                           iprb,jprb,prob,nstep,ncycl,nsall,ihx
  implicit none
!
  integer :: ic,jc,istep,ierr,iter,icycl,ip,icc
  real(8) :: xx,yy,xt,yt,dist,dmin
  character(len=3) :: char
!-----------------------------------------------------------------------
!
!
  if(istep==1 .and. iter==1 .and. icycl==1) then
!
    if(allocated(prob)) deallocate(prob)
    allocate(prob(4,nsall*ncycl),stat=ierr)
    prob(:,:) = 0.d0
!
!
!   Position 1
    xt   =-2.5d0
    yt   =-0.5d0
    dmin = 9.d0
    do jc=1,jmax
    do ic=1,imx1
!     if(ihx(ic,jc,1)==1) then
        xx   = xcen(ic)
        yy   = 0.5d0*(ycen(jc)+ycen(jc+1))
        dist = (xx-xt)**2+(yy-yt)**2
        if(dist<=dmin) then
          dmin    = dist
          iprb(1) = ic
          jprb(1) = jc
        endif
!     endif
    enddo
    enddo
!   Position 2
    xt   = 0.0d0
    yt   =-2.5d0
    dmin = 9.d0
    do jc=1,jmax
    do ic=1,imx1
!     if(ihx(ic,jc,1)==1) then
        xx   = xcen(ic)
        yy   = 0.5d0*(ycen(jc)+ycen(jc+1))
        dist = (xx-xt)**2+(yy-yt)**2
        if(dist<=dmin) then
          dmin    = dist
          iprb(2) = ic
          jprb(2) = jc
        endif
!     endif
    enddo
    enddo
!   Position 3
    xt   = 2.5d0
    yt   = 0.0d0
    dmin = 9.d0
    do jc=1,jmax
    do ic=1,imx1
!     if(ihx(ic,jc,1)==1) then
        xx   = xcen(ic)
        yy   = 0.5d0*(ycen(jc)+ycen(jc+1))
        dist = (xx-xt)**2+(yy-yt)**2
        if(dist<=dmin) then
          dmin    = dist
          iprb(3) = ic
          jprb(3) = jc
        endif
!     endif
    enddo
    enddo
!   Position 4
    xt   = 7.5d0
    yt   = 0.0d0
    dmin = 9.d0
    do jc=1,jmax
    do ic=1,imx1
!     if(ihx(ic,jc,1)==1) then
        xx   = xcen(ic)
        yy   = 0.5d0*(ycen(jc)+ycen(jc+1))
        dist = (xx-xt)**2+(yy-yt)**2
        if(dist<dmin) then
          dmin    = dist
          iprb(4) = ic
          jprb(4) = jc
        endif
!     endif
    enddo
    enddo
    jprb(4) = jprb(3)
!
    if(char=="ref") then
      open(60,file='probe_ref.dat',form='formatted',status='replace',action='write')
      write(60,'(" pos(x,y)",8f12.7)') (xcen(iprb(ip)),ycen(jprb(ip)),ip=1,4)
      write(60,'(" iter   step      ref1        ref2        ref3        ref4")')
      close(60)
      open(60,file='probe_mes.dat',form='formatted',status='replace',action='write')
      write(60,'(" pos(x,y)",8f12.7)') (xcen(iprb(ip)),ycen(jprb(ip)),ip=1,4)
      write(60,'(" iter   step      mes1        mes2        mes3        mes4")')
      close(60)
    elseif(char=="est") then
      open(60,file='probe_est.dat',form='formatted',status='replace',action='write')
      write(60,'(" pos(x,y)",8f12.7)') (xcen(iprb(ip)),ycen(jprb(ip)),ip=1,4)
      write(60,'(" iter   step      est1        est2        est3        est4")')
      close(60)
    elseif(char=="bst") then
      open(60,file='probe_bst.dat',form='formatted',status='replace',action='write')
      write(60,'(" pos(x,y)",8f12.7)') (xcen(iprb(ip)),ycen(jprb(ip)),ip=1,4)
      write(60,'(" iter   step      bst1        bst2        bst3        bst4")')
      close(60)
    endif
!
  endif
!
  prob(1,istep) = ustg(iprb(1),jprb(1))
  prob(2,istep) = ustg(iprb(2),jprb(2))
  prob(3,istep) = ustg(iprb(3),jprb(3))
  prob(4,istep) = ustg(iprb(4),jprb(4))
!
  if(char=="ref" .and. istep==icycl*nsall) then
    open(60,file='probe_ref.dat',form='formatted',position='append')
    do ic=1+(icycl-1)*nsall,(icycl)*nsall
      write(60,'(2i6,4f12.7)') iter,ic,prob(1,ic),prob(2,ic),prob(3,ic),prob(4,ic)
    enddo
    close(60)
    open(60,file='probe_mes.dat',form='formatted',position='append')
    do ic=1,nstep
      icc = ic+(icycl-1)*nstep
      if(maxval(ihx(:,:,ic))>0) then
        write(60,'(2i6,4f12.7)') iter,icc,prob(1,icc),prob(2,icc),prob(3,icc),prob(4,icc)
      endif
    enddo
    close(60)
  elseif(char=="est" .and. istep==icycl*nstep) then
    open(60,file='probe_est.dat',form='formatted',position='append')
    do ic=1+(icycl-1)*nstep,(icycl)*nstep
      write(60,'(2i6,4f12.7)') iter,ic,prob(1,ic),prob(2,ic),prob(3,ic),prob(4,ic)
    enddo
    write(60,'(2i6,4f12.7)')
    close(60)
  elseif(char=="bst" .and. istep==icycl*nsall) then
    open(60,file='probe_bst.dat',form='formatted',position='append')
    do ic=1+(icycl-1)*nsall,(icycl)*nsall
      write(60,'(2i6,4f12.7)') iter,ic,prob(1,ic),prob(2,ic),prob(3,ic),prob(4,ic)
    enddo
    close(60)
  endif
!
  return
end subroutine sub_probe2
!-----------------------------------------------------------------------


c     subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c
c     construction and/or application of a single
c     householder transformation..     q = i + u*(u**t)/b
c
c     mode    = 1 or 2	 to select algorithm  h1  or  h2 .
c     lpivot is the index of the pivot element.
c     l1,m   if l1 .le. m   the transformation will be constructed to
c	     zero elements indexed from l1 through m.	if l1 gt. m
c	     the subroutine does an identity transformation.
c     u(),iue,up    on entry to h1 u() contains the pivot vector.
c		    iue is the storage increment between elements.
c					on exit from h1 u() and up
c		    contain quantities defining the vector u of the
c		    householder transformation.   on entry to h2 u()
c		    and up should contain quantities previously computed
c		    by h1.  these will not be modified by h2.
c     c()    on entry to h1 or h2 c() contains a matrix which will be
c	     regarded as a set of vectors to which the householder
c	     transformation is to be applied.  on exit c() contains the
c	     set of transformed vectors.
c     ice    storage increment between elements of vectors in c().
c     icv    storage increment between vectors in c().
c     ncv    number of vectors in c() to be transformed. if ncv .le. 0
c	     no operations will be done on c().
c
      subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv)
      dimension u(iue,m), c(1)
      double precision sm,b
      one=1.
c
      if (0.ge.lpivot.or.lpivot.ge.l1.or.l1.gt.m) return
      cl=abs(u(1,lpivot))
      if (mode.eq.2) go to 60
c			     ****** construct the transformation. ******
	  do 10 j=l1,m
   10	  cl=amax1(abs(u(1,j)),cl)
      if (cl) 130,130,20
   20 clinv=one/cl
      sm=(dble(u(1,lpivot))*clinv)**2
	  do 30 j=l1,m
   30	  sm=sm+(dble(u(1,j))*clinv)**2
c			       convert dble. prec. sm to sngl. prec. sm1
      sm1=sm
      cl=cl*sqrt(sm1)
      if (u(1,lpivot)) 50,50,40
   40 cl=-cl
   50 up=u(1,lpivot)-cl
      u(1,lpivot)=cl
      go to 70
c	     ****** apply the transformation  i+u*(u**t)/b  to c. ******
c
   60 if (cl) 130,130,70
   70 if (ncv.le.0) return
      b=dble(up)*u(1,lpivot)
c			b  must be nonpositive here.  if b = 0., return.
c
      if (b) 80,130,130
   80 b=one/b
      i2=1-icv+ice*(lpivot-1)
      incr=ice*(l1-lpivot)
	  do 120 j=1,ncv
	  i2=i2+icv
	  i3=i2+incr
	  i4=i3
	  sm=c(i2)*dble(up)
	      do 90 i=l1,m
	      sm=sm+c(i3)*dble(u(1,i))
   90	      i3=i3+ice
	  if (sm) 100,120,100
  100	  sm=sm*b
	  c(i2)=c(i2)+sm*dble(up)
	      do 110 i=l1,m
	      c(i4)=c(i4)+sm*dble(u(1,i))
  110	      i4=i4+ice
  120	  continue
  130 return
      end


subroutine topol(s, q)

  implicit none

  real(8), parameter   :: pi2 = 2.0 * 3.141592653589793

  integer, parameter   :: np = 400
  integer, parameter   :: nnmax = 7
  integer, parameter   :: ndr = 2 * np

  real(8), intent(in)  :: s(-nnmax+1:np,3)
  real(8), intent(out) :: q
  integer              :: ldr(ndr,3)

  real(8)              :: siga
  real(8)              :: s11, s12, s13, s21, s22, s23, s31, s32, s33
  real(8)              :: cc, cc1, cc2, cc3
  real(8)              :: ss, ss1, ss2, ss3
  integer              :: idr, n, is

  common /lattice/ ldr

  siga = 0.0
  do idr = 0, ndr/2, ndr/2

     ! *****   cc = 1 + s1*s2 + s2*s3 + s3*s1   *****
     ! *****   ss = s1 * ( s2 x s3 )            *****

     do is = 1, ndr/2
        s11 = s(ldr(idr+is,1),1)
        s12 = s(ldr(idr+is,1),2)
        s13 = s(ldr(idr+is,1),3)

        s21 = s(ldr(idr+is,2),1)
        s22 = s(ldr(idr+is,2),2)
        s23 = s(ldr(idr+is,2),3)

        s31 = s(ldr(idr+is,3),1)
        s32 = s(ldr(idr+is,3),2)
        s33 = s(ldr(idr+is,3),3)

        cc1 = s11 * s21 + s12 * s22 + s13 * s23
        cc2 = s21 * s31 + s22 * s32 + s23 * s33
        cc3 = s31 * s11 + s32 * s12 + s33 * s13

        cc  = 1.0 + cc1 + cc2 + cc3

        ss1 = s22 * s33 - s23 * s32
        ss2 = s23 * s31 - s21 * s33
        ss3 = s21 * s32 - s22 * s31

        ss  = s11 * ss1 + s12 * ss2 + s13 * ss3

        siga = siga + atan2(ss,cc)
     enddo

  enddo

  q = siga / pi2

end


c     # ------------------------------------------------------------
c     # Define cell centered velocity field using basis functions
c     #
c     #      u = u1*t1 + u2*t2   (div u might not be zero)
c     #
c     # NOTE: All arguments to routines here should be in computational
c     # coordinates (x,y) in [0,1]x[0,1].  Mapping from brick domains
c     # to [0,1]x[0,1] should be done from calling routines, as should
c     # any mappings that convert from an orthogonal coordinate system
c     # to a non-orthogonal system.
c     # ------------------------------------------------------------

c     # ------------------------------------------------------------
c     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
c     # ------------------------------------------------------------
      subroutine annulus_center_velocity(x,y,t,vel)
      implicit none

      double precision x,y,vel(3), t

      double precision t1(3), t2(3), u(2)

      integer k

c     # Vector field defined as u1*tau1 + u2*tau2

      call annulus_covariant_basis(x, y, t1,t2)
      call annulus_velocity_components(x,y,t,u)

      do k = 1,3
          vel(k) = u(1)*t1(k) + u(2)*t2(k)
      enddo

      end

      subroutine annulus_covariant_basis(x,y,t1,t2)
      implicit none

      double precision x,y,t1(3),t2(3)
      double precision t(3,2),tinv(3,2), tderivs(3,2,2)
      integer flag, k

c     # Compute covariant derivatives only
      flag = 1
      call annulus_basis_complete(x,y, t, tinv, tderivs, flag)

      do k = 1,3
          t1(k) = t(k,1)
          t2(k) = t(k,2)
      enddo

      end

c     # ----------------------------------------------------------------
c     # Utility functions
c     # ----------------------------------------------------------------

      subroutine annulus_cross(u,v,uxv,w)
      implicit none

      double precision u(3),v(3),uxv(3),w, annulus_dot
      integer k

      uxv(1) =   u(2)*v(3) - u(3)*v(2)
      uxv(2) = -(u(1)*v(3) - u(3)*v(1))
      uxv(3) =   u(1)*v(2) - u(2)*v(1)

      w = annulus_dot(uxv,uxv)
      w = sqrt(w)

      end

      double precision function annulus_dot(u,v)
      implicit none

      double precision u(3),v(3)

      annulus_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


      PROGRAM xfredin
C     driver for routine fredin
      INTEGER N
      REAL PI
      PARAMETER(N=8,PI=3.1415927)
      REAL a,ak,ans,b,fredin,g,x,t(N),f(N),w(N)
      EXTERNAL g,ak
      a=0.
      b=PI/2.
      call fred2(N,a,b,t,f,w,g,ak)
100   format(3f10.6)
1     write(*,*) 'Enter T between 0 and PI/2'
      read(*,*,END=99) x
      ans=fredin(x,N,a,b,t,f,w,g,ak)
      write(*,*) 'T, Calculated answer, True answer'
      write(*,100) x,ans,sqrt(x)
      go to 1
99    stop
      END
      REAL FUNCTION g(t)
      REAL PI
      PARAMETER(PI=3.1415927)
      REAL t
      g=sqrt(t)-(PI/2.)**2.25*t**.75/2.25
      return
      END
      REAL FUNCTION ak(t,s)
      REAL s,t
      ak=(t*s)**.75
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfredin.for


! { dg-do run }
program main
  integer, parameter :: sz=5, su=3
  integer, parameter :: l=2
  integer, parameter :: u=l-1+su
  integer(kind=4), dimension(sz,sz) :: r,a,b
  integer :: i,j
  do i=1,4
     do j=1,4
        a(i,j) = i*10+j
        b(i,j) = 100+i*10+j
     end do
  end do
  r = -1
  b(l:u,l:u) = reshape([(i,i=1,su*su)],[su,su]);
  a(l:u,l:u) = reshape([(i,i=1,su*su)],[su,su]);

  r(1:su,1:su) = matmul(a(l:u,l:u),b(l:u,l:u))
  if (any(reshape(r,[sz*sz]) /= [30, 36, 42, -1, -1, 66, 81, 96, -1, -1,&
       & 102, 126, 150, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1])) &
       call abort
end program main


subroutine fprint(no,ncase,neqn,t,u)
!
! Subroutine fprint displays the numerical and
! analytical solutions to the 1 x 1 ODE problem
!
! Double precision coding is used
implicit double precision(a-h,l,o-z)
!
! Size the arrays
dimension u(neqn)
!
! Problem parameters
u0=1.0d0
alpha=1.0d0
lambda=1.0d0
!
! Print a heading for the solution at t = 0
if(t.le.0.0d0)then
!
! Label for ODE integrator
!
! Fixed step modfied Euler
if(ncase.eq.1)then
write(no,11)
11 format(//,6x,'euler2a integrator')
!
! Variable step modified Euler
else if(ncase.eq.2)then
write(no,12)
12 format(//,6x,'euler2b integrator')
!
! Fixed step classical fourth order RK
else if(ncase.eq.3)then
write(no,13)
13 format(//,6x,'rkc4a integrator')
!
! Variable step classical fourth order RK
else if(ncase.eq.4)then
write(no,14)
14 format(//,6x,'rkc4b integrator')
!
! Fixed step RK Fehlberg 45
else if(ncase.eq.5)then
write(no,15)
15 format(//,6x,'rkf45a integrator')
!
! Variable step RK Fehlberg 45
else if(ncase.eq.6)then
write(no,16)
16 format(//,6x,'rkf45b integrator')
end if
!
! Heading
write(no,2)
2 format(/,9x,'t',3x,'u1(num)',4x,'u1(ex)',8x,'diff1',/)
!
! End of t = 0 heading
end if
!
! Analytical solution
u1exact=u0*dexp(lambda/alpha*(1.0d0-dexp(-alpha*t)))
!
! Difference between exact and numerical solution vectors
diff1=u(1)-u1exact
!
! Display the numerical and exact solutions, and their
! difference
write(no,3)t,u(1),u1exact,diff1
3 format(f10.2,2f10.5,e13.4)
return
!
! End of fprint
end


SUBROUTINE chstwo(bins1,bins2,nbins,knstrn,df,chsq,prob)
INTEGER knstrn,nbins
REAL*8 :: chsq,df,prob,bins1(nbins),bins2(nbins)
!CU    USES gammq
INTEGER j
REAL gammq
df=nbins-knstrn
 chsq=0.
do j=1,nbins
  if(bins1(j).eq.0..and.bins2(j).eq.0.)then
    df=df-1.
  else
    chsq=chsq+(bins1(j)-bins2(j))**2/(bins1(j)+bins2(j))
  endif
enddo
prob=gammq(0.5*df,0.5*chsq)
return
END


module global_module

  implicit none

  ! Time integration

  real(kind=8), parameter :: dt  = 0.0005d0 ! [s] time step
  integer,      parameter :: Nt  = 500 ! Number of time steps to be performed

  real(kind=8), parameter :: x_min = -0.5d0 ! [m] beginning of computational domain
  real(kind=8), parameter :: x_max = 0.5d0  ! [m] end of computational domain

  ! Total number of cells (including 4 ghost cells for each side)
  ! (using 4 ghost cells makes it easy to reach higher order accuracy)

  integer, parameter :: Nx = 200

  logical, parameter :: bool_PERIODIC = .false. ! Boundary conditions

  ! Note: we use here 4 ghost cells per side. This allows for a good generalization
  ! for higher order cases.
  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-8)

end module


C
       real*4 function ct_lin_inv_grey( rgb, ci, cimin, cimax )
C      --------------------------------------------------------
C
C Function defining a standard linear inverted grey-scale.
C
C    ct_lin_inv_grey = (cimax-ci)/(cimax-cimin)
C
*-

       integer        rgb, ci, cimin, cimax
       ct_lin_inv_grey  = (float(cimax-ci)/float(cimax-cimin))
       end


program problem_7

use aoc_utilities

implicit none

integer :: iunit, i, j, k, n
character(len=:),allocatable :: line
logical :: status_ok
type(string),dimension(:),allocatable :: vals
integer,dimension(:),allocatable :: list
integer :: min_fuel

open(newunit=iunit,file='inputs/day7.txt')

call read_line_from_file(iunit,line,status_ok)

call split(line,',',vals)
n = size(vals)

allocate(list(n))
do i = 1, n
    list(i) = vals(i)%to_int()
end do

min_fuel = minval([(sum(abs(list-i)), i = 0, maxval(list))])
write(*,*) '7a: ', min_fuel

min_fuel = minval([( sum( [(sum( [(k, k = 1, abs(list(j)-i))] ), j = 1, size(list) )] ), i = 0, maxval(list) )])
write(*,*) '7b: ', min_fuel

end program problem_7


c -------------------------------------------------------------
      SUBROUTINE DREGCOEF(X,Y,NPTS,XMSG,YMSG,RCOEF,TVAL,NPTXY,XAVE,
     +     YAVE,RSTD,YINT,IER)
      IMPLICIT NONE

c NCL:  rcoef = regCoef (x,y)
c NCL:  rcoef = regcoef (x,y,tval,nptxy)
c NCL:  rcoef = regline (x,y,tval,nptxy,xave,yave)

c this routine will calculate the regression coef (trend, slope,..),
c .   x and y averages, the t-statistic and the number of pts used
c .   missing data are allowed.

c .   see: brownlee
c .        statistical theory and methodology
c .        j wiley 1965   pgs: 281-284     QA276  .B77

c arguments :
c .   x,y      - input vectors
c .   npts     - length of vectors x and y
c .   xmsg,ymsg- missing code: if no msg values set to some number
c .                            which will not be encountered.
c .              dmsg will be used to fill missing values
c .   rcoef    - slope (trend ... regression coef)
c .   tval     - t-statistic (null hypothesis: H0: r=0.0)
c .   nptxy    - number of points used
c .   rstd     - standard deviation of the regression coefficient
c .   xave     - average of x
c .   yave     - average of y
c .   yint     - y-intercept
c .   ier      - if (ier.ne.0) an error has occurred

C input
      INTEGER NPTS,NPTXY
C input
      DOUBLE PRECISION X(1:NPTS),Y(1:NPTS),XMSG,YMSG
C output
      INTEGER IER
C output
      DOUBLE PRECISION RCOEF,TVAL,YAVE,XAVE,RSTD,YINT

C local
      LOGICAL REGDBG
      INTEGER N
      DOUBLE PRECISION RNULL,XYN,DF
      DOUBLE PRECISION XSUM,YSUM,X2SUM,Y2SUM,XYSUM,XVAR,YVAR,XYVAR,
     +                 SSQREG,SSQ,VB,SQRTVB

      IER = 0
      TVAL  = YMSG
      RCOEF = YMSG
      RSTD  = YMSG
      IF (NPTS.LT.2) IER = 1
      IF (IER.NE.0) RETURN

C null hypothesis
      RNULL = 0.0D0

      XYN = 0.0D0
      XSUM = 0.d0
      YSUM = 0.d0
      X2SUM = 0.d0
      Y2SUM = 0.d0
      XYSUM = 0.d0
      DO N = 1,NPTS
          IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
              XSUM = XSUM + DBLE(X(N))
              YSUM = YSUM + DBLE(Y(N))
              X2SUM = X2SUM + X(N)*X(N)
              Y2SUM = Y2SUM + Y(N)*Y(N)
              XYSUM = XYSUM + X(N)*Y(N)
              XYN = XYN + 1.D0
          END IF
      END DO

      NPTXY = XYN

      IF (XYN.LT.1.D0) THEN
C all msg values
          IER = 5
          RETURN
      ELSE IF (XYN.LT.3.D0) THEN
C not enough data
          IER = 6
          RETURN
      END IF

      XAVE = XSUM/XYN
      YAVE = YSUM/XYN

      XVAR = X2SUM - XSUM*XSUM/DBLE(XYN)
      YVAR = Y2SUM - YSUM*YSUM/DBLE(XYN)
      XYVAR = XYSUM - XSUM*YSUM/DBLE(XYN)

      IF (XVAR.GT.0.D0) then
C regression coef (b in book)
          RCOEF = XYVAR/XVAR
C sum of squares due to regression
          SSQREG = XYVAR* (XYVAR/XVAR)
          SSQ = (YVAR-SSQREG)/DBLE(XYN-2.D0)
C v[b] in book {variance of B}
          VB = SSQ/XVAR
          SQRTVB = DSQRT(VB)
C t-statistic and standard deviation of reg coef
          IF (SQRTVB.GT.0.D0) then
              TVAL = (RCOEF-RNULL)/SQRTVB
              RSTD = SQRTVB
          ELSE
              TVAL = YMSG
          END IF
C degrees of freedom
          DF = XYN - 2.D0
C y-intercept
          YINT = YAVE - RCOEF*XAVE
      ELSE
c XVAR = 0.0
          IER    = 7
          SSQREG = YMSG
          SSQ    = YMSG
          VB     = YMSG
          SQRTVB = YMSG
          TVAL   = YMSG
          RCOEF  = YMSG
          YINT   = YMSG
      END IF

      REGDBG = .false.
      IF (REGDBG) THEN
          WRITE (*,FMT='(///,'' trtest: debug'')')
          WRITE (*,FMT='('' xsum  ='',f12.5)') XSUM
          WRITE (*,FMT='('' ysum  ='',f12.5)') YSUM
          WRITE (*,FMT='('' x2sum ='',f12.5)') X2SUM
          WRITE (*,FMT='('' y2sum ='',f12.5)') Y2SUM
          WRITE (*,FMT='('' xysum ='',f12.5)') XYSUM
          WRITE (*,FMT='('' xvar  ='',f12.5)') XVAR
          WRITE (*,FMT='('' yvar  ='',f12.9)') YVAR
          WRITE (*,FMT='('' xyvar ='',f12.9)') XYVAR
          WRITE (*,FMT='('' ssqreg='',f12.9)') SSQREG
          WRITE (*,FMT='('' ssq   ='',f12.9)') SSQ
          WRITE (*,FMT='('' rcoef ='',f12.9)') RCOEF
          WRITE (*,FMT='('' rnull ='',f12.9)') RNULL
          WRITE (*,FMT='('' vb    ='',f15.9)') VB
          WRITE (*,FMT='('' rstd(=sqrtvb)='',f15.9)') RSTD
          WRITE (*,FMT='('' tval  ='',f15.9)') TVAL
          WRITE (*,FMT='('' yint  ='',f15.9)') YINT
      END IF

      RETURN
      END


      SUBROUTINE INCORE(A,N,B,CX,IX)
C
C     IN-CORE DECOMPOSITION OF SQUARE, COMPLEX, NXN MATRIX,A.
C     AX = B.
C     CX = X
C     IX = NUMBER OF B VECTORS SPECIFIED.
C
      COMPLEX A(N,N), B(IX,N), CX(IX,N), CMAX, SCRCH
      COMPLEX T1,T2,T3
      COMPLEX CSUM
C
C
      IF(N.EQ.2) GO TO 500
      IF(N.EQ.1) GO TO 600
      NM1 = N-1
C
C     PIVOT MAYBE.
C
      DO 150 J=1,NM1
      CMAX = A(J,J)
      JP1 = J + 1
      JMAX = J
      DO 100 JJ= JP1,N
      IF(CABS(A(J,JJ)).LE.CABS(CMAX)) GO TO 100
      CMAX = A(J,JJ)
      IROW = JJ
      JMAX = JJ
  100 CONTINUE
C
C     IROW = ROW WITH LARGEST ELEMENT IN COLUMN J.
C     MOVE PIVOT ROW TO TOP OF ELIMINATION
C
      AMAX = CABS(CMAX)
      IF(AMAX.EQ.0.) GO TO 150
      IF(JMAX.EQ.J) GO TO 120
      DO 110 JJ= J,N
      SCRCH = A(JJ,J)
      A(JJ,J) = A(JJ,IROW)
      A(JJ,IROW) = SCRCH
  110 CONTINUE
C
C     INTERCHANGE B VECTOR
C
      DO 115 JJ = 1,IX
      SCRCH = B(JJ,J)
      B(JJ,J) = B(JJ,IROW)
      B(JJ,IROW) = SCRCH
  115 CONTINUE
C
C     ELIMINATE COLUMN
C
  120 CONTINUE
      A(J,J) = (1.0,0.0) / A(J,J)
      T1 = A(J,J)
      DO 140 I=JP1,N
      T2 = A(I,J)
      IF(CABS(T2).LT.(1.0E-19)) GO TO 140
      T2 = -T2*T1
      A(I,J) = T2
      DO 130 L = JP1,N
      T3 = A(J,L)
      IF(CABS(T3).LT.(1.0E-19)) GO TO 130
      A(I,L) = A(I,L) + T3*T2
  130 CONTINUE
  140 CONTINUE
C
C     HANDLE B ELIMINATION.
C
      DO 141 JJ = 1,IX
      B(JJ,J) = B(JJ,J) * T1
  141 CONTINUE
      DO 145 JJ = 1,IX
      DO 145 K=JP1,N
      B(JJ,K) = B(JJ,K) - B(JJ,J)*A(J,K)
  145 CONTINUE
  150 CONTINUE
C
C     BACKWARD PASS.
C
      DO 185 JJ = 1,IX
      CX(JJ,N) = B(JJ,N)/A(N,N)
  185 CONTINUE
      DO 210 JJ = 1,IX
      I = N
  190 CONTINUE
      CSUM = (0.,0.)
      K = I-1
      DO 200 J=I,N
      CSUM = CSUM + CX(JJ,J)*A(J,K)
  200 CONTINUE
      CX(JJ, K)    = B(JJ, K)    + CSUM
      IF(I.LE.2) GO TO 210
      I = I-1
      GO TO 190
  210 CONTINUE
      RETURN
  500 CONTINUE
      DO 510 I = 1,IX
      CX(I ,2) = (B(I ,2)-(B(I ,1)*A(1,2)/A(1,1)))/(A(2,2)-(A(2,1)
     +  *A(1,2)/A(1,1)))
      CX(I ,1) = B(I ,1)/A(1,1)-A(2,1)*CX(I ,2)/A(1,1)
  510 CONTINUE
      RETURN
  600 CONTINUE
      DO 610 I=1,IX
      CX(I ,1) = B(I ,1)/A(1,1)
  610 CONTINUE
      RETURN
      END


PROGRAM pg125
!-------------------------------------------------------------------------
!   Program 12.5 conduction equation on a 3-d box volume using 8-node
!   hexahedral elements and a simple explicit algorithm: DEC, parallel
!   version write on processor it at freedom nres
!-------------------------------------------------------------------------
!USE mpi_wrapper !remove comment for serial compilation
 USE precision; USE global_variables; USE mp_interface; USE input
 USE output; USE loading; USE timing; USE maths; USE gather_scatter
 USE geometry; USE new_library; USE common_mod; USE geometry_mod
 IMPLICIT NONE
! neq,ntot are now global variables - not declared
 INTEGER,PARAMETER::nodof=1,ndim=3
 INTEGER::nels,ndof,npes_pp,nn,nr,nip,nod,i,j,k,m,iel,nstep,nlen,          &
   npri,nres,it,is,meshgen,partitioner,loaded_nodes=0,fixed_freedoms,    &
   nodes_pp,node_start,node_end
 REAL(iwp)::kx,ky,kz,det,dtim,val0,real_time
 REAL(iwp),PARAMETER::zero=0.0_iwp; CHARACTER(LEN=6)::ch
 CHARACTER(LEN=15)::element; CHARACTER(LEN=50)::argv
!------------------------------ dynamic arrays ---------------------------
 REAL(iwp),ALLOCATABLE::loads_pp(:),points(:,:),kay(:),jac(:,:),       &
   der(:,:),deriv(:,:),weights(:),kc(:,:),funny(:,:),globma_pp(:),       &
   fun(:),store_pm_pp(:,:,:),newlo_pp(:),mass(:),globma_tmp(:,:),        &
   pmul_pp(:,:),utemp_pp(:,:),g_coord_pp(:,:,:),timest(:),pm(:,:),       &
   ptl_pp(:)
 INTEGER,ALLOCATABLE::rest(:,:),g_num_pp(:,:),g_g_pp(:,:)

 INTEGER :: n_smplx
 INTEGER, ALLOCATABLE :: smplx(:,:)
 REAL(iwp):: ka
!-------------------------- input and initialisation ---------------------
 ALLOCATE(timest(25)); timest=zero; timest(1)=elap_time()
 CALL find_pe_procs(numpe,npes); CALL getname(argv,nlen)
 CALL read_p125(argv,numpe,dtim,element,fixed_freedoms,kx,ky,kz,         &
   loaded_nodes,meshgen,nels,nip,nn,nod,npri,nr,nres,nstep,partitioner,  &
   val0)
 CALL calc_nels_pp(argv,nels,npes,numpe,partitioner,nels_pp)
 ndof=nod*nodof; ntot=ndof
 ALLOCATE(g_num_pp(nod,nels_pp),g_coord_pp(nod,ndim,nels_pp),            &
   rest(nr,nodof+1)); g_num_pp=0; g_coord_pp=zero; rest=0
 CALL read_g_num_pp(argv,iel_start,nn,npes,numpe,g_num_pp)
 IF(meshgen==2) CALL abaqus2sg(element,g_num_pp)
 CALL read_g_coord_pp(argv,g_num_pp,nn,npes,numpe,g_coord_pp)
 CALL read_rest(argv,numpe,rest);timest(2)=elap_time()
 ALLOCATE (points(nip,ndim),weights(nip),kay(ndim),jac(ndim,ndim),  &
   der(ndim,nod),deriv(ndim,nod),kc(ntot,ntot),funny(1,nod),             &
   g_g_pp(ntot,nels_pp),store_pm_pp(ntot,ntot,nels_pp),                  &
   mass(ntot),fun(nod),pm(ntot,ntot),globma_tmp(ntot,nels_pp),           &
   pmul_pp(ntot,nels_pp),utemp_pp(ntot,nels_pp))
!----------  find the steering array and equations per process -----------
 CALL rearrange_2(rest); g_g_pp = 0; neq=0
 elements_0: DO iel = 1, nels_pp
   CALL find_g4(g_num_pp(:,iel),g_g_pp(:,iel),rest)
 END DO elements_0
 neq=MAXVAL(g_g_pp); neq=max_p(neq); CALL calc_neq_pp
 CALL calc_npes_pp(npes,npes_pp); CALL make_ggl(npes_pp,npes,g_g_pp)
 DO i=1,neq_pp; IF(nres==ieq_start+i-1)THEN;it=numpe;is=i;END IF;END DO
 IF(numpe==it)THEN
   OPEN(11,FILE=argv(1:nlen)//".res",STATUS='REPLACE',ACTION='WRITE')
   WRITE(11,'(A,I5,A)')"This job ran on ",npes,"  processes"
   WRITE(11,'(A,3(I12,A))')"There are ",nn," nodes",nr," restrained and",&
     neq," equations"
   WRITE(11,'(A,F10.4)') "Time to read input is:",timest(2)-timest(1)
   WRITE(11,'(A,F10.4)') "Time after setup is:",elap_time()-timest(1)
 END IF
 ALLOCATE(loads_pp(neq_pp),newlo_pp(neq_pp),globma_pp(neq_pp))
 loads_pp=zero; newlo_pp=zero; globma_pp=zero; globma_tmp=zero
!------------- loop the elements for integration and invert mass ---------
 timest(3)=elap_time();

 dim_cmplx = 3;  dim_embbd = 3;  k=dim_cmplx+1
 ALLOCATE(num_pelm_pp(1)); num_pelm_pp(1)=nod;  extra_pelm=0;  glb_offset=0
 glb_num_elm = (/ nod, 19, 18, 6 /);  num_elm=glb_num_elm
 ALLOCATE(lcl_complex(k));
 ALLOCATE(lcl_complex(1)%centers(nod,dim_embbd),&
   lcl_complex(k)%orientation(6),lcl_complex(k)%node_indx(6,k))
 lcl_complex(k)%orientation=0;  indx_offset = 0

 kay=zero; kay(1)=kx; kay(2)=ky; kay(3)=kz
 elements_1: DO iel=1,nels_pp
   kc=zero; pm=zero

   !- split elements into simplices
   CALL elm2smplx(num_elm(dim_cmplx+1),lcl_complex(dim_cmplx+1)%node_indx,&
      g_coord_pp(:,:,iel),element,nod)

   !- Recursively compute element (co-)boundaries
   DO k=dim_cmplx+1,2,-1; CALL calc_bndry_cobndry(k); END DO

   !- setup connectivity
   DO k=1,dim_cmplx+1; lcl_complex(k)%lcl_node_indx = lcl_complex(k)%node_indx; END DO

   !- calc circumcenter
   lcl_complex(1)%centers = g_coord_pp(:,:,iel)
   DO k=2,dim_cmplx+1; CALL calc_circumcenters(k); END DO

   !- calc primal edge and dual area and primal direction
   CALL calc_prml_unsgnd_vlm(2); CALL calc_dual_vlm(1)
   CALL calc_prml_dir()

   DO i=1,nod
     DO j=1,lcl_complex(1)%num_cobndry(i)
       k = lcl_complex(1)%cobndry(i)%indx(j)
       IF (ABS(lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small))<smalls) CYCLE
       m = lcl_complex(2)%bndry(k)%indx(1)
       IF (i==m) m = lcl_complex(2)%bndry(k)%indx(2)
       ka = DOT_PRODUCT(kay,abs(lcl_complex(2)%prml_dir(k,:)))
       kc(i,m) = kc(i,m) - ka*lcl_complex(2)%dual_volume(k) / max(lcl_complex(2)%prml_volume(k),small)
       kc(i,i) = kc(i,i) + ka*lcl_complex(2)%dual_volume(k) / max(lcl_complex(2)%prml_volume(k),small)
     END DO
     pm(i,i) = pm(i,i) + lcl_complex(1)%dual_volume(i)
   END DO
   DO i=1,ntot; mass(i)=pm(i,i); END DO
   store_pm_pp(:,:,iel)=pm-kc*dtim
   DO i=1,ntot; globma_tmp(i,iel)=globma_tmp(i,iel)+mass(i); END DO

   !- Deallocate variables
   DO k=1,dim_cmplx+1;
     IF (ALLOCATED(lcl_complex(k)%recv_indx))   DEALLOCATE(lcl_complex(k)%recv_indx)
     IF (ALLOCATED(lcl_complex(k)%num_bndry))   DEALLOCATE(lcl_complex(k)%num_bndry)
     IF (ALLOCATED(lcl_complex(k)%bndry))       DEALLOCATE(lcl_complex(k)%bndry)
     IF (ALLOCATED(lcl_complex(k)%num_cobndry)) DEALLOCATE(lcl_complex(k)%num_cobndry)
     IF (ALLOCATED(lcl_complex(k)%cobndry))     DEALLOCATE(lcl_complex(k)%cobndry)
     IF (ALLOCATED(lcl_complex(k)%node_indx))   DEALLOCATE(lcl_complex(k)%node_indx)
   END DO
 END DO elements_1
 IF(numpe==it) THEN; WRITE(11,'(A,F10.4)')                              &
   "Time for element integration is :",elap_time()-timest(3); END IF
 CALL scatter(globma_pp,globma_tmp); globma_pp = 1._iwp/globma_pp
 loads_pp=val0; DEALLOCATE(globma_tmp); timest(4)=elap_time()
!------------------------- time stepping recursion -----------------------
 IF(numpe==it)THEN
   WRITE(11,'(A)')"  Time        Pressure"
   WRITE(11,'(2E12.4)') 0.0_iwp, loads_pp(is)
 END IF
 CALL calc_nodes_pp(nn,npes,numpe,node_end,node_start,nodes_pp)
 ALLOCATE(ptl_pp(nodes_pp*ndim))
 timesteps: DO j=1,nstep
   real_time = j*dtim
!------------------------- go round the elements -------------------------
   utemp_pp=zero; pmul_pp=zero; CALL gather(loads_pp,pmul_pp)
   elements_2: DO iel=1,nels_pp
     pm = store_pm_pp(:,:,iel)
     utemp_pp(:,iel) = utemp_pp(:,iel)+MATMUL(pm,pmul_pp(:,iel))
   END DO elements_2; CALL scatter(newlo_pp,utemp_pp)
   loads_pp=newlo_pp*globma_pp; newlo_pp=zero
   IF(j/npri*npri==j) THEN
     IF(numpe==it) WRITE(11,'(2E12.4)')real_time,loads_pp(is)
!--------------------- output pressures for ParaView ---------------------
     IF(numpe==1)THEN; WRITE(ch,'(I6.6)') j
       OPEN(12,file=argv(1:nlen)//".ensi.NDPRE-"//ch,status='replace',   &
         action='write')
       WRITE(12,'(A)')"Alya Ensight Gold --- Scalar per-node variable file"
       WRITE(12,'(A/A/A)') "part", "    1","coordinates"
     END IF
     ptl_pp=zero; utemp_pp=zero; CALL gather(loads_pp(1:),utemp_pp)
     CALL scatter_nodes(npes,nn,nels_pp,g_num_pp,nod,nodof,nodes_pp,     &
       node_start,node_end,utemp_pp,ptl_pp,1)
     CALL dismsh_ensi_p(12,1,nodes_pp,npes,numpe,1,ptl_pp); CLOSE(12)
   END IF
 END DO timesteps; timest(5)=elap_time()
 IF(numpe==it) THEN
   WRITE(11,'(A,F10.4)')"Time stepping recursion took  :",               &
     timest(5)-timest(4)
   WRITE(11,'(A,F10.4)')"This analysis took  :",elap_time()-timest(1)
 END IF; CALL SHUTDOWN()
END PROGRAM pg125


PROGRAM question4
    IMPLICIT NONE
    Integer:: A = 3, B = 5, C = 4
    print *, A/B*C
    print *, A*B/C
    print *, 3 * (A**B)
    print *, B + A/C
    print *, A/B+C
    STOP
END PROGRAM question4


! Program to generate a lattice of spin-1/2 particles and study its
! Ferromagnetic properties

program ising_2d
    implicit none

    integer:: i,j,L,p,a,b,c,d,niter,time,mm,nn,N
    real:: r,q,E,M,mag,Ei,Ef,dE,u,h

    real:: T, J_ising=1.0 !assigning value to relevant parameters: k_B, J_ising

    integer, dimension(:,:), allocatable :: spin
    integer:: seed
    character(len=30):: charac_a, charac_b ! charac_b stores the name dump_pos

    seed=44859
    charac_b = "store_config"

    print*, "Enter the value of KbT is units of J_ising"
    read*, T
    print*, "Enter the number of lattice points in one dimension"
    read*,L
    print*, "Enter the number of iterations"
    read*, niter

    allocate(spin(L,L))
    E=0.0d0 ! Instantaneous Energy of the lattice
    M=0.0d0 ! Instantaneous magnetization of the lattice
    N = L*L ! Total numer of spins in lattice

    ! Initialize your lattice
    open(unit=71, file="initial_ising.dat")
    p=0
    do i=1,L
        do j=1,L
            ! call RANDOM_NUMBER(r)
                spin(j,i) = 1
                ! if (r < 0.5) then
                !     spin(j,i) = -1
                ! else
                !     spin(j,i)=1
                ! End if
            ! Write down this configuration
            !write(71, fmt="(4g10.8)") float(i), float(j), float(p), float(spin(j,i))
            write(71,*) float(i), float(j), float(p), float(spin(j,i))
        end do
    end do
    close(71)

    ! Calculate Initial magnetization and energy
    do i=1,L
        do j=1,L
            a=i+1; b=i-1; c=j+1; d=j-1 !identifying the 4 neighbors of spin(j,i)

            ! Setting PBCs (Periodic Boundary conditions)
            if (i==L)a=1
            if (i==1)b=L
            if (j==1)d=L
            if (j==L)c=1

            E=E-J_ising*float((spin(j,i))*(spin(a,j)+spin(b,j)+spin(i,c)+spin(i,d)))
            M=M+spin(i,j)
        end do
    end do

    ! Calculate instantaneous magnetization per spin
    mag = M/float(N)
    E=E*0.5d0
    print*, "Initial energy E, E per spin is: ",E, E/float(N)
    print*, "Initial magentization M, M per spin is: ", M,mag

    ! INITIALIZATION COMPLETE
    ! -----------------------------
    ! EVOLVE TO REACH EQUILIBRIUM

    open(unit=10, file="ising_T_Linit_random.dat")
    do time=i,niter ! loop over number of MCS
        do mm=1,L
            do nn=1,L
                call random_number(r); i=int(r*float(L))+1 !choosing a lattice site
                call random_number(r); j=int(r*float(L))+1

                a=i+1;b=i-1;c=j+1;d=j-1 !identify the neighbors of spin(j,i)

                if(i==L)a=1; if(i==1)b=L; if(j==1)d=L; if(j==L)c=1 !PBC
                ! BEFORE TRAIL FLIP
                Ei = -J_ising*float((spin(j,i))*(spin(a,j)+spin(b,j)+spin(i,c)+spin(i,d)))

                spin(i,j) =-spin(i,j) !TRIAL FLIP

                ! AFTER TRAIL FLIP
                Ef = -J_ising*float((spin(j,i))*(spin(a,j)+spin(b,j)+spin(i,c)+spin(i,d)))
                dE = Ef-Ei

                if(dE <=0.0) then
                    E=E+dE
                    M=M+(2.0*float(spin(i,j)))
                else
                    u=exp(-dE/(T))
                    call random_number(h)
                    if (h<u) then
                        E=E+dE
                        M=M+(2.0*float(spin(i,j))) ! Instantaneous mag. Of entire lattice
                    else
                        spin(i,j) = -spin(i,j) ! Trial flip not accepted; E & M not updated
                    end if
                end if
            end do
        end do
    write(10,*) time, M/float(N), E/float(N) ! Writing down E and M with no of iterations
    end do
    close(10)

end program ising_2d