c     program DRSBACC
c>> 1996-05-28 DRSBACC  Krogh Moved formats up.
c>> 1994-10-19 DRSBACC  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSBACC  Lawson  Initial Code.
c--S replaces "?": DR?BACC, ?BACC, ?BSOL
c     Demonstration driver for SBACC & SBSOL
c     C. L. Lawson & S. Y. Chiu, JPL, July 1987, Sept 1987.
c     ------------------------------------------------------------------
      integer NX, LDG, NB, ISCALE
      integer I, IERR2, IERR3, IG, IR, J, JT, JTPREV, MT, MTOTAL
      parameter(NX = 10, LDG = 24, NB = 2, ISCALE = 6)
      real             XTAB(NX), G(LDG,3), YFIT(NX), C(NX,NX)
      real             DELX, DOF, DTOR, RDUMMY, RNORM, SIGFAC, VFAC
      real             X, YF, YTRUE
      real             ZERO, XINC, XLIMIT
      real             ONE, C45, HALF
      parameter(ZERO = 0.0E0, XINC = 1.0E0, XLIMIT = 89.5E0)
      parameter(ONE = 1.0E0, C45 = 45.0E0, HALF = 0.5E0)
      data XTAB / 00.0E0, 10.0E0, 20.0E0, 30.0E0, 40.0E0,
     *            50.0E0, 60.0E0, 70.0E0, 80.0E0, 90.0E0 /
c
 1000 format(' Calling SBACC with JT =',i3,', MT =',i3)
 1003 format(1x/'     X       Y        YFIT   R=Y-YFIT'/1X)
 1004 format(1X, F6.1, 3F10.5)
 1006 format(1X,10(F7.2,1X))
c     ------------------------------------------------------------------
      write(*,'(1x,a//1x,a/1x,a/1x)')
     *'        Demonstration driver for SBACC and SBSOL.',
     *'Compute least-squares fit of a continuous piecewise linear',
     *'     function to the sine function on 0 to 90 degrees.'
      DTOR = atan(ONE)/C45
      MTOTAL = 0
      IR = 1
      MT = 0
      JT = 1
      IG = 0
      X = -XINC
      DELX = XTAB(JT+1) - XTAB(JT)
c
   20 if( X .lt. XLIMIT)then
         X = X + XINC
         MTOTAL = MTOTAL + 1
      if(X .gt. XTAB(JT+1))then
            write(*,1000) JT, MT
            call SBACC(G,LDG,NB,IR,MT,JT,JTPREV, IERR2)
            IG = IR-1
            MT = 0
            JT = min(JT+1, NX-1)
            DELX = XTAB(JT+1) - XTAB(JT)
      end if
         IG = IG + 1
         MT = MT + 1
         G(IG,1) = (XTAB(JT+1) - X) / DELX
         G(IG,2) = (X - XTAB(JT)) / DELX
         G(IG,3) = sin(x * DTOR)
      go to 20
      end if

      if(MT .gt. 0)then
         write(*,1000) JT, MT
         call SBACC(G,LDG,NB,IR,MT,JT,JTPREV, IERR2)
      end if

      call SBSOL(1,G,LDG,NB,IR,JTPREV,YFIT,NX,RNORM, IERR3)
c                       The following statement does a type conversion.
      DOF = MTOTAL - NX
      SIGFAC = RNORM / SQRT(DOF)
      write(*,'(1x/1x, a, i4, a, f10.5, a, f10.5)')
     *  'MTOTAL =', MTOTAL, ',  RNORM =', RNORM, ',  SIGFAC =', SIGFAC
      write(*,1003)
      do 30 I=1,NX
         YTRUE = sin(XTAB(I)*DTOR)
         write(*,1004) XTAB(I),YTRUE,YFIT(I),YFIT(I) - YTRUE
      if( I .ne. NX)then
            X = HALF*(XTAB(I+1) + XTAB(I))
            YF = HALF*(YFIT(I+1) + YFIT(I))
            YTRUE = sin(X*DTOR)
            write(*,1004) X,YTRUE,YF,YF - YTRUE
      end if
   30 continue
c
c     Compute unscaled covariance matrix in C(,).
c
      do 50 J = 1,NX
        do 40 I = 1,NX
            C(I,J) = ZERO
   40   continue
        C(J,J) = ONE
        call SBSOL(2,G,LDG,NB,IR,JTPREV,C(1,J),NX,RDUMMY,IERR3)
        call SBSOL(3,G,LDG,NB,IR,JTPREV,C(1,J),NX,RDUMMY,IERR3)
   50 continue
c
      write(*,'(1x/10x,a,i1/1x)')
     *  'Covariance matrix scaled up by 10**',ISCALE
c
      VFAC = (10**ISCALE) * SIGFAC**2
      do 60 I = 1,NX
        print 1006,(VFAC*C(I,J),J=1,NX)
   60 continue
c
      stop
      end


! RUN: %S/test_folding.sh %s %t %flang_fc1
! REQUIRES: shell
! Tests reduction intrinsic function folding
module m
  implicit none
  integer, parameter :: intmatrix(*,*) = reshape([1, 2, 3, 4, 5, 6], [2, 3])
  logical, parameter :: odds(2,3) = mod(intmatrix, 2) == 1
  character(*), parameter :: chmatrix(*,*) = reshape(['abc', 'def', 'ghi', 'jkl', 'mno', 'pqr'], [2, 3])

  logical, parameter :: test_allidentity = all([Logical::])
  logical, parameter :: test_all = .not. all(odds)
  logical, parameter :: test_alldim1 = all(.not. all(odds,1))
  logical, parameter :: test_alldim2 = all(all(odds,2) .eqv. [.true., .false.])
  logical, parameter :: test_anyidentity = .not. any([Logical::])
  logical, parameter :: test_any = any(odds)
  logical, parameter :: test_anydim1 = all(any(odds,1))
  logical, parameter :: test_anydim2 = all(any(odds,2) .eqv. [.true., .false.])

  logical, parameter :: test_iallidentity = iall([integer::]) == -1
  logical, parameter :: test_iall = iall(intmatrix) == 0
  logical, parameter :: test_iall_masked = iall(intmatrix,odds) == 1
  logical, parameter :: test_ialldim1 = all(iall(intmatrix,dim=1) == [0, 0, 4])
  logical, parameter :: test_ialldim2 = all(iall(intmatrix,dim=2) == [1, 0])
  logical, parameter :: test_ianyidentity = iany([integer::]) == 0
  logical, parameter :: test_iany = iany(intmatrix) == 7
  logical, parameter :: test_iany_masked = iany(intmatrix,odds) == 7
  logical, parameter :: test_ianydim1 = all(iany(intmatrix,dim=1) == [3, 7, 7])
  logical, parameter :: test_ianydim2 = all(iany(intmatrix,dim=2) == [7, 6])
  logical, parameter :: test_iparityidentity = iparity([integer::]) == 0
  logical, parameter :: test_iparity = iparity(intmatrix) == 7
  logical, parameter :: test_iparity_masked = iparity(intmatrix,odds) == 7
  logical, parameter :: test_iparitydim1 = all(iparity(intmatrix,dim=1) == [3, 7, 3])
  logical, parameter :: test_iparitydim2 = all(iparity(intmatrix,dim=2) == [7, 0])

  logical, parameter :: test_imaxidentity = maxval([integer::]) == -huge(0) - 1
  logical, parameter :: test_iminidentity = minval([integer::]) == huge(0)
  logical, parameter :: test_imaxval = maxval(intmatrix) == 6
  logical, parameter :: test_iminval = minval(intmatrix) == 1
  logical, parameter :: test_imaxval_masked = maxval(intmatrix,odds) == 5
  logical, parameter :: test_iminval_masked = minval(intmatrix,.not.odds) == 2
  logical, parameter :: test_rmaxidentity = maxval([real::]) == -huge(0.0)
  logical, parameter :: test_rminidentity = minval([real::]) == huge(0.0)
  logical, parameter :: test_rmaxval = maxval(real(intmatrix)) == 6.0
  logical, parameter :: test_rminval = minval(real(intmatrix)) == 1.0
  logical, parameter :: test_rmaxval_scalar_mask = maxval(real(intmatrix), .true.) == 6.0
  logical, parameter :: test_rminval_scalar_mask = minval(real(intmatrix), .false.) == huge(0.0)
  logical, parameter :: test_cmaxlen = len(maxval([character*4::])) == 4
  logical, parameter :: test_cmaxidentity = maxval([character*4::]) == repeat(char(0), 4)
  logical, parameter :: test_cminidentity = minval([character*4::]) == repeat(char(127), 4)
  logical, parameter :: test_cmaxval = maxval(chmatrix) == 'pqr'
  logical, parameter :: test_cminval = minval(chmatrix) == 'abc'
  logical, parameter :: test_maxvaldim1 = all(maxval(intmatrix,dim=1) == [2, 4, 6])
  logical, parameter :: test_minvaldim2 = all(minval(intmatrix,dim=2,mask=odds) == [1, huge(0)])

  logical, parameter :: test_iproductidentity = product([integer::]) == 1
  logical, parameter :: test_iproduct = product(intmatrix) == 720
  logical, parameter :: test_iproduct_masked = product(intmatrix,odds) == 15
  logical, parameter :: test_productdim1 = all(product(intmatrix,dim=1) == [2, 12, 30])
  logical, parameter :: test_productdim2 = all(product(intmatrix,dim=2) == [15, 48])
  logical, parameter :: test_rproductidentity = product([real::]) == 1.
  logical, parameter :: test_rproduct = product(real(intmatrix)) == 720.
  logical, parameter :: test_cproductidentity = product([complex::]) == (1.,0.)
  logical, parameter :: test_cproduct = product(cmplx(intmatrix,-intmatrix)) == (0.,5760.)

  logical, parameter :: test_isumidentity = sum([integer::]) == 0
  logical, parameter :: test_isum = sum(intmatrix) == 21
  logical, parameter :: test_isum_masked = sum(intmatrix,odds) == 9
  logical, parameter :: test_sumdim1 = all(sum(intmatrix,dim=1) == [3, 7, 11])
  logical, parameter :: test_sumdim2 = all(sum(intmatrix,dim=2) == [9, 12])
  logical, parameter :: test_rsumidentity = sum([real::]) == 0.
  logical, parameter :: test_rsum = sum(real(intmatrix)) == 21.
  logical, parameter :: test_csumidentity = sum([complex::]) == (0.,0.)
  logical, parameter :: test_csum = sum(cmplx(intmatrix,-intmatrix)) == (21.,-21.)
end


program main
    use mpi
    implicit none
    real(8), parameter :: pi = acos(-1.d0), kB = 1.d0
    integer :: ntasks, id, rc
    integer, allocatable :: status(:)
    integer :: i, n, clock
    integer, allocatable :: seed(:)
    real(8) :: r

    real(8) :: T, dT = .002d0, T_final = 2.35d0, beta
    integer :: L = 30, dL = 2, L_final = 100
    integer, allocatable :: lattice(:,:)
    integer :: x, y
    integer, parameter :: n_warmup = 200, n_evol = 2000
    real(8) :: J = 1.d0, P_add
    real(8) :: M, M_sqr, E_tmp, E, E_sqr, M_ave, M_sqr_ave, chi, E_ave, E_sqr_ave, C
    real(8) :: T_c, m_c, chi_max, C_max

    ! initialize MPI environment
    call MPI_INIT(rc)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, rc)
    call MPI_COMM_RANK(MPI_COMM_WORLD, id, rc)
    allocate(status(MPI_STATUS_SIZE))

    ! initialize seeds for different processes
    if (id == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(r)
            clock = clock + Int(r * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, rc)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, id, MPI_COMM_WORLD, status, rc)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    do while (L <= L_final)
        if (id == 0) then
            open(unit = 1, file = 'data.txt', status = 'unknown', position = 'append')
            open(unit = 2, file = 'summary.txt', status = 'unknown', position = 'append')
            write(*,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            write(*,'(" !!!!!!!!!!!!!!!!!!!!!!!!!!!!!  L  =  ",i10,"  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")') L
            write(*,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            write(*,'(4a20)') 'T', 'm', 'chi', 'C'
        end if
        T = 2.25d0
        T_c = 0
        m_c = 0
        chi_max = 0
        C_max = 0
        allocate(Lattice(0:L - 1,0:L - 1))
        Lattice = 1

        do while (T < T_final)
            beta = 1.d0 / kB / T
            P_add = 1 - exp(-2 * beta * J)
            M = 0.d0
            M_sqr = 0.d0
            E = 0.d0
            E_sqr = 0.d0

            ! warm up
            do i =1, n_warmup
                call EVOLUTION(lattice, L, P_add)
            end do

            ! evolution
            do i = 1, n_evol
                call EVOLUTION(lattice, L, P_add)
                M = M + abs(sum(lattice))
                M_sqr = M_sqr + sum(lattice)**2
                E_tmp = 0.d0
                do x = 0, L - 2
                    do y = 0, L - 2
                        E_tmp = E_tmp + lattice(x, y) * (lattice(x + 1, y) + lattice(x, y + 1))
                    end do
                end do
                do x = 0, L - 2
                    E_tmp = E_tmp + lattice(x, L - 1) * (lattice(x + 1, L - 1) + lattice(x, 0))
                end do
                do y = 0, L - 2
                    E_tmp = E_tmp + lattice(L - 1, y) * (lattice(L - 1, y + 1) + lattice(0, y))
                end do
                E_tmp = E_tmp + lattice(L - 1, L - 1) * (lattice(0, L - 1) + Lattice(L - 1, 0))
                E_tmp = - E_tmp * J
                E = E + E_tmp
                E_sqr = E_sqr + E_tmp**2
            end do
            call MPI_REDUCE(M, M_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
            call MPI_REDUCE(M_sqr, M_sqr_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
            call MPI_REDUCE(E, E_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
            call MPI_REDUCE(E_sqr, E_sqr_ave, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, rc)
            if (id == 0) then
                M_ave = M_ave / dble(ntasks * n_evol)
                M_sqr_ave = M_sqr_ave / dble(ntasks * n_evol)
                chi = beta * (M_sqr_ave - M_ave**2)
                E_ave = E_ave / dble(ntasks * n_evol)
                E_sqr_ave = E_sqr_ave / dble(ntasks * n_evol)
                C = kB * beta**2 / dble(L * L) * (E_sqr_ave - E_ave**2)
                write(*,'(4f20.10)') T, M_ave / dble(L * L), chi, C
                write(1,'(4f20.10)') T, M_ave / dble(L * L), chi, C

                if (chi > chi_max) then
                    m_c = M_ave / dble(L * L)
                    chi_max = chi
                    T_c = T
                    C_max = C
                end if
            end if
            T = T + dT
        end do

        if (id == 0) then
            write(*,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            write(*,'(a5,a15,3a20)') 'L', 'T_c', 'm_c', 'chi_max', 'C_max'
            write(*,'(i5,f15.10,3f20.10)') L, T_c, m_c, chi_max, C_max
            write(*,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            write(*,*)
            write(1,*)
            write(2,'(i10,4f20.10)') L, T_c, m_c, chi_max, C_max
            close(1)
            close(2)
        end if
        L = L + dL
        deallocate(Lattice)
    end do

    ! done with MPI
    call MPI_FINALIZE(rc)
end program main

subroutine EVOLUTION(lattice, L, P_add)
    implicit none
    integer, intent(in) :: L
    integer, intent(inout) :: lattice(0:L - 1, 0:L - 1)
    real(8), intent(in) :: P_add
    real(8) :: r
    integer :: x, y, x_neighbor, y_neighbor, i
    integer :: cluster(L * L, 2)
    integer :: n_seed, n_cluster, cluster_spin
    logical :: notincluster

    ! choose seed spin
    call RANDOM_NUMBER(r)
    x = floor(r * dble(L))
    call RANDOM_NUMBER(r)
    y = floor(r * dble(L))
    n_cluster = 1
    n_seed = 1
    cluster(1,1) = x
    cluster(1,2) = y
    cluster_spin = lattice(x, y)
    lattice(x, y) = -lattice(x, y)

    do while (n_seed <= n_cluster)
        x = cluster(n_seed, 1)
        y = cluster(n_seed, 2)
        n_seed = n_seed + 1

        x_neighbor = modulo(x - 1, L)
        y_neighbor = y
        if (lattice(x_neighbor, y_neighbor) == cluster_spin) then
            call RANDOM_NUMBER(r)
            if (r < P_add) then
                notincluster = .true.
                do i = n_cluster, 1, -1
                    if ((cluster(i, 1) == x_neighbor) .and. (cluster(i, 2) == y_neighbor)) then
                        notincluster = .false.
                        exit
                    end if
                end do
                if (notincluster .eqv. .true.) then
                    n_cluster = n_cluster + 1
                    cluster(n_cluster, 1) = x_neighbor
                    cluster(n_cluster, 2) = y_neighbor
                    lattice(x_neighbor, y_neighbor) = -lattice(x_neighbor, y_neighbor)
                end if
            end if
        end if

        x_neighbor = modulo(x + 1, L)
        ! y_neighbor = y
        if (lattice(x_neighbor, y_neighbor) == cluster_spin) then
            call RANDOM_NUMBER(r)
            if (r < P_add) then
                notincluster = .true.
                do i = n_cluster, 1, -1
                    if ((cluster(i, 1) == x_neighbor) .and. (cluster(i, 2) == y_neighbor)) then
                        notincluster = .false.
                        exit
                    end if
                end do
                if (notincluster .eqv. .true.) then
                    n_cluster = n_cluster + 1
                    cluster(n_cluster, 1) = x_neighbor
                    cluster(n_cluster, 2) = y_neighbor
                    lattice(x_neighbor, y_neighbor) = -lattice(x_neighbor, y_neighbor)
                end if
            end if
        end if

        x_neighbor = x
        y_neighbor = modulo(y - 1, L)
        if (lattice(x, y_neighbor) == cluster_spin) then
            call RANDOM_NUMBER(r)
            if (r < P_add) then
                notincluster = .true.
                do i = n_cluster, 1, -1
                    if ((cluster(i, 1) == x_neighbor) .and. (cluster(i, 2) == y_neighbor)) then
                        notincluster = .false.
                        exit
                    end if
                end do
                if (notincluster .eqv. .true.) then
                    n_cluster = n_cluster + 1
                    cluster(n_cluster, 1) = x_neighbor
                    cluster(n_cluster, 2) = y_neighbor
                    lattice(x_neighbor, y_neighbor) = -lattice(x_neighbor, y_neighbor)
                end if
            end if
        end if

        ! x_neighbor = x
        y_neighbor = modulo(y + 1, L)
        if (lattice(x_neighbor, y_neighbor) == cluster_spin) then
            call RANDOM_NUMBER(r)
            if (r < P_add) then
                notincluster = .true.
                do i = n_cluster, 1, -1
                    if ((cluster(i, 1) == x_neighbor) .and. (cluster(i, 2) == y_neighbor)) then
                        notincluster = .false.
                        exit
                    end if
                end do
                if (notincluster .eqv. .true.) then
                    n_cluster = n_cluster + 1
                    cluster(n_cluster, 1) = x_neighbor
                    cluster(n_cluster, 2) = y_neighbor
                    lattice(x_neighbor, y_neighbor) = -lattice(x_neighbor, y_neighbor)
                end if
            end if
        end if
    end do
end subroutine EVOLUTION


C SUBROUTINE POLFIT.F
C
C SOURCE
C   BEVINGTON, PAGES 140-142.
C
C PURPOSE
C   MAKE A LEAST-SQUARES FIT TO DATA WITH A POLYNOMIAL CURVE
C      Y = A(1) + A(2)*X + A(3)*X**2 + A(3)*X**3 + . . .
C
C USAGE
C   CALL POLFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, CHISQR)
C
C DESCRIPTION OF PARAMETERS
C   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF COEFFICIENTS (DEGREE OF POLYNOMIAL + 1)
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C	      0 (NO WEIGHTING) WEIGHT(I) = 1.
C	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   A	   - ARRAY OF COEFFICIENTS OF POLYNOMIAL
C   CHISQR - REDUCED CHI SQUARE FOR FIT
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   DETERM (ARRAY, NORDER)
C      EVALUATES THE DETERMINANT OF A SYMETRICAL
C      TWO-DIMENSIONAL MATRIX OF ORDER NORDER
C
C COMMENTS
C   DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C
	SUBROUTINE POLFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,CHISQR)
	DOUBLE PRECISION SUMX,SUMY,XTERM,YTERM,ARRAY,CHISQ
	DIMENSION X(1),Y(1),SIGMAY(1),A(1)
	DIMENSION SUMX(19),SUMY(10),ARRAY(10,10)
C
C ACCUMULATE WEIGHTED SUMS
C
11	NMAX=2*NTERMS-1
	DO 13 N=1,NMAX
13	SUMX(N)=0.
	DO 15 J=1,NTERMS
15	SUMY(J)=0.
	CHISQ=0.
21	DO 50 I=1,NPTS
	XI=X(I)
	YI=Y(I)
31	IF (MODE) 32,37,39
32	IF (YI) 35,37,33
33	WEIGHT=1./YI
	GOTO 41
35	WEIGHT=1./(-YI)
	GOTO 41
37	WEIGHT=1.
	GOTO 41
39	WEIGHT=1./SIGMAY(I)**2
41	XTERM=WEIGHT
	DO 44 N=1,NMAX
	SUMX(N)=SUMX(N)+XTERM
44	XTERM=XTERM*XI
45	YTERM=WEIGHT*YI
	DO 48 N=1,NTERMS
	SUMY(N)=SUMY(N)+YTERM
48	YTERM=YTERM*XI
49	CHISQ=CHISQ+WEIGHT*YI**2
50	CONTINUE
C
C CONSTRUCT MATRICES AND CALCULATE COEFFICIENTS
C
51	DO 54 J=1,NTERMS
	DO 54 K=1,NTERMS
	N=J+K-1
54	ARRAY(J,K)=SUMX(N)
	DELTA=DETERM (ARRAY,NTERMS)
	IF (DELTA) 61,57,61
57	CHISQR=0.
	DO 59 J=1,NTERMS
59	A(J)=0.
	GOTO 80
61	DO 70 L=1,NTERMS
62	DO 66 J=1,NTERMS
	DO 65 K=1,NTERMS
	N=J+K-1
65	ARRAY(J,K)=SUMX(N)
66	ARRAY(J,L)=SUMY(J)
70	A(L)=DETERM (ARRAY,NTERMS) /DELTA
C
C CALCULATE CHI SQUARE
C
71	DO 75 J=1,NTERMS
	CHISQ=CHISQ-2.*A(J)*SUMY(J)
	DO 75 K=1,NTERMS
	N=J+K-1
75	CHISQ=CHISQ+A(J)*A(K)*SUMX(N)
76	FREE=NPTS-NTERMS
77	CHISQR=CHISQ/FREE
80	RETURN
	END


program problem_2

use aoc_utilities

implicit none

integer,dimension(2) :: xz !! [horizontal position, depth]
integer,dimension(3) :: xza !! [horizontal position, depth, aim]
integer :: i, ival, iunit
character(len=:),allocatable :: line
logical :: status_ok
type(string),dimension(:),allocatable :: vals

xz = 0
xza = 0

open(newunit=iunit,file='inputs/day2.txt')
do i = 1, number_of_lines_in_file(iunit)

    call read_line_from_file(iunit,line,status_ok)

    call split(line,' ',vals)

    read(vals(2)%str, '(I10)') ival ! string to integer

    select case (vals(1)%str)
    case('forward')
        xz(1) = xz(1) + ival
        xza(1) = xza(1) + ival          ! increases your horizontal position by X units.
        xza(2) = xza(2) + (xza(3)*ival) ! increases your depth by your aim multiplied by X
    case('up')
        xz(2) = xz(2) - ival
        xza(3) = xza(3) - ival
    case('down')
        xz(2) = xz(2) + ival
        xza(3) = xza(3) + ival
    case default; error stop 'error'
    end select

end do

write(*,*) '2A: horizontal * depth: ', product(xz)

write(*,*) '2B: horizontal * depth: ', product(xza(1:2))

end program problem_2


SUBROUTINE LUBKSB(A,N,NP,INDX,B)
  IMPLICIT NONE

  !Transferred variables
  INTEGER::N,NP,INDX(N)
  REAL(8)::A(NP,NP),B(N)

  !Local variables
  INTEGER::I,II,J,LL
  REAL(8)::SUM

  II=0
  DO I=1,N
    LL=INDX(I)
    SUM=B(LL)
    B(LL)=B(I)
    IF (II.NE.0) THEN
      DO J=II,I-1
        SUM=SUM-A(I,J)*B(J)
      END DO
    ELSE IF (SUM.NE.0.0) THEN
      II=I
    END IF
    B(I)=SUM
  END DO
  DO I=N,1,-1
    SUM=B(I)
    IF (I.LT.N) THEN
      DO J=I+1,N
        SUM=SUM-A(I,J)*B(J)
      END DO
    END IF
    B(I)=SUM/A(I,I)
  END DO

END SUBROUTINE LUBKSB


 SUBROUTINE actrot(lambda,theta)
!*****************************************************************
!
!     UPDATES THE NODAL LOCAL AXES
!
!*****************************************************************
 IMPLICIT NONE
!     dummy arguments
 REAL (kind=8),INTENT(IN) :: theta(3)        !rotation increment
 REAL (kind=8),INTENT(IN OUT) :: lambda(3,3) !local system
!     local variables
 REAL (kind=8) :: t(3),dl(3,3),l(3,3),modulo,c1,c2,c3

 modulo=SQRT(DOT_PRODUCT(theta,theta))      !check if Theta /= 0
 IF(modulo == 0d0) RETURN
 t = theta/modulo                           !rotation axis
 l = lambda                                 !previous local axis

 c1 = SIN(modulo)                           !factors
 c2 = 2d0*(SIN(modulo/2d0))**2
 c3 = 1d0-c2

 dl(1,1) = c3           + c2 * t(1)*t(1)    !Delta Lambda
 dl(2,1) =      c1*t(3) + c2 * t(2)*t(1)
 dl(3,1) =    - c1*t(2) + c2 * t(3)*t(1)
 dl(1,2) =    - c1*t(3) + c2 * t(1)*t(2)
 dl(2,2) = c3           + c2 * t(2)*t(2)
 dl(3,2) =      c1*t(1) + c2 * t(3)*t(2)
 dl(1,3) =      c1*t(2) + c2 * t(1)*t(3)
 dl(2,3) =    - c1*t(1) + c2 * t(2)*t(3)
 dl(3,3) = c3           + c2 * t(3)*t(3)

 lambda = MATMUL(l,dl)                      !new local axis

 RETURN
 END SUBROUTINE actrot


	SUBROUTINE DP_UGRB  ( idata, kxky, nbits, qmin, scale, misflg,
     +			      grid, iret )
C************************************************************************
C* DP_UGRB								*
C*									*
C* This subroutine unpacks a grid into the GEMPAK GRIB format.		*
C* The packing and unpacking equations are:				*
C*									*
C*	IDATA  =  NINT ( ( GRID - QMIN ) / SCALE )			*
C*	GRID   =  QMIN  +  IDATA * SCALE				*
C*									*
C* DP_UGRB  ( IDATA, KXKY, NBITS, QMIN, SCALE, MISFLG, GRID, IRET )	*
C*									*
C* Input parameters:							*
C*	IDATA (*)	INTEGER		Packed data			*
C*	KXKY		INTEGER		Number of grid points		*
C*	NBITS		INTEGER		Number of bits			*
C*	QMIN		REAL		Minimum value of grid		*
C*	SCALE		REAL		Scaling factor			*
C*	MISFLG		LOGICAL		Missing data flag		*
C*									*
C* Output parameters:							*
C*	GRID (KXKY)	REAL		Grid data			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-10 = NBITS invalid		*
C*					-12 = invalid scale		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (*)
	INTEGER		idata (*)
	LOGICAL		misflg
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for valid input.
C
	IF  ( ( nbits .le. 1 ) .or. ( nbits .gt. 31 ) )  THEN
	    iret = -10
	    RETURN
	END IF
	IF  ( scale .eq. 0. )  THEN
	    iret = -12
	    RETURN
	END IF
C
C*	Compute missing data value.
C
	imax = 2 ** nbits - 1
C
C*	Retrieve data points from buffer.
C
	iword = 1
	ibit  = 1
	DO  i = 1, kxky
C
C*	    Get the integer from the buffer.
C
	    jshft = nbits + ibit - 33
	    idat  = 0
	    idat  = ISHFT ( idata (iword), jshft )
	    idat  = IAND  ( idat, imax )
C
C*	    Check to see if packed integer overflows into next word.
C
	    IF  ( jshft .gt. 0 )  THEN
		jshft = jshft - 32
		idat2 = 0
		idat2 = ISHFT ( idata (iword+1), jshft )
		idat  = IOR ( idat, idat2 )
	    END IF
C
C*	    Compute value of word.
C
	    IF  ( ( idat .eq. imax ) .and. misflg )  THEN
		grid (i) = RMISSD
	      ELSE
		grid (i) = qmin + idat * scale
	    END IF
C
C*	    Set location for next word.
C
	    ibit = ibit + nbits
	    IF  ( ibit .gt. 32 )  THEN
		ibit  = ibit - 32
		iword = iword + 1
	    END IF
	END DO
C*
	RETURN
	END


program PolynomalFitting
  use fitting
  implicit none

  ! let us test it
  integer, parameter      :: degree = 2
  integer, parameter      :: dp = selected_real_kind(15, 307)
  integer                 :: i
  real(dp), dimension(11) :: x = (/ (i,i=0,10) /)
  real(dp), dimension(11) :: y = (/ 1,   6,  17,  34, &
                                   57,  86, 121, 162, &
                                   209, 262, 321 /)
  real(dp), dimension(degree+1) :: a

  a = polyfit(x, y, degree)

  write (*, '(F9.4)') a

end program


        SUBROUTINE FCUSP(N,T,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF THE CUSP EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        COMMON/NERVES/NNERV
        COMMON/DIFFCOEF/DIFFUS
c-----------
        DO 25 INERV=1,NNERV
        X=Y(3*INERV-2)
        A=Y(3*INERV-1)
        B=Y(3*INERV)
        IF(INERV.EQ.1)THEN
            XRIGHT=Y(3*NNERV-2)
            ARIGHT=Y(3*NNERV-1)
            BRIGHT=Y(3*NNERV)
        ELSE
            XRIGHT=Y(3*INERV-5)
            ARIGHT=Y(3*INERV-4)
            BRIGHT=Y(3*INERV-3)
        END IF
        IF(INERV.EQ.NNERV)THEN
            XLEFT=Y(1)
            ALEFT=Y(2)
            BLEFT=Y(3)
        ELSE
            XLEFT=Y(3*INERV+1)
            ALEFT=Y(3*INERV+2)
            BLEFT=Y(3*INERV+3)
        END IF
        XDOT=-10000.D0*(B+X*(A+X*X))
        U=(X-0.7D0)*(X-1.3D0)
        V=U/(U+0.1D0)
        ADOT=B+0.07D0*V
        BDOT=(1.D0*(1.D0-A*A)*B-A)-0.4D0*X+0.035D0*V
        F(3*INERV-2)=XDOT+DIFFUS*(XLEFT-2.D0*X+XRIGHT)
        F(3*INERV-1)=ADOT+DIFFUS*(ALEFT-2.D0*A+ARIGHT)
        F(3*INERV)  =BDOT+DIFFUS*(BLEFT-2.D0*B+BRIGHT)
  25    CONTINUE
        RETURN
        END


      subroutine gaussv(E, n, mean, stdev)
C     This function darws n indipendent Gaussian random numbers,
C     with mean 'mean' and standard deviation 'stdev' and puts
C     the numbers in the E array
      integer n
      real*8 E(n), mean, stdev, gauss
C     write (*,*) 'n = ', n, ' m = ', m
C     write (*,*) 'stdev = ', stdev, ' mean = ', mean

      do i = 1, n
         E(i) = gauss(mean, stdev)
C        write(*,*) 'E=',E(i)
      enddo
      return
      end

      subroutine beamv(u, n, F, L, E, I)
      integer n, j
      real*8 E(n), u(n), F, L, I
c     End deflection of a cantilever beam
      do j = 1, n
         u(j) = (F*L**3)/(3*E(j)*I)
      enddo
      end


FUNCTION erf(x)
REAL*8 erf,x
! USES gammp
REAL*8,EXTERNAL :: gammp
if(x.lt.0.)then
	erf=-gammp(0.5d0,x**2)
else
	erf=gammp(0.5d0,x**2)
endif
return
END


!*******************************************************************************
!> author: Jacob Williams
!
!  Test for the [[slsqp_module]].
!
!  This is problem 71 from the Hock-Schittkowsky test suite:
!
!```
!  min   x1*x4*(x1 + x2 + x3)  +  x3
!  s.t.  x1*x2*x3*x4  -  x5             -  25  =  0
!        x1**2 + x2**2 + x3**2 + x4**2  -  40  =  0
!        1 <=  x1,x2,x3,x4  <= 5
!        0 <=  x5
!
!  Starting point:
!     x = (1, 5, 5, 1, -24)
!
!  Optimal solution:
!     x = (1.00000000, 4.74299963, 3.82114998, 1.37940829, 0)
!```

    program slsqp_test_71

    use slsqp_module
    use slsqp_kinds

    implicit none

    integer,parameter               :: n = 5                    !! number of optimization variables
    integer,parameter               :: m = 2                    !! total number of constraints
    integer,parameter               :: meq = 2                  !! number of equality constraints
    integer,parameter               :: max_iter = 100           !! maximum number of allowed iterations
    real(wp),dimension(n),parameter :: xl = [1.0_wp, 1.0_wp, 1.0_wp, 1.0_wp, 0.0_wp]     !! lower bounds
    real(wp),dimension(n),parameter :: xu = [5.0_wp, 5.0_wp, 5.0_wp, 5.0_wp, 1.0e10_wp]  !! upper bounds
    real(wp),parameter              :: acc = 1.0e-8_wp          !! tolerance
    integer,parameter               :: linesearch_mode = 1      !! use inexact linesearch.

    type(slsqp_solver)    :: solver      !! instantiate an slsqp solver
    real(wp),dimension(n) :: x           !! optimization variable vector
    integer               :: istat       !! for solver status check
    logical               :: status_ok   !! for initialization status check
    integer               :: iterations  !! number of iterations by the solver

    x = [1.0_wp, 5.0_wp, 5.0_wp, 1.0_wp, -24.0_wp] !initial guess

    call solver%initialize(n,m,meq,max_iter,acc,func,grad,&
                            xl,xu,linesearch_mode=linesearch_mode,&
                            status_ok=status_ok,&
                            report=report_iteration)

    if (status_ok) then
        call solver%optimize(x,istat,iterations)
        write(*,*) ''
        write(*,*) 'solution   :', x
        write(*,*) 'istat      :', istat
        write(*,*) 'iterations :', iterations
        write(*,*) ''
    else
        error stop 'error calling slsqp.'
    end if

    contains

    subroutine func(me,x,f,c)

        implicit none
        class(slsqp_solver),intent(inout) :: me
        real(wp),dimension(:),intent(in)  :: x      !! optimization variable vector
        real(wp),intent(out)              :: f      !! value of the objective function
        real(wp),dimension(:),intent(out) :: c      !! the constraint vector `dimension(m)`,
                                                    !! equality constraints (if any) first.

        f = x(1)*x(4)*(x(1)+x(2)+x(3)) + x(3)

        c(1) = x(1)*x(2)*x(3)*x(4) - x(5) - 25.0_wp
        c(2) = x(1)**2 + x(2)**2 + x(3)**2 + x(4)**2 - 40.0_wp

    end subroutine func

    subroutine grad(me,x,g,a)
        !! gradients for [[func]].
        implicit none
        class(slsqp_solver),intent(inout)   :: me
        real(wp),dimension(:),intent(in)    :: x    !! optimization variable vector
        real(wp),dimension(:),intent(out)   :: g    !! objective function partials w.r.t x `dimension(n)`
        real(wp),dimension(:,:),intent(out) :: a    !! gradient matrix of constraints w.r.t. x `dimension(m,n)`

        g(1) = x(4)*(2.0_wp*x(1)+x(2)+x(3))
        g(2) = x(1)*x(4)
        g(3) = x(1)*x(4) + 1.0_wp
        g(4) = x(1)*(x(1)+x(2)+x(3))
        g(5) = 0.0_wp

        a = 0.0_wp
        a(1,1) = x(2)*x(3)*x(4)
        a(1,2) = x(1)*x(3)*x(4)
        a(1,3) = x(1)*x(2)*x(4)
        a(1,4) = x(1)*x(2)*x(3)
        a(1,5) = -1.0_wp
        a(2,1) = 2.0_wp*x(1)
        a(2,2) = 2.0_wp*x(2)
        a(2,3) = 2.0_wp*x(3)
        a(2,4) = 2.0_wp*x(4)

    end subroutine grad

    subroutine report_iteration(me,iter,x,f,c)
        use, intrinsic :: iso_fortran_env, only: output_unit
        !! report an iteration (print to the console).
        implicit none
        class(slsqp_solver),intent(inout) :: me
        integer,intent(in)                :: iter
        real(wp),dimension(:),intent(in)  :: x
        real(wp),intent(in)               :: f
        real(wp),dimension(:),intent(in)  :: c

        !write a header:
        if (iter==0) then
            write(output_unit,'(*(A20,1X))') 'iteration', 'x(1)', 'x(2)', 'x(3)', 'x(4)', 'x(5)', 'f', 'c(1)', 'c(2)'
        end if

        !write the iteration data:
        write(output_unit,'(I20,1X,(*(F20.16,1X)))') iter,x,f,c

    end subroutine report_iteration

    end program slsqp_test_71
!*******************************************************************************


c
c    uses  de Casteljau to compute one coordinate
c    value of a  Bezier curve. Has to be called
c    for each coordinate  (x,y, and/or z) of a control polygon.
c    Input:   degree: degree of curve.
c             coeff:  array with coefficients of curve.
c             t:      parameter value.
c     Output: coordinate value.
      real function decas(degree, coeff, t)
      implicit none
      integer degree
      real    coeff(*), t

      integer r, i
      real    t1
c     an auxiliary array. Change dim. if too small
      real    coeffa(0:100)

      t1 = 1.0 - t;
      coeffa(0:degree) = coeff(1:degree+1)

      do r=1,degree
         do i=0,degree-r
            coeffa(i)= t1* coeffa(i)  +   t * coeffa(i+1)
         enddo
      enddo

      decas = coeffa(0)

      end


	FUNCTION PR_PLCL  ( tmpc, pres, tlcl )
C************************************************************************
C* PR_PLCL 								*
C*									*
C* This function computes PLCL from TMPC, PRES, and TLCL for an air	*
C* parcel.  TMPC and PRES refer to the parcel before lifting, while	*
C* TLCL is the temperature at the LCL.  TLCL may be computed using	*
C* PR_TLCL.  The equation used is a modified Poisson equation:		*
C*									*
C*          PLCL = PRES * ( TLCL / TMPK ) ** ( 1 / RKAPPA )		*
C*									*
C* REAL PR_PLCL  ( TMPC, PRES, TLCL )					*
C*									*
C* Input parameters:							*
C*	TMPC		REAL    	Temperature in Celsius		*
C*	PRES		REAL		Pressure in millibars		*
C*	TLCL  		REAL    	LCL temperature in Kelvin	*
C*									*
C* Output parameters:							*
C*	PR_PLCL		REAL		LCL pressure in millibars	*
C**									*
C* Log:									*
C* M. Goodman/RDS	8/84	Original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation				*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( tmpc ) .or.
     +	      ERMISS ( tlcl ) )  THEN
	    PR_PLCL = RMISSD
	  ELSE
	    tmpk = PR_TMCK (tmpc)
	    PR_PLCL = pres * (tlcl / tmpk) ** (1 / RKAPPA)
	END IF
C*
	RETURN
	END