C NCLFORTSTART
      subroutine xy2pdf90(nxy,x,y, xmsg,ymsg, nby, mbx, pdf
     *                   ,mbxp1,nbyp1,binxbnd, binybnd,ipcnt,ier)
      implicit none
      integer  nxy, nby, mbx, mbxp1,nbyp1, ipcnt,ier
      double precision x(nxy), y(nxy), xmsg, ymsg
     *                ,binxbnd(mbxp1), binybnd(nbyp1)
      double precision pdf(mbx,nby)
C NCLEND
      integer m, n, mb, nb, kxy, unit, msgflg

c Initialize; Count valid values

      ier   = 0
      pdf   = 0.0
      kxy   = count(x.ne.xmsg .and. y.ne.ymsg)

c Valid data check

      if (kxy.eq.0) then
          ier = 1
          return
      end if

c Very large arrays can result in slow execution times.
c .   To minimize unnecessary do loop checks, see if missing
c .   values are present.

      msgflg = 1
      if (kxy.eq.nxy) msgflg = 0

c binning

      if (msgflg.eq.1) then
          do nb=1,nby
            do mb=1,mbx
               pdf(mb,nb) = count(x.ne.xmsg .and. y.ne.ymsg .and.
     *                            x.ge.binxbnd(mb)  .and.
     *                            x.lt.binxbnd(mb+1).and.
     *                            y.ge.binybnd(nb)  .and.
     *                            y.lt.binybnd(nb+1))
            end do
          end do
      else
          do nb=1,nby
            do mb=1,mbx
               pdf(mb,nb) = count(x.ge.binxbnd(mb)  .and.
     *                            x.lt.binxbnd(mb+1).and.
     *                            y.ge.binybnd(nb)  .and.
     *                            y.lt.binybnd(nb+1))
            end do
          end do
      end if

      unit = 1
      if (ipcnt.eq.1) then
          unit = 100
      end if

      pdf = unit*(pdf/kxy)

      return
      end


program Personal_Income_Tax  !求不同收入的税收
implicit none
    real::income(10)=0. , tax(10)=0.
	read*, income

	where (income < 30000.)
	    tax = income*0.1
	elsewhere (income >= 30000 .and. income < 50000.)
	    tax = income*0.12
    elsewhere (income >= 50000.)
	    tax = income*0.15
	end where

	write(*,"(10F8.1)") tax

end


C At http://micro.ustc.edu.cn/Fortran/ZJDing/
        PROGRAM Example_1_1
        REAL a, b, av1, av2
        READ (*,*) a, b
        av1 = (a + b)/2
        av2 = sqrt(a*b)
        WRITE(*,*) av1, av2
        END


program test_eps
    implicit none
    print *, "Double precision:"
    print *, "epsilon @ 0.0d = ", epsilon(0d0)
    print *, "epsilon @ 1.0d = ", epsilon(1d0)
    print *, "tiny @ 0.0d = ", tiny(0d0)
    print *, "tiny @ 1.0d = ", tiny(1d0)
    print *, "huge @ 0.0d = ", huge(0d0)
    print *, "huge @ 1.0d = ", huge(1d0)

    print *, "Single precision:"
    print *, "epsilon @ 0.0f = ", epsilon(0e0)
    print *, "epsilon @ 1.0f = ", epsilon(1e0)
    print *, "tiny @ 0.0f = ", tiny(0e0)
    print *, "tiny @ 1.0f = ", tiny(1e0)
    print *, "huge @ 0.0f = ", huge(0e0)
    print *, "huge @ 1.0f = ", huge(1e0)
end program test_eps


*DECK BINOM
      FUNCTION BINOM (N, M)
C***BEGIN PROLOGUE  BINOM
C***PURPOSE  Compute the binomial coefficients.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1
C***TYPE      SINGLE PRECISION (BINOM-S, DBINOM-D)
C***KEYWORDS  BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNREL, R1MACH, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BINOM
      LOGICAL FIRST
      SAVE SQ2PIL, BILNMX, FINTMX, FIRST
      DATA SQ2PIL / 0.9189385332 0467274E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BINOM
      IF (FIRST) THEN
         BILNMX = LOG (R1MACH(2))
         FINTMX = 0.9/R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'BINOM',
     +   'N OR M LT ZERO', 1, 2)
      IF (N .LT. M) CALL XERMSG ('SLATEC', 'BINOM', 'N LT M', 2, 2)
C
      K = MIN (M, N-M)
      IF (K.GT.20) GO TO 30
      IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30
C
      BINOM = 1.
      IF (K.EQ.0) RETURN
C
      DO 20 I=1,K
        BINOM = BINOM * REAL(N-I+1)/I
 20   CONTINUE
C
      IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
      RETURN
C
C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM
 30   IF (K .LT. 9) CALL XERMSG ('SLATEC', 'BINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      XN = N + 1
      XK = K + 1
      XNK = N - K + 1
C
      CORR = R9LGMC(XN) - R9LGMC(XK) - R9LGMC(XNK)
      BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN)
     1  - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR
C
      IF (BINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'BINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      BINOM = EXP (BINOM)
      IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
C
      RETURN
      END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program sph
!  Evenly sample a sphere.  Supply the spacing between points as the first argument,
!  otherwise defaults to 15 degrees.  Values nearly divisible into 90 are best,
!  or small ones.

   use spherical_geometry, only: sphere_sample

   implicit none

   real(8), allocatable, dimension(:) :: lon, lat
   real(8) :: d
   integer :: i, iostat, n
   character(len=80) :: arg

   if (command_argument_count() == 1) then
      call getarg(1,arg)
      read(arg,*,iostat=iostat) d
      if (iostat /= 0) call usage
   else if (command_argument_count() == 0) then
      d = 15._8
   else
      call usage
   endif

   call sphere_sample(d, lon, lat, n)
   do i=1,n
      write(*,*) lon(i), lat(i)
   enddo

contains
   !============================================================================
   subroutine usage
   !============================================================================
      write(0,'(a)') 'Usage: sph (point spacing in degrees)', &
                     'Writes a set of evenly-spaced (lon,lat) points on a sphere to stdout'
      stop
   end subroutine usage
   !----------------------------------------------------------------------------
end program sph


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   enz :    A two-cell, one-substrate enzyme model
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION R,s,s1,s2,s0,mu,rho,kappa

       R(s)=s/(1+s+kappa*s**2)
       s1=U(1)
       s2=U(2)
       s0=PAR(1)
       mu=PAR(2)
       rho=PAR(3)
       kappa=PAR(4)

       F(1)=(s0   -s1) + (s2-s1) - rho * R(s1)
       F(2)=(s0+mu-s2) + (s1-s2) - rho * R(s2)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=0
       PAR(2)=0
       PAR(3)=100
       PAR(4)=1

       U(1)=0
       U(2)=0

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine  initialize

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     This subroutine initializes the field variable u using
c     tri-linear transfinite interpolation of the boundary values
c---------------------------------------------------------------------

      include 'header.h'

      integer c, i, j, k, m, ii, jj, kk, ix, iy, iz
      double precision  xi, eta, zeta, Pface(5,3,2), Pxi, Peta,
     >     Pzeta, temp(5)

c---------------------------------------------------------------------
c  Later (in compute_rhs) we compute 1/u for every element. A few of
c  the corner elements are not used, but it convenient (and faster)
c  to compute the whole thing with a simple loop. Make sure those
c  values are nonzero by initializing the whole thing here.
c---------------------------------------------------------------------
      do c = 1, ncells
         do kk = -1, KMAX
            do jj = -1, JMAX
               do ii = -1, IMAX
                  do m = 1, 5
                     u(m, ii, jj, kk, c) = 1.0
                  end do
               end do
            end do
         end do
      end do
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     first store the "interpolated" values everywhere on the grid
c---------------------------------------------------------------------
      do c=1, ncells
         kk = 0
         do k = cell_low(3,c), cell_high(3,c)
            zeta = dble(k) * dnzm1
            jj = 0
            do j = cell_low(2,c), cell_high(2,c)
               eta = dble(j) * dnym1
               ii = 0
               do i = cell_low(1,c), cell_high(1,c)
                  xi = dble(i) * dnxm1

                  do ix = 1, 2
                     call exact_solution(dble(ix-1), eta, zeta,
     >                    Pface(1,1,ix))
                  enddo

                  do iy = 1, 2
                     call exact_solution(xi, dble(iy-1) , zeta,
     >                    Pface(1,2,iy))
                  enddo

                  do iz = 1, 2
                     call exact_solution(xi, eta, dble(iz-1),
     >                    Pface(1,3,iz))
                  enddo

                  do m = 1, 5
                     Pxi   = xi   * Pface(m,1,2) +
     >                    (1.0d0-xi)   * Pface(m,1,1)
                     Peta  = eta  * Pface(m,2,2) +
     >                    (1.0d0-eta)  * Pface(m,2,1)
                     Pzeta = zeta * Pface(m,3,2) +
     >                    (1.0d0-zeta) * Pface(m,3,1)

                     u(m,ii,jj,kk,c) = Pxi + Peta + Pzeta -
     >                    Pxi*Peta - Pxi*Pzeta - Peta*Pzeta +
     >                    Pxi*Peta*Pzeta

                  enddo
                  ii = ii + 1
               enddo
               jj = jj + 1
            enddo
            kk = kk+1
         enddo
      enddo

c---------------------------------------------------------------------
c     now store the exact values on the boundaries
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     west face
c---------------------------------------------------------------------
      c = slice(1,1)
      ii = 0
      xi = 0.0d0
      kk = 0
      do k = cell_low(3,c), cell_high(3,c)
         zeta = dble(k) * dnzm1
         jj = 0
         do j = cell_low(2,c), cell_high(2,c)
            eta = dble(j) * dnym1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            jj = jj + 1
         enddo
         kk = kk + 1
      enddo

c---------------------------------------------------------------------
c     east face
c---------------------------------------------------------------------
      c  = slice(1,ncells)
      ii = cell_size(1,c)-1
      xi = 1.0d0
      kk = 0
      do k = cell_low(3,c), cell_high(3,c)
         zeta = dble(k) * dnzm1
         jj = 0
         do j = cell_low(2,c), cell_high(2,c)
            eta = dble(j) * dnym1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            jj = jj + 1
         enddo
         kk = kk + 1
      enddo

c---------------------------------------------------------------------
c     south face
c---------------------------------------------------------------------
      c = slice(2,1)
      jj = 0
      eta = 0.0d0
      kk = 0
      do k = cell_low(3,c), cell_high(3,c)
         zeta = dble(k) * dnzm1
         ii = 0
         do i = cell_low(1,c), cell_high(1,c)
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            ii = ii + 1
         enddo
         kk = kk + 1
      enddo

c---------------------------------------------------------------------
c     north face
c---------------------------------------------------------------------
      c = slice(2,ncells)
      jj = cell_size(2,c)-1
      eta = 1.0d0
      kk = 0
      do k = cell_low(3,c), cell_high(3,c)
         zeta = dble(k) * dnzm1
         ii = 0
         do i = cell_low(1,c), cell_high(1,c)
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            ii = ii + 1
         enddo
         kk = kk + 1
      enddo

c---------------------------------------------------------------------
c     bottom face
c---------------------------------------------------------------------
      c = slice(3,1)
      kk = 0
      zeta = 0.0d0
      jj = 0
      do j = cell_low(2,c), cell_high(2,c)
         eta = dble(j) * dnym1
         ii = 0
         do i =cell_low(1,c), cell_high(1,c)
            xi = dble(i) *dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            ii = ii + 1
         enddo
         jj = jj + 1
      enddo

c---------------------------------------------------------------------
c     top face
c---------------------------------------------------------------------
      c = slice(3,ncells)
      kk = cell_size(3,c)-1
      zeta = 1.0d0
      jj = 0
      do j = cell_low(2,c), cell_high(2,c)
         eta = dble(j) * dnym1
         ii = 0
         do i =cell_low(1,c), cell_high(1,c)
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,ii,jj,kk,c) = temp(m)
            enddo
            ii = ii + 1
         enddo
         jj = jj + 1
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine lhsinit

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      include 'header.h'

      integer i, j, k, d, c, m, n

c---------------------------------------------------------------------
c     loop over all cells
c---------------------------------------------------------------------
      do c = 1, ncells

c---------------------------------------------------------------------
c     first, initialize the start and end arrays
c---------------------------------------------------------------------
         do d = 1, 3
            if (cell_coord(d,c) .eq. 1) then
               start(d,c) = 1
            else
               start(d,c) = 0
            endif
            if (cell_coord(d,c) .eq. ncells) then
               end(d,c) = 1
            else
               end(d,c) = 0
            endif
         enddo

c---------------------------------------------------------------------
c     zero the whole left hand side for starters
c---------------------------------------------------------------------
         do k = 0, cell_size(3,c)-1
            do j = 0, cell_size(2,c)-1
               do i = 0, cell_size(1,c)-1
                  do m = 1,5
                     do n = 1, 5
                        lhsc(m,n,i,j,k,c) = 0.0d0
                     enddo
                  enddo
               enddo
            enddo
         enddo

      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine lhsabinit(lhsa, lhsb, size)
      implicit none

      integer size
      double precision lhsa(5, 5, -1:size), lhsb(5, 5, -1:size)

      integer i, m, n

c---------------------------------------------------------------------
c     next, set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
      do i = 0, size
         do m = 1, 5
            do n = 1, 5
               lhsa(m,n,i) = 0.0d0
               lhsb(m,n,i) = 0.0d0
            enddo
            lhsb(m,m,i) = 1.0d0
         enddo
      enddo

      return
      end


program toboggan
    implicit none
    integer, parameter :: w = 31
    integer, parameter :: h = 323

    integer :: x, y
    character(len = w) :: row
    integer(kind=4), dimension(h) :: slope
    integer(kind=8) :: hit

    ! parse the slope
    do y = 1, h
        read(*,*) row
        do x = 1, w
            if (row(x:x) == '#') then
                slope(y) = ibset(slope(y), x - 1)
            else
                slope(y) = ibclr(slope(y), x - 1)
            end if
        end do
    end do

    ! part 1
    hit = trees(3, 1)
    write(*,*) hit

    ! part2
    hit = trees(1, 1)
    hit = hit * trees(3, 1)
    hit = hit * trees(5, 1)
    hit = hit * trees(7, 1)
    hit = hit * trees(1, 2)
    write(*,*) hit

contains

    function trees(dx, dy)
        implicit none
        integer :: trees, dx, dy
        integer :: x, y

        x = 0
        y = 1
        trees = 0

        do while (y <= h)
            if (btest(slope(y), x)) then
                trees = trees + 1
            end if
            x = x + dx
            y = y + dy
            x = mod(x, w)
       end do
    end function

end program


	SUBROUTINE FWINDW(my_window,my_normal,window)
C
$IF ABSOFT_FORTRAN
	character *(*)	rn
	parameter	(rn='FFT FWINDOW:')
$ELSE
	parameter	rn='FFT FWINDOW:'
$ENDIF
	integer*4	my_window	!1 for Hamming, 2 for Hanning,
					!otherwise, square
	integer*4	my_normal	!1 for RMS normalized, otherwise not
	real*4		WINDOW(1024)
!
	DATA TWOPI /6.2831853/
C
	if (my_window .eq. 1) then
	    ALPHA = .54				!Hamming
	    SUMSQ = 0.
	    DO N = 1,1024
		WINDOW(N) = ALPHA + (ALPHA-1.)*COS(TWOPI*(N-1)/1024.)
		SUMSQ = SUMSQ + WINDOW(N)**2
	    ENDDO
	elseif (my_window .eq. 2) then
	    ALPHA = .5				!Hanning
	    SUMSQ = 0.
	    DO N = 1,1024
		WINDOW(N) = ALPHA + (ALPHA-1.)*COS(TWOPI*(N-1)/1024.)
		SUMSQ = SUMSQ + WINDOW(N)**2
	    ENDDO
	else
	    call w_msg_put_always(rn, 'REQUESTED WINDOW DOES NOT EXIST')
	    call w_msg_put_always2(rn,'NO WINDOWING, IWINDW=', my_window)
	    DO N = 1,1024
		WINDOW(N) = 1.
	    ENDDO
	endif

	if (my_normal .eq. 1) then
	    RMS = SQRT(SUMSQ/1024.)
	    DO N = 1,1024
		WINDOW(N) = WINDOW(N)/RMS
	    ENDDO
	endif

	RETURN
	END

      SUBROUTINE REALFT(DATA,N,ISIGN)
C
C	Calculates the Fourier Transform of a set of 2*N real-valued data
C	points.  Replaces this data (which is stored in array DATA) by the
C	positive frequency half of its complex Fourier Transform.  The real-
C	valued first and last components of the complex transform are
C	returned as DATA(1) and DATA(2) respectively.
C
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
C
C
      THETA=6.28318530717959D0/2.0D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      C1=0.5
C
C
      IF (ISIGN.EQ.1) THEN
        C2=-0.5
        CALL FOUR1(DATA,N,+1)
        DATA(2*N+1)=DATA(1)
        DATA(2*N+2)=DATA(2)
      ELSE
        C2=0.5
        THETA=-THETA
        DATA(2*N+1)=DATA(2)
        DATA(2*N+2)=0.0
        DATA(2)=0.0
      ENDIF
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      N2P3=2*N+3
      DO 11 I=1,N/2+1
        I1=2*I-1
        I2=I1+1
        I3=N2P3-I2
        I4=I3+1
        WRS=SNGL(WR)
        WIS=SNGL(WI)
        H1R=C1*(DATA(I1)+DATA(I3))
        H1I=C1*(DATA(I2)-DATA(I4))
        H2R=-C2*(DATA(I2)+DATA(I4))
        H2I=C2*(DATA(I1)-DATA(I3))
        DATA(I1)=H1R+WRS*H2R-WIS*H2I
        DATA(I2)=H1I+WRS*H2I+WIS*H2R
        DATA(I3)=H1R-WRS*H2R+WIS*H2I
        DATA(I4)=-H1I+WRS*H2I+WIS*H2R
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
11    CONTINUE
      IF (ISIGN.EQ.1) THEN
        DATA(2)=DATA(2*N+1)
      ELSE
        CALL FOUR1(DATA,N,-1)
      ENDIF
C
C
      RETURN
      END

      SUBROUTINE FOUR1(DATA,NN,ISIGN)
C
C
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
C
C
      N=2*NN
      J=1
      DO 11 I=1,N,2
        IF(J.GT.I)THEN
          TEMPR=DATA(J)
          TEMPI=DATA(J+1)
          DATA(J)=DATA(I)
          DATA(J+1)=DATA(I+1)
          DATA(I)=TEMPR
          DATA(I+1)=TEMPI
        ENDIF
        M=N/2
1       IF ((M.GE.2).AND.(J.GT.M)) THEN
          J=J-M
          M=M/2
        GO TO 1
        ENDIF
        J=J+M
11    CONTINUE
      MMAX=2
2     IF (N.GT.MMAX) THEN
        ISTEP=2*MMAX
        THETA=6.28318530717959D0/(ISIGN*MMAX)
        WPR=-2.D0*DSIN(0.5D0*THETA)**2
        WPI=DSIN(THETA)
        WR=1.D0
        WI=0.D0
        DO 13 M=1,MMAX,2
          DO 12 I=M,N,ISTEP
            J=I+MMAX
            TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
            TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
            DATA(J)=DATA(I)-TEMPR
            DATA(J+1)=DATA(I+1)-TEMPI
            DATA(I)=DATA(I)+TEMPR
            DATA(I+1)=DATA(I+1)+TEMPI
12        CONTINUE
          WTEMP=WR
          WR=WR*WPR-WI*WPI+WR
          WI=WI*WPR+WTEMP*WPI+WI
13      CONTINUE
        MMAX=ISTEP
      GO TO 2
      ENDIF
C
C
      RETURN
      END


program example
use RKHS            ! This module needs to be used by your code
implicit none

!Some variables are defined here
integer, parameter :: D = 2       ! number of dimensions
real(kind(0d0))    :: x(D)        ! coordinate array (even when D = 1, this needs to be an array)
real(kind(0d0))    :: f           ! will store the value of the model function
real(kind(0d0))    :: dfdx(D)     ! will store partial first derivatives of the model function with respect to any component of x
real(kind(0d0))    :: d2fdx2(D,D) ! will store the Hessian matrix of the model function
type(kernel)       :: K           ! The kernel type is needed to set up and evaluate a RKHS model

!for calculating only some of the partial derivatives/some entries of the Hessian
logical            :: dfdx_mask(D)
logical            :: d2fdx2_mask(D,D)

! we choose some arbitrary point at which the model function should be evaluated
x = (/1.5d0,0.5d0/)

!Below follow the 3 (or 4) steps necessary to set up and evaluate a RKHS model.
!======================================================================================================================
! 1) read training data
!======================================================================================================================
call K%read_grid("multidimensional-grid.csv")
!   Each line of the grid file must contain
!   x1 , x2 , x3 , ... , xn , f
!   where the xi are the individual coordinates and f the reference function values.
!   Further, the file needs to be sorted ascendingly in this order: x1>x2>x3>...>xn
!   For example (3 dimensions):
!
!   x1_1 , x2_1 , x3_1 , f_1_1_1
!   x1_1 , x2_1 , x3_2 , f_1_1_2
!   x1_1 , x2_1 , x3_3 , f_1_1_3
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!   x1_1 , x2_1 , x3_N3, f_1_1_N3
!   x1_1 , x2_2 , x3_1 , f_1_2_1
!   x1_1 , x2_2 , x3_2 , f_1_2_2
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!   x1_1 , x2_2 , x3_N3 , f_1_2_N3
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!     .  ,   .  ,   .  ,    .
!   x1_N1, x2_N2, x3_N3, f_N1_N2_N3
!
!   where xi_1 < xi_2 < xi_3 < ... < xi_Ni and Ni is the amount of grid points in dimension i
!   Note that the grid file MUST CONTAIN THE FULL GRID SPECIFICATION, even if data is not available
!   at some grid points (else there will be reading issues). If data is not available, place the string
!   "NaN" in the place of f for the associated grid point.
!   See also the provided grid file "multidimensional-grid.csv" as a reference!

!======================================================================================================================
! 2) choose one-dimensional kernel functions
!======================================================================================================================
call K%k1d(1)%init(EXPONENTIAL_DECAY_N3_KERNEL)   ! choose one-dimensional kernel for dimension 1
K%k1d(1)%par(1) = 2d0 !OPTIONAL: If the kernel has parameters, you can set them like this (parameters default to 1)
call K%k1d(2)%init(TAYLOR_SPLINE_N3_KERNEL)       ! choose one-dimensional kernel for dimension 2
!   For higher-dimensional kernels, this pattern is simply repeated, e.g.
!   call K%k1d(d)%init(KERNEL_TYPE) ! choose one-dimensional kernel for dimension d
!   The available KERNEL_TYPEs are:
!
!   RECIPROCAL_POWER_N2_M6_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M6_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M5_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M5_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M4_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M4_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M3_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M3_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M2_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M2_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M1_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M1_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N2_M0_KERNEL   (no parameters)
!   RECIPROCAL_POWER_N3_M0_KERNEL   (no parameters)
!   EXPONENTIAL_DECAY_N2_KERNEL     ( 1 parameter )
!   EXPONENTIAL_DECAY_N3_KERNEL     ( 1 parameter )
!   TAYLOR_SPLINE_N2_KERNEL         (no parameters)
!   TAYLOR_SPLINE_N3_KERNEL         (no parameters)
!   LAPLACIAN_KERNEL                ( 1 parameter )
!   BERNOULLI_N2_KERNEL             (no parameters)
!

!======================================================================================================================
! 3) calculate kernel coefficients
!======================================================================================================================
call K%calculate_coefficients_fast() ! once all kernels are initialized, the coefficients can be calculated (uses Tensor product)
!   ATTENTION: If the kernel matrix is ill-conditioned, the code will crash at this point and print the error message:
!
!   "Matrix M is not positive definite! If you are sure M is correct, maybe the matrix is ill conditioned.
!   Try to use the Tikhonov regularization procedure."
!
!   In that case, the fast method for calculating coefficients unfortunately is not applicable. However, it is still possible
!   to calculate the coefficients using Tikhonov regularization with:
!
!   call K%calculate_coefficients_slow(lambda)
!
!   where lambda is typically a very small value, e.g. 1d-16. If you still receive the same error message, try to increase lambda!
!
!   At this stage, the model function can already be evaluated using the slow evaluation method:
call K%evaluate_slow(x,f)
write(*,*) "Slow evaluation at point ", x, " gives ", f
!   Or, if derivatives are also desired, we just need to supply an appropriate array for storing them
call K%evaluate_slow(x,f,dfdx)
write(*,*) "Slow evaluation at point ", x, " gives derivative of f with respect to x(1): ", dfdx(1)
write(*,*) "Slow evaluation at point ", x, " gives derivative of f with respect to x(2): ", dfdx(2)
!   Or, if the Hessian is also desired, we just need to supply an appropriate array for storing them
call K%evaluate_slow(x,f,dfdx,d2fdx2)
write(*,*) "Slow evaluation at point ", x, " gives the Hessian: "
write(*,*) d2fdx2(1,:)
write(*,*) d2fdx2(2,:)

!   The fast evaluation method needs additional setup:
!======================================================================================================================
! 4) calculate lookup table for fast evaluation
!======================================================================================================================
call K%calculate_sums() ! this call will calculate the complete lookup table
!   Now, it is also possible to use the fast evaluation method:
call K%evaluate_fast(x,f)
write(*,*) "Fast evaluation at point ", x, " gives ", f
!   Or, if derivatives are also desired, we just need to supply an appropriate array for storing them
call K%evaluate_fast(x,f,dfdx)
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(1): ", dfdx(1)
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(2): ", dfdx(2)
!   Or, if the Hessian is also desired, we just need to supply an appropriate array for storing them
call K%evaluate_fast(x,f,dfdx,d2fdx2)
write(*,*) "Fast evaluation at point ", x, " gives the Hessian: "
write(*,*) d2fdx2(1,:)
write(*,*) d2fdx2(2,:)

!   Note that the results from the slow evaluation and fast evaluation method might disagree slightly due to rounding errors

!======================================================================================================================
! Although the set up is complete at this stage, there is still some useful additional functionality implemented:
!======================================================================================================================
!   At any stage of the setup, the kernel (and all data that has been calculated up to this point, e.g. coefficients,
!   lookup tables, etc.) can be saved to a binary file
call K%save_to_file("test.kernel")
!   If the kernel is not needed anymore, all associated memory can be freed with
call K%free()

!   If a kernel is available as a binary file, it can be loaded and directly evaluated without repetition of the
!   previous setup steps
call K%load_from_file("test.kernel")
call K%evaluate_fast(x,f,dfdx,d2fdx2)
write(*,*) "Fast evaluation at point ", x, " gives ", f
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(1): ", dfdx(1)
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(2): ", dfdx(2)
write(*,*) "Fast evaluation at point ", x, " gives the Hessian: "
write(*,*) d2fdx2(1,:)
write(*,*) d2fdx2(2,:)
!   This allows easy sharing of PES or models for other functions with other people: Simply send them the
!   .kernel file! It also means that e.g. in a Molecular Dynamics code, the PES can be loaded from a .kernel
!   file without the need to perform the complete setup.
!   The training data can always be recovered in human-readable format from a .kernel file:
call K%write_grid("multidimensional-grid-RECOVERED.csv")

!   Note that for efficiency reasons, it is possible to provide a "mask" when calculating
!   partial derivatives or the Hessian of the model function. In case only certain derivatives
!   or entries of the Hessian are required, only those entries are calculated, which saves
!   computational time
dfdx   = 0d0 !reset to 0
d2fdx2 = 0d0 !reset to 0
!only the derivative with respect to x(1) will be calculated
dfdx_mask        = (/.true.,.false./)
!only the diagonal entries of the Hessian will be calculated
d2fdx2_mask(1,:) = (/.true.  , .false./)
d2fdx2_mask(2,:) = (/.false. , .true. /)
call K%evaluate_fast(x,f,dfdx,d2fdx2,dfdx_mask,d2fdx2_mask)
write(*,*)
write(*,*) "Evaluation with supplied mask:"
write(*,*) "Fast evaluation at point ", x, " gives ", f
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(1): ", dfdx(1)
write(*,*) "Fast evaluation at point ", x, " gives derivative of f with respect to x(2): ", dfdx(2)
write(*,*) "Fast evaluation at point ", x, " gives the Hessian: "
write(*,*) d2fdx2(1,:)
write(*,*) d2fdx2(2,:)

! Note: masks can also be supplied in the same fashion for the slow evaluation method

call K%free() ! free resources

!======================================================================================================================
! IMPORTANT:
!======================================================================================================================
!   The RKHS module uses file unit 30 for all file i/o by default. If this causes problems with your existing code,
!   you can modify the i/o default unit. Go to the source file RKHS.f90 and search for
!   "integer, parameter :: io_unit = 30"
!   in "module file_io" (it's located at the very top of the RKHS.f90 file) and modify the file unit to whatever unit you want.
end program example


C     PROGRAM No. 5: CONSTANT STRENGTH VORTEX
C     ---------------------------------------

C     THIS PROGRAM FINDS THE PRESSURE DISTRIBUTION ON AN ARBITRARY AIRFOIL
C      BY REPRESENTING THE SURFACE AS A FINITE NUMBER OF VORTEX PANELS WITH
C      CONST. STRENGTH (NEUMANN B.C., PROGRAM BY STEVEN YON, 1989).
      REAL EP(400,2),EPT(400,2),PT1(400,2),PT2(400,2)
      REAL CO(400,2),A(400,400),B(400,400),G(400)
      REAL VEL(400),VELT(400),TH(400),DL(400)

      OPEN(8,FILE='CPV.DAT',STATUS='NEW')
      OPEN(9,FILE='AFOIL2.DAT',STATUS='OLD')

      WRITE(6,*) 'ENTER NUMBER OF PANELS'
      READ(5,*) M
      N=M+1
      WRITE(6,*) 'ENTER ANGLE OF ATTACK IN DEGREES'
      READ(5,*) ALPHA
      AL=ALPHA/57.2958

C     READ IN THE PANEL END POINTS
      DO I=1,M+1
         READ(9,*) EPT(I,1),EPT(I,2)
      END DO

C     CONVERT PANELING TO CLOCKWISE
      DO I=1,N
         EP(I,1)=EPT(N-I+1,1)
         EP(I,2)=EPT(N-I+1,2)
      END DO

C     ESTABLISH COORDINATES OF PANEL END POINTS
      DO I=1,M
         PT1(I,1)=EP(I,1)
         PT2(I,1)=EP(I+1,1)
         PT1(I,2)=EP(I,2)
         PT2(I,2)=EP(I+1,2)
      END DO

C     FIND PANEL ANGLES TH(J)
      DO I=1,M
         DZ=PT2(I,2)-PT1(I,2)
         DX=PT2(I,1)-PT1(I,1)
         TH(I)=ATAN2(DZ,DX)
      END DO

C     ESTABLISH COLLOCATION POINTS
      DO I=1,M
         CO(I,1)=(PT2(I,1)-PT1(I,1))/2+PT1(I,1)
         CO(I,2)=(PT2(I,2)-PT1(I,2))/2+PT1(I,2)
      END DO

C     ESTABLISH INFLUENCE COEFFICIENTS
      DO I=1,M
         DO J=1,M

C     CONVERT COLLOCATION POINT INTO LOCAL PANEL COORDS.
            X2T=PT2(J,1)-PT1(J,1)
            Z2T=PT2(J,2)-PT1(J,2)
            XT=CO(I,1)-PT1(J,1)
            ZT=CO(I,2)-PT1(J,2)

            X2=X2T*COS(TH(J))+Z2T*SIN(TH(J))
            Z2=0
            X=XT*COS(TH(J))+ZT*SIN(TH(J))
            Z=-XT*SIN(TH(J))+ZT*COS(TH(J))

C     SAVE PANEL LENGTHS FOR LATER USE
            IF(I.EQ.1) THEN
               DL(J)=X2
            END IF

            R1=SQRT(X**2+Z**2)
            R2=SQRT((X-X2)**2+Z**2)
            TH1=ATAN2(Z,X)
            TH2=ATAN2(Z,X-X2)

            IF(I.EQ.J) THEN
               UL=0.5
               WL=0
            ELSE
               UL=0.15916*(TH2-TH1)
               WL=0.15916*LOG(R2/R1)
            END IF

            U=UL*COS(-TH(J))+WL*SIN(-TH(J))
            W=-UL*SIN(-TH(J))+WL*COS(-TH(J))

C     A(I,J) IS THE COMPONENT OF VELOCITY NORMAL TO
C     THE AIRFOIL INDUCED BY THE JTH PANEL AT THE
C     ITH COLLOCATION POINT.
            A(I,J)=-U*SIN(TH(I))+W*COS(TH(I))
            B(I,J)=U*COS(TH(I))+W*SIN(TH(I))
         END DO

         A(I,N)=COS(AL)*SIN(TH(I))-SIN(AL)*COS(TH(I))

      END DO

C     REPLACE EQUATION M/4 WITH A KUTTA CONDITION
      DO J=I,M+1
         A(M/4,J)=0
      END DO

      A(M/4,1)=1
      A(M/4,M)=1

C     SOLVE FOR THE SOLUTION VECTOR OF VORTEX STRENGTHS

      CALL MATRX(A,N,G)

C     CONVERT SOURCE STRENGTHS INTO TANGENTIAL
C     VELOCITIES ALONG THE AIRFOIL SURFACE AND CP'S
C     ON EACH OF THE PANELS

 200   CONTINUE

      CL=0
      DO I=1,M
         TEMP=0
         DO J=1,M
            TEMP=TEMP+B(I,J)*G(J)
         END DO
         VEL(I)=TEMP+COS(AL)*COS(TH(I))+SIN(AL)*SIN(TH(I))
      CL=CL+VEL(I)*DL(I)
      END DO

      WRITE(6,*) 'SMOOTH THE VELOCITY DISTRIBUTION?'
      WRITE(6,*) '1=YES'
      WRITE(6,*) '2=NO'
      READ(5,*) ANS1

      DO I=2,M
         IF(ANS1.EQ.1) THEN
            CP=1-((VEL(I)+VEL(I-1))/2)**2
            WRITE(8,*) PT2(I-1,1),' ,',CP
         ELSE
            CP=1-VEL(I)**2
            WRITE(8,*) CO(I,1),' ,',CP
         END IF
      END DO

      WRITE(6,*) ' '
      WRITE(6,*) 'LIFT COEFFICIENT=',CL

      STOP
      END


PROGRAM ibquad
!
!     Use DOPT to find good incomplete-block designs for fitting
!     quadratic surfaces.
!
USE d_optimal_design

IMPLICIT NONE

INTEGER, PARAMETER :: maxf=6, maxb=10, maxcol=maxf*(maxf+3)/2, &
                      kmax=maxcol+maxb, nrmax=kmax*(kmax-1)/2, &
                      mxcand=3**maxf, nmax=100
INTEGER            :: nfact, nblock, blksiz(maxb), n, kin, kfull, nrbar, &
                      ncand, picked(nmax), ifault, point, i, j, ind(maxcol), &
                      pos, nrep, design(nmax), i1, i2
REAL (dp)          :: d(kmax), rbar(nrmax), lndet, xx(kmax), &
                      tol(kmax), zpz(mxcand,maxb), wk(kmax), dbest, stdet
REAL               :: x(mxcand,maxcol)
LOGICAL, PARAMETER :: rstart = .TRUE.
INTEGER, PARAMETER :: in(maxb) = (/ (0,i=1,maxb) /)
INTEGER, ALLOCATABLE :: seed(:)
CHARACTER (LEN=1)    :: bel
REAL (dp), PARAMETER :: zero = 0.0_dp

WRITE(*, *)'   +++   Incomplete blocks for quad. surfaces   +++'
bel = CHAR(7)
10 WRITE(*, *) 'Enter no. of factors: '
READ(*, *) nfact
IF (nfact > maxf .OR. nfact < 2) THEN
  WRITE(*, 900) bel
  900   FORMAT(' ', a, '** Illegal value entered **')
  GO TO 10
END IF

WRITE(*, *) 'Enter no. of blocks: '
READ(*, *) nblock
IF (nblock > maxb .OR. nblock < 0) THEN
  WRITE(*, 900) bel
  GO TO 10
END IF

WRITE(*, *)'Enter size of each block: '
READ(*, *) blksiz(1:nblock)
n = SUM( blksiz(1:nblock) )
IF (n > nmax) THEN
  WRITE(*, *) bel, '** Sorry, design is too large **'
  GO TO 10
END IF

WRITE(*, *)'How many tries?: '
READ(*, *) nrep

CALL RANDOM_SEED(size=i)
ALLOCATE( seed(i) )
WRITE(*, *)'Enter', i, ' integers for random no. seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

kin = nfact * (nfact + 3) / 2
kfull = kin + nblock
IF (n < kfull) THEN
  WRITE(*, *) bel, '** Design too small to fit model **'
  GO TO 10
END IF
nrbar = kfull * (kfull - 1) / 2
ncand = 3**nfact

!     Open a file for the output
!     Default file name:  DESIGN.OPT

OPEN(10, FILE='DESIGN.OPT')
WRITE(10, 1000) nfact
1000 FORMAT('Output from DOPT for fitting quadratic surfaces'/   &
            i2, ' factors at 2 levels')
IF (nblock .GT. 1) THEN
  WRITE(10, '(a, 10i4)') 'Block sizes: ', blksiz
ELSE
  WRITE(10, '(a, i5)') 'No. of experimental runs = ', n
END IF

!     Generate the candidate design points.
!     ind(i) stores the level (-1,0,1) of the i-th factor.

point = 1
ind(1:nfact) = -1
GO TO 55
30 i = 1
40 ind(i) = ind(i) + 1
IF (ind(i) > 1) THEN
  IF (i == nfact) GO TO 90
  ind(1:i) = -1
  i = i + 1
  GO TO 40
END IF
!
!     Calculate row of X.
!
55 x(point,1:nfact) = ind(1:nfact)
pos = nfact + 1
DO i = 1, nfact
  DO j = 1, i
    x(point,pos) = ind(i) * ind(j)
    pos = pos + 1
  END DO
END DO
point = point + 1
GO TO 30

90 dbest = zero
DO i = 1, nrep
  CALL dopt(x, mxcand, ncand, kin, n, nblock, in, blksiz, kfull, &
            rstart, nrbar, d, rbar, picked, lndet, xx, tol, zpz, wk, &
  ifault)
  IF (ifault /= 0) THEN
    WRITE(*, *) bel, 'IFAULT = ', ifault
    ELSE
    WRITE(*, *) i, ' Log Det. = ', lndet
  END IF
  IF (lndet > dbest) THEN
    design(1:n) = picked(1:n)
    dbest = lndet
  END IF
END DO

WRITE(*, *)
stdet = EXP(dbest - kfull*LOG(REAL(n, KIND=dp)))
WRITE(*, *) 'Max. log det. = ', dbest, '   Std. det = ', stdet
WRITE(*, *) 'Design:'
WRITE(10, *) 'Max. log det. = ', dbest, '   Std. det = ', stdet
WRITE(10, *) 'Design:'
i2 = 0
DO i = 1, nblock
  i1 = i2 + 1
  i2 = i2 + blksiz(i)
  WRITE(*, 960) i, (j, j=1,nfact)
  WRITE(10, 960) i, (j, j=1,nfact)
  960 FORMAT(' BLOCK', i5 / t15, 'F A C T O R' / '   ', 15I5)
  DO j = i1, i2
    WRITE(*, 970) x(design(j), 1:nfact)
    WRITE(10, 970) x(design(j), 1:nfact)
    970 FORMAT('    ', 15F5.0)
  END DO
END DO
WRITE(*, *)
GO TO 10

STOP
END PROGRAM ibquad


(* Bit array for compact noting of precence or on/off state

   The origimal idea of this is from Albert Nijhof,
   this implementation (c) 2021 Willem Ouwerkerk.
   This code assumes that the dataspace is reserved & addressed in
   words. To keep track of 64 entries one only needs 8 bytes.

This variant which calculates the sizes from a system value!
With out of bounds detection for this version.

Note that: The defining word BITARRAY has two entries. The first line
   is for a forth system with seprate SRAM, the second for a RAM only system.

\ Word version of bit set, bit clear & bit test instructions
: **BIS  ( mask addr -- )       tuck @ or  swap ! ;
: **BIC  ( mask addr -- )       >r  invert  r@ @ and  r> ! ;
: BIT**  ( mask addr -- 0|b )   @ and ;

: @+     ( a1 -- a2 x )         dup cell+  swap @ ;

*)

hex
8 cells  constant #BITS \ Bits in a cell
: >LEN      ( a1 -- #n )    @ #bits * ; \ Length in bits of bit array a1
: >ADR      ( a1 -- a2 )    cell+ @ ;   \ Start address of bit array a1

: LOC           ( nr a1 -- bit a2 )     \ Bit location in word-addr
    2dup >len < 0= ?abort   \ Valid bit flag check
    @+ 1- >r  @             \ nr adr
    >r  dup #bits 1- and    \ nr bit-nr
    1 swap lshift           \ nr bit-mask
    swap #bits /            \ nr / bits in a cell
    r> swap  r> and cells + ; \ Mask excess bits, leave bit-array offset
                            \ Leave bit & word-adr
: BITARRAY
    create      ( +n "name"-- )  ( exec: -- a )
        #bits /mod                  \ Calculate length in cells & remainder
        swap if 1+ then  dup ,      \ Round length to the next cell
        here , cells allot ;        \ Save RAM pointer, reserve RAM in ROM Forth
\       here cell+ , cells allot ;  \ Save pointer, reserve RAM in RAM Forth

: *SET      ( nr a -- )       loc **bis ; \ Set bit nr in array a
: *CLR      ( nr a -- )       loc **bic ; \ Erase bit nr from array a
: GET*      ( nr a -- 0|msk ) loc bit** ; \ Bit nr set in array a?
: ZERO      ( a -- )          dup >adr  swap >len 8 /  0 fill ; \ Erase bit-map a

\ Additional routines:
\ COPY any bit array to another, use the length of the shortest array!
: COPY      ( a1 a2 -- )    \ Copy array a1 to array a2
    dup zero  >r            \ Erase target array a2
    dup >adr  swap >len     \ Get address & length of origin array
    r@ >len  min  8 /       \ Use shortest length in bytes
    r> >adr  swap move ;    \ Move to destination array

\ Leave number of bits set in bit array a
: COUNT*    ( a -- +n )     \ Counted noted high bits
    0  over >len 0 ?do
        over i swap get*    \ Bits present?
        if  1+  then        \ Add 1 when found
    loop  nip ;

\ Leave the number of the first used item in bit array a on the stack and erase it!
: UP?       ( a -- false | nr true )
    dup >len 0 ?do              \ Test all bits
        i over get* if          \ Bit set?
            i swap *clr         \ Yes clear bit
            i true unloop exit  \ Leave bit-nr & true, ready
        then
    loop  drop  false ;         \ Nothing found

\ An example:

40 bitarray BITMAP  \ Demo bit arrays
13 bitarray SIGNALS \ Note that this one is rounded to one cell (32 bits)
                    \ or two cells on a system with 16-bit cells.

BITMAP zero         \ Clear whole bit array
3 BITMAP *set       \ Set bit 3, 11, 24 & 33
11 BITMAP *set
1F BITMAP *set
24 BITMAP *set
33 BITMAP *set

3 BITMAP *clr       \ Clear bit 3
11 BITMAP get* .    \ Leave status of bit 11 & 3
3 BITMAP get* .

BITMAP SIGNALS copy \ Copy BITMAP to SIGNALS

: .BITARRAY ( a -- )    \ Show whole contents of bit array a
    cr  dup >len 0 do
        i 8 mod 0= if  cr  then
        i 2 .r space   i over get*
        if ." Set" else ." -- " then
        space space
    loop  drop ;

: SHOW      ( a -- )  \ Display the contents of bit array a & empty it
    dup count*
    ?dup 0= if drop ." bit array empty " exit then
    2 .r ."  bit flags set "  cr        \ Used, show how many bits
    dup .bitarray
    cr  ." Used bits "                  \ Show & consume only
    dup >len 0 do
        dup up? if  .  then             \ the bits set in array a
    loop  drop ;

\ End ;;;

Data-Structures/Bit-Array/noForth/Bit array (generalised) v0.2.f


      program Day1
c        declarations
         integer count,values(10000),value,sum,twoProduct,threeProduct

c        read input file
         open(1,FILE='input.txt',STATUS='OLD')
         do
            read(1,*,IOSTAT=io) value
            if (io.gt.0) then
               write(*,*) 'Error'
               exit
            else if(io.lt.0) then
               exit
            else
               values(count+1) = value
               count = count+1
            endif
         enddo
         close(1)

         twoProduct =-1
         threeProduct =-1

c        search values to find two values that sum to 2020
         do 200 i=1,count
            do 300 j=i+1,count
               sum = values(i)+values(j)
               write(*,*) i,values(i),j,values(j)
               if(sum.eq.2020) then
c                 compute twoProduct
                  twoProduct = values(i)*values(j)
                  goto 400
               endif
300        continue
200      continue

c        search the values to find three values that sum to 2020
400      do 500 i=1,count
            if (values(i).lt.2020) then
               do 600 j=i+1,count
                  sum = values(i)+values(j)
                  if(sum.lt.2020) then
                     do 700 k=j+1,count
                        sum = values(i)+values(j)+values(k)
                        write(*,*) i,values(i),j,values(j),k,values(k)
                        if(sum.eq.2020) then
c                          compute twoProduct
                           threeProduct = values(i)*values(j)*values(k)
                           goto 900
                        endif
700                 continue
                  endif
600            continue
            endif
500      continue

900      write(*,*) 'Two Product: ',twoProduct
         write(*,*) 'Three Product: ',threeProduct

         end


      PROGRAM xlinbcg
C     driver for routine linbcg
      INTEGER NP,NMAX,ITOL,ITMAX
      DOUBLE PRECISION TOL
      PARAMETER (NP=20,NMAX=1000,ITOL=1,TOL=1.d-9,ITMAX=75)
      INTEGER i,iter,ija
      DOUBLE PRECISION b(NP),x(NP),bcmp(NP),sa,err
      COMMON /mat/ sa(NMAX),ija(NMAX)
      do 11 i=1,NP
        x(i)=0.d0
        b(i)=1.d0
11    continue
      b(1)=3.d0
      b(NP)=-1.d0
      call linbcg(NP,b,x,ITOL,TOL,ITMAX,iter,err)
      write(*,'(/1x,a,e15.6)') 'Estimated error:',err
      write(*,'(/1x,a,i6)') 'Iterations needed:',iter
      write(*,'(/1x,a)') 'Solution vector:'
      write(*,'(1x,5f12.6)') (x(i),i=1,NP)
      call dsprsax(sa,ija,x,bcmp,NP)
C     this is a double precision version of sprsax
      write(*,'(/1x,a)') 'press RETURN to continue...'
      read(*,*)
      write(*,'(1x,a/t8,a,t22,a)') 'Test of solution vector:','a*x','b'
      do 12 i=1,NP
        write(*,'(1x,2f12.6)') bcmp(i),b(i)
12    continue
      END
      BLOCK DATA
      INTEGER NMAX
      PARAMETER(NMAX=1000)
      DOUBLE PRECISION sa
      INTEGER ija
      COMMON /mat/ sa(NMAX),ija(NMAX)
C     logical length = 59
      DATA sa/3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,
     *     3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,3.d0,
     *     3.d0,3.d0,3.d0,3.d0,0.d0,2.d0,-2.d0,2.d0,
     *     -2.d0,2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,
     *     2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,
     *     2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,2.d0,
     *     -2.d0,2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,
     *     2.d0,-2.d0,2.d0,-2.d0,2.d0,-2.d0,941*0.d0/
      DATA ija/22,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,
     *     55,57,59,60,2,1,3,2,4,3,5,4,6,5,7,6,8,7,9,8,10,9,11,10,
     *     12,11,13,12,14,13,15,14,16,15,17,16,18,17,19,18,20,19,941*0/
      END

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


	SUBROUTINE RS_NUMD  ( line, numb, defalt, nout, iret )
C************************************************************************
C* RS_NUMD								*
C*									*
C* This subroutine reads a character substring (which must contain 	*
C* nothing but digits and slashes) and returns the integer		*
C* represented by that substring.  If the string contains nothing but	*
C* slashes, the subroutine returns DEFALT.  If embedded slashes are 	*
C* encountered, they are treated as zeroes.				*
C*									*
C* RS_NUMD  ( LINE, NUMB, DEFALT, NOUT, IRET )				*
C*									*
C* Input parameters:							*
C*	LINE		CHAR*		Substring			*
C*	NUMB		INTEGER		Number of characters to read	*
C*	DEFALT		INTEGER		Default value for numb		*
C*									*
C* Output parameters:							*
C*	NOUT		INTEGER		Returned integer		*
C*	IRET		INTEGER		Return status			*
C*					  0 = Successful completion	*
C*					 -1 = Unexpected chars found	*
C*					  1 = Needed to use defalt	*
C**									*
C* Log:									*
C* J. Nielsen/MIT	10/86						*
C* J. Nielsen/MIT	 2/89						*
C* F. Cuq/UCLA		 8/90	Integer*2 -> integer*4			*
C* J. Nielsen/TAMU	 2/92	Gempacized				*
C* S. Jacobs/NMC	 9/95	Fixed format I to I1 			*
C* T. Lee/GSC		 9/97	Fixed typo, DEFAULT -> DEFALT		*
C************************************************************************
	CHARACTER*(*)	line
	INTEGER		numb, defalt
C*
	INTEGER		nout, iret
C*
	INTEGER		tento, defcnt
C------------------------------------------------------------------------`
	defcnt = 0
	nout = 0
	tento = 1
C
C*	Work backwards from last digit
C
	DO  j = numb, 1, -1
	    IF  ( line ( j:j) .ne. '/' )  THEN
C
C*		Read digit, add to nout
C
		READ ( line ( j:j ), '(I1)', ERR=1000 ) idigit
		nout = nout + idigit*tento
	    ELSE
C
C*		Found slash; do not increment NOUT
C
		defcnt = defcnt + 1
	    ENDIF
C
	    tento = tento * 10
	END DO
C
C*	See if we have found nothing but slashes
C
	IF  ( defcnt .eq. numb )  THEN
	    nout = defalt
	    iret = 1
	ELSE
C
C*	Normal successful completion
C
	    iret = 0
	ENDIF
	RETURN
C
C*	Here if found a non-integer, non-slash in substring
C
1000	nout = defalt
	iret = -1
	RETURN
	END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program gcp_from_point_azi_prog
!===============================================================================
! Wrapper program for sg_gcp_from_point_azi.  Given a point on a sphere and an
! azimuth through that point, return the pole to the great circle along that
! azimuth.  Reads lon, lat and azi from stdin, all in degrees

   use spherical_geometry, only: sg_gcp_from_point_azi

   implicit none

   real(8) :: lon,lat,azi,long,latg
   integer :: iostat

   if (command_argument_count() /= 0) call usage

   iostat = 0
   do while (iostat == 0)
      read(*,*,iostat=iostat) lon,lat,azi
      if (iostat > 0) then
         write(0,'(a)') 'gcp_from_point_azi: Error: problem reading lon,lat,azi (degrees) from stdin'
         stop
      endif
      if (iostat < 0) exit
      call sg_gcp_from_point_azi(lon,lat,azi,long,latg,degrees=.true.)
      write(*,'(f11.6,1x,f10.6)') long,latg
   enddo

contains
   !============================================================================
   subroutine usage()
   !============================================================================
      implicit none
      write(0,'(a)') 'Usage: gcp_from_point_azi < [lon] [lat] [azi]',&
                     '   Reads point on sphere and azimuth from stdin (degrees)',&
                     '   Writes lon and lat of pole to great circle defined by the input to stdout.'
      stop
   end subroutine usage
   !----------------------------------------------------------------------------

end program gcp_from_point_azi_prog
!-------------------------------------------------------------------------------


      implicit real *8 (a-h,o-z)
      integer ntests,nsuccess
      complex *16 zk,ima

      data ima/(0.0d0,1.0d0)/

      done = 1
      pi = atan(done)*4

      zk = 300.0d0
      call test_helm_zkbig(zk,i1)

      zk = 300.0d0*ima
      call test_helm_zkbig(zk,i2)

      zk = 12*pi*ima*4
      call test_helm_zkbig(zk,i3)

      zk = 12*pi*ima/32

      call test_helm_zkbig(zk,i4)

      zk = 12*pi*ima + 0.01d0
      call test_helm_zkbig(zk,i5)

      zk = (12*pi*ima + 12*pi)/10
      call test_helm_zkbig(zk,i6)

      nsuccess = i1+i2+i3+i4+i5+i6
      ntest = 6
      open(unit=33,file='print_testres.txt',access='append')
      write(33,'(a,i1,a,i1,a)') 'Successfully completed ', nsuccess,
     1   ' out of ', ntest, ' in hfmm3d zkbig testing suite'

      stop
      end

      subroutine test_helm_zkbig(zk,isuccess)

      implicit none
      integer ns
      double precision, allocatable :: source(:,:)
      double complex, allocatable :: charge(:),dipvec(:,:)
      double complex, allocatable :: pot(:),potex(:)
      double complex, allocatable :: grad(:,:),gradex(:,:)

      double precision eps
      double complex eye,zk
      integer i,j,k,ntest
      double precision hkrand,thresh,erra,ra
      integer isuccess

      data eye/(0.0d0,1.0d0)/

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      write(*,*)
      write(*,*)

      ns = 10000

      allocate(source(3,ns))
      allocate(charge(ns))
      allocate(dipvec(3,ns))
      allocate(pot(ns))
      allocate(grad(3,ns))

      eps = 0.51d-3

c
c
c       example demonstrating use of
c        source to source, charges, pot + gradient
c

c
cc      generate sources with distribution unif^2
c
c
      do i=1,ns
        source(1,i) = hkrand(0)**2
        source(2,i) = hkrand(0)**2
        source(3,i) = hkrand(0)**2

        charge(i) = hkrand(0) + eye*hkrand(0)
        dipvec(1,i) = hkrand(0) + eye*hkrand(0)
        dipvec(2,i) = hkrand(0) + eye*hkrand(0)
        dipvec(3,i) = hkrand(0) + eye*hkrand(0)

        pot(i) = 0
        grad(1,i) = 0
        grad(2,i) = 0
        grad(3,i) = 0
      enddo

      call hfmm3d_s_c_g(eps,zk,ns,source,charge,
     1      pot,grad)
      ntest = 10
      allocate(potex(ntest),gradex(3,ntest))

      thresh = 2.0d0**(-51)

      do i=1,ntest
        potex(i) = 0
        gradex(1,i) = 0
        gradex(2,i) = 0
        gradex(3,i) = 0
      enddo

      call h3ddirectcg(1,zk,source,charge,ns,source,
     1  ntest,potex,gradex,thresh)

      erra = 0
      ra = 0
      do i=1,ntest
        erra = erra + abs(potex(i)-pot(i))**2
        erra = erra + abs(gradex(1,i)-grad(1,i))**2
        erra = erra + abs(gradex(2,i)-grad(2,i))**2
        erra = erra + abs(gradex(3,i)-grad(3,i))**2

        ra = ra + abs(potex(i))**2
        ra = ra + abs(gradex(1,i))**2 + abs(gradex(2,i))**2 +
     1   abs(gradex(3,i))**2
      enddo

      erra = sqrt(erra/ra)

      call prin2('zk=*',zk,1)
      call prin2('l2 rel err=*',erra,1)

      isuccess = 0

      if(erra.lt.eps) isuccess = 1

      return
      end
c----------------------------------------------------------
c
cc
c
c


! compile using : gfortran fftw2d.f90 ETDRK4.f90 main.f90 -lfftw3 -o run -O3
program run
	use FFTW2d
	use ETDRK4
	implicit none

	integer :: i, j, k, simmode
	real (kind = 8) :: m

	m = 20.0d0
	! example for Kuramoto-Sivashinsky equation (KSE)
	call initETDRK4( 0.1d0, m * 2.0d0 * PI, m * 2.0d0 * PI, 256, 256, 'KSE', [0.0d0] )
	! example for Nikolaevskiy equation (NE)
	!call initETDRK4( 0.02d0, m * 2.0d0 * PI, m * 2.0d0 * PI, 256, 256, 'NE', [0.0d0, 0.1d0] )

	real_data = 0.0d0
	freq_data = 0.0d0

	call perturbation(0.1d0, 2411)
	do i = 1, 600
		call step( 10, .true. )

		call snapshot(real_data, 0)
		call snapshot(real_data, i)
		!call snapshot(idfft(2*nx, 2*ny, upscaledfield( freq_data, 2 )), i)

		write(*,*) i, time
	end do

	call ETDRK4_free()
end program


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.01/07                           *
C  *    TEST TITLE : Composition of a matrix with a        *
C  *                 transformation                        *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      REAL      ACT4X4(4,4), ACT3X3(3,3), EXP4X4(4,4), EXP3X3(3,3)
      REAL      A4(4,4), A3(3,3)
      REAL      X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ
      LOGICAL   TRNSEQ

      CALL INITGL ('06.01.01/07')

C open PHIGS
      CALL XPOPPH  (ERRFIL, MEMUN)

      CALL SETMSG ('1 2 17', '<Compose transformation matrix 3> '  //
     1             'should generate a matrix which is the '        //
     2             'composition of the specified matrix with the ' //
     3             'specified 3D transformation.')

C set up specified matrix
      A4(1,1) = -2.2
      A4(1,2) = 3.3
      A4(1,3) = 4.4
      A4(1,4) = 5.5
      A4(2,1) = 0.0023
      A4(2,2) = -727.12
      A4(2,3) = 2.09
      A4(2,4) = 33.33
      A4(3,1) = 0
      A4(3,2) = 34
      A4(3,3) = 54.1
      A4(3,4) = -0.045
      A4(4,1) = 7
      A4(4,2) = 6
      A4(4,3) = 5
      A4(4,4) = 4

C Set up transform parameters:
C   set fixed point
      X0 = -1.12
      Y0 = 2.23
      Z0 = 3.34
C   set shift vector
      DX = 6.7
      DY = 8.9
      DZ = 10.11
C   set rotation angle
      PHIX = 7.6
      PHIY = -5.4
      PHIZ = 3.2
C   set scale factors
      FX = 0.0023
      FY = -636.34
      FZ = 2.2

C <Compose transformation matrix 3> returns act4x4 = actual array
      CALL PCOTM3 (A4, X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1             ERRIND, ACT4X4)
      CALL CHKINQ ('pcotm3', ERRIND)

C Compute exp4x4 = expected array
      CALL ECOTM3 (A4, X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1             EXP4X4)
      CALL IFPF ( TRNSEQ (4, ACT4X4, EXP4X4))

      CALL SETMSG ('1 2 18', '<Compose transformation matrix> '    //
     1             'should generate a matrix which is the '        //
     2             'composition of the specified matrix with the ' //
     3             'specified 2D transformation.')

C set up specified matrix
      A3(1,1) = -2.2
      A3(1,2) = 3.3
      A3(1,3) = 5.5
      A3(2,1) = 0.0023
      A3(2,2) = -727.12
      A3(2,3) = 33.33
      A3(3,1) = 0
      A3(3,2) = 34
      A3(3,3) = -0.045

C Set up parameters:
C   set fixed point
      X0 = -1.12
      Y0 = 2.23
C   set shift vector
      DX = 6.7
      DY = 10.11
C   set rotation angle
      PHIZ = -5.4
C   set scale factors
      FX = 0.0023
      FY = -636.34

C <Compose transformation matrix> returns act3x3 = actual array
      CALL PCOTM  (A3, X0,Y0, DX,DY, PHIZ, FX,FY, ERRIND, ACT3X3)
      CALL CHKINQ ('pcotm', ERRIND)

C Compute exp3x3 = expected array
      CALL ECOTM  (A3, X0,Y0, DX,DY, PHIZ, FX,FY, EXP3X3)
      CALL IFPF ( TRNSEQ (3, ACT3X3, EXP3X3))

      CALL ENDIT
      END


c
c ---------------------------------------------------------------------
c
       subroutine qslopes(qca,qpt,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                    lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,
     &                    iir,jjr,istage)

      use amr_module

      implicit double precision(a-h,o-z)
      include "cuserdt.i"

!    qca is for cell average
!    qpt is pointwise vals

      dimension qca(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &          qy(nvar,mitot,mjtot),irr(mitot,mjtot)
      dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
      dimension qxy(nvar,mitot,mjtot)
      dimension qpt(nvar,mitot,mjtot)
      dimension iir(mitot,mjtot),jjr(mitot,mjtot)
      logical ag, orig

      ! driver routine to call the correct gradient routine

      ! first call slope routines for regular cells
      ag = .false.
      orig = .false.
      if (ag) then
         call reg_slopes2(qca,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)
      else if (orig) then
         call reg_slopes(qca,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)
      else ! higher order
         call reg_slopes3(qca,qpt,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)
      endif

      ! (use for both cell gradients and merge nhood gradients)
      ! igradChoice =
      !  0 = no gradient
      !  1 = first order accurate gradients  (2 terms in least squares)
      !  2 = pointwise quadratic gradients (5 terms in least squares)
      !  3 = cellwise average  quadratic gradients (5 terms in least squares)
      !  4 = cellwise average  quads using Andrews iir approach

      if (igradChoice .eq. 1 .or. igradChoice .eq. 2) then
         call qslopesPtQuad2(qca,qx,qy,mitot,mjtot,irr,lstgrd,lwidth,
     &                       hx,hy,xlow,ylow,mptr,nvar)
      else if (igradChoice .eq. 3) then
         call qslopesCellAvgQuad(qca,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                       lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,
     &                       istage)
      else if (igradChoice .eq. 4) then
         call qslopesQuadWithIIR(qca,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                       lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,
     &                       iir,jjr,istage)
      else if (igradChoice .eq. 5) then
         call qslopes3(qca,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                       lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,
     &                       iir,jjr,istage)
      endif

      if (limitTile .eq. 1) then ! BJ limiter
          call limitCellBJ(qca,qx,qy,mitot,mjtot,irr,nvar,hx,hy,
     &                     lwidth,lstgrd,xlow,ylow)
      endif

      return
      end


subroutine bsel(n, vp, rcut, dimcouples)

    implicit none
    integer*4, intent(in)                  :: n
    real*8,    intent(in)                  :: rcut
    real*8,    intent(in) , dimension(n,3) :: vp
    integer*8, intent(out)                 :: dimcouples

    integer*4                              :: i,j
    real*8                                 :: xi,yi,zi,xj,yj,zj,dx,dy,dz,mdl
    real*8                                 :: rcutsq

    rcutsq = rcut*rcut

    do i = 1, (n - 1)
        xi = vp(i,1)
        yi = vp(i,2)
        zi = vp(i,3)

        do j = 1, n
            if (i >= j) cycle

            xj = vp(j,1)
            yj = vp(j,2)
            zj = vp(j,3)

            dx = abs(xj - xi)
            dy = abs(yj - yi)
            dz = abs(zj - zi)

            mdl = dx*dx + dy*dy + dz*dz
            !mdl = int(mdl * 10.0**3) / 10.0**3

            if (mdl > rcutsq) then
                cycle
            else
                dimcouples = dimcouples + 1
            end if
        end do
    end do

    print *,"Bonds detected in the specified cutoff:",dimcouples

    return
end subroutine bsel


program test_amr

use tt_lib
use ttop_lib
use ttio_lib
use python_conv_lib
use tt_adapt_als

! d,n,m,ry,ra,crA, crY, crX0, rx, eps, kickrank, nswp, verb, prec, nrestart, niters
integer :: d
integer, allocatable :: n(:),m(:),ry(:),ra(:), rx(:), ps(:), na(:), psa(:)
integer :: kickrank, nswp, verb, nrestart, niters
! verb: 0: off; 1: matlab; 2: console
character :: prec ! 'n', 'l', 'r', 'c'
real(8),allocatable :: crA(:), crb(:)

type(dtt) :: tt_A, tt_b

call dtt_read(tt_A,'A.sdv')
call dtt_read(tt_b,'b.sdv')

d = tt_A%m-tt_A%l+1

!call svd(tt_A,1d-6)
allocate(n(d),na(d),m(d),ry(d+1),ra(d+1),rx(d+1),ps(d+1),psa(d+1))

 call dsdv_to_arrays(na,ra,d,psa,crA,tt_A)
!print *,na(1:d)
call dsdv_to_arrays(n,rx,d,ps,crb,tt_b)

call dealloc(tt_A)
call dealloc(tt_b)
ry(1:d+1) = rx(1:d+1)
call tt_amr_solve(d,n,n,ry,ra,crA, crb, crb, rx, 1d-6)

! deallocate (crA, crb)

end program