!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Highly divisible triangular number
!
! The sequence of triangle numbers is generated by adding the natural numbers.
! So the 7th trianlge number would be 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28. The first
! ten terms would be:
!
!    1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ...
!
! Let us list the factors of the first seven triangle numbers:
!     1: 1
!     3: 1, 3
!     6: 1, 2, 3, 6
!    10: 1, 2, 5, 10
!    15: 1, 3, 5, 15
!    21: 1, 3, 7, 21
!    28: 1, 2, 4, 7, 14, 28
!
! We can see that 28 is the first triangle number to have over five divisirs.
! What is the value of the first triangle number to have over five hundred divisors?
module MPEProblem12

    implicit none
    private

    type, public :: TPEProblem12
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 12. Highly divisible triangular number.'

        write (*, '(A, I)') 'Triangle 1: ', triangle1()
    end subroutine

    pure function triangle1()
        integer*8 triangle1

        integer number
        integer base
        integer divisors

        ! initial values
        triangle1 = 1
        number    = 1

        do while (.true.)
            divisors = 0
            do base = 1, sqrt(real(triangle1))
                if (mod(triangle1, base) .eq. 0) then
                    divisors = divisors + 1
                end if
            end do

            ! the number of divisors is two times less in case of sqr
            if (divisors .ge. 250) then
                return
            end if

            number    = number + 1
            triangle1 = triangle1 + number
        end do
    end function
end module


FUNCTION gammln_s(xx)
  USE mo_kind, only: sp, dp
  USE mo_nrutil, ONLY : arth,assert
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: xx
  REAL(SP) :: gammln_s
  REAL(DP) :: tmp,x
  REAL(DP) :: stp = 2.5066282746310005_dp
  REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,&
       -86.50532032941677_dp,24.01409824083091_dp,&
       -1.231739572450155_dp,0.1208650973866179e-2_dp,&
       -0.5395239384953e-5_dp/)
  call assert(xx > 0.0, 'gammln_s arg')
  x=xx
  tmp=x+5.5_dp
  tmp=(x+0.5_dp)*log(tmp)-tmp
  gammln_s=tmp+log(stp*(1.000000000190015_dp+&
       sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x)
END FUNCTION gammln_s

FUNCTION gammln_v(xx)
  USE mo_kind, only: sp, dp, i4
  USE mo_nrutil, ONLY: assert
  IMPLICIT NONE
  INTEGER(I4) :: i
  REAL(SP), DIMENSION(:), INTENT(IN) :: xx
  REAL(SP), DIMENSION(size(xx)) :: gammln_v
  REAL(DP), DIMENSION(size(xx)) :: ser,tmp,x,y
  REAL(DP) :: stp = 2.5066282746310005_dp
  REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,&
       -86.50532032941677_dp,24.01409824083091_dp,&
       -1.231739572450155_dp,0.1208650973866179e-2_dp,&
       -0.5395239384953e-5_dp/)
  if (size(xx) == 0) RETURN
  call assert(all(xx > 0.0), 'gammln_v arg')
  x=xx
  tmp=x+5.5_dp
  tmp=(x+0.5_dp)*log(tmp)-tmp
  ser=1.000000000190015_dp
  y=x
  do i=1,size(coef)
     y=y+1.0_dp
     ser=ser+coef(i)/y
  end do
  gammln_v=tmp+log(stp*ser/x)
END FUNCTION gammln_v

FUNCTION dgammln_s(z)
  !  Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !  Reference:
  !       Lanczos, C. ''A precision approximation of the gamma
  !               function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !  Accuracy: About 14 significant digits except for small regions
  !            in the vicinity of 1 and 2.
  !  Programmer: Alan Miller
  !              1 Creswick Street, Brighton, Vic. 3187, Australia
  !  e-mail: amiller @ bigpond.net.au
  !  Latest revision - 14 October 1996
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: z
  REAL(DP) :: dgammln_s
  ! Local variables
  REAL(DP)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
       -1259.139216722289_dp, 771.3234287757674_dp, &
       -176.6150291498386_dp, 12.50734324009056_dp, &
       -0.1385710331296526_dp, 0.9934937113930748D-05, &
       0.1659470187408462D-06 /)
  REAL(DP)  :: zero = 0.0_dp,   &
       one = 1.0_dp, &
       lnsqrt2pi =  0.9189385332046727_dp, &
       half = 0.5_dp, &
       sixpt5 = 6.5_dp, &
       seven = 7.0_dp
  REAL(DP)  :: tmp
  INTEGER   :: j
  call assert(z > zero, 'dgammln_s arg')
  dgammln_s = zero
  tmp = z + seven
  DO j = 9, 2, -1
     dgammln_s = dgammln_s + a(j)/tmp
     tmp = tmp - one
  END DO
  dgammln_s = dgammln_s + a(1)
  dgammln_s = LOG(dgammln_s) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
  RETURN
END FUNCTION dgammln_s

FUNCTION dgammln_v(z)
  !  Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !  Reference:
  !       Lanczos, C. ''A precision approximation of the gamma
  !               function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !  Accuracy: About 14 significant digits except for small regions
  !            in the vicinity of 1 and 2.
  !  Programmer: Alan Miller
  !              1 Creswick Street, Brighton, Vic. 3187, Australia
  !  e-mail: amiller @ bigpond.net.au
  !  Latest revision - 14 October 1996
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: z
  REAL(DP), DIMENSION(size(z)) :: dgammln_v
  ! Local variables
  REAL(DP)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
       -1259.139216722289_dp, 771.3234287757674_dp, &
       -176.6150291498386_dp, 12.50734324009056_dp, &
       -0.1385710331296526_dp, 0.9934937113930748D-05, &
       0.1659470187408462D-06 /)
  REAL(DP)  :: zero = 0.0_dp,   &
       one = 1.0_dp, &
       lnsqrt2pi =  0.9189385332046727_dp, &
       half = 0.5_dp, &
       sixpt5 = 6.5_dp, &
       seven = 7.0_dp
  REAL(DP), DIMENSION(size(z)) :: tmp
  INTEGER   :: j
  if (size(z) == 0) RETURN
  call assert(all(z > 0.0_dp), 'dgammln_v arg')
  dgammln_v = zero
  tmp = z + seven
  DO j = 9, 2, -1
     dgammln_v = dgammln_v + a(j)/tmp
     tmp = tmp - one
  END DO
  dgammln_v = dgammln_v  + a(1)
  dgammln_v = LOG(dgammln_v) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
END FUNCTION dgammln_v


SUBROUTINE p88(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.8 General two- (plane) or three-dimensional analysis of the
!             consolidation equation. Implicit time integration using
!             the "theta" method.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nci,ndim,nels,neq,nip,nlen,nn,nod=4,npri,&
   np_types,nres,nstep,ntime
 CHARACTER(len=15)::argv,element
 REAL(iwp)::det,dtim,penalty=1.0e20_iwp,theta,time,zero=0.0_iwp
!----------------------------- dynamic arrays-----------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:),kdiag(:)
 REAL(iwp),ALLOCATABLE::bp(:),coord(:,:),der(:,:),deriv(:,:),fun(:),      &
   g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),kv(:),loads(:),newlo(:),        &
   ntn(:,:),mm(:,:),points(:,:),prop(:,:),storbp(:),value(:),weights(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)element,nels,nn,nip,nod,ndim,np_types
 neq=nn
 ALLOCATE(points(nip,ndim),g_coord(ndim,nn),coord(nod,ndim),fun(nod),     &
   etype(nels),jac(ndim,ndim),weights(nip),num(nod),ntn(nod,nod),         &
   g_num(nod,nels),der(ndim,nod),deriv(ndim,nod),kc(nod,nod),mm(nod,nod), &
   kay(ndim,ndim),kdiag(neq),prop(ndim,np_types),newlo(0:neq),loads(0:neq))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)g_coord
 READ(10,*)g_num
 READ(10,*)dtim,nstep,theta,npri,nres
 IF(ndim==2.AND.nod==4)THEN
   READ(10,*)ntime,nci
   CALL mesh(g_coord,g_num,argv,nlen,12)
 END IF
 kdiag=0
!-----------loop the elements to set up global geometry and kdiag --------
 elements_1: DO iel=1,nels
   num=g_num(:,iel)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 WRITE(11,'(2(a,i5))')                                                    &
 " There are",neq,"  equations and the skyline storage is ",kdiag(neq)
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 CALL sample(element,points,weights)
 kv=zero
 bp=zero
!------------- global conductivity matrix assembly------------------------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)
   END DO gauss_pts
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 kv=kv*theta*dtim
 bp=bp+kv
 kv=bp-kv/theta
!---------------initial and boundary conditions data----------------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            storbp(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   bp(kdiag(node))=bp(kdiag(node))+penalty
   storbp=bp(kdiag(node))
 END IF
!------------------------factorise left hand side-------------------------
 CALL sparin(bp,kdiag)
!-------------------time stepping recursion-------------------------------
 WRITE(11,'(/a,i3,a)')"    Time      Pressure (node",nres,")"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,newlo,kdiag)
   IF(fixed_freedoms/=0)newlo(node)=storbp*value
   CALL spabac(bp,newlo,kdiag)
   loads=newlo
   IF(ndim==2.AND.nod==4.AND.j==ntime)                                    &
     CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
   IF(j/npri*npri==j)WRITE(11,'(2e12.4)')time,loads(nres)
 END DO timesteps

END SUBROUTINE p88


      double precision function total_area(mx,my,mbc,area)
      implicit none

      integer mx,my,mbc
      double precision dx,dy
      double precision sum
      integer i,j

      include 'metric_terms.i'

      sum = 0
      do j = 1,my
         do i = 1,mx
            sum = sum + area(i,j)
         enddo
      enddo
      total_area = sum

      end

      subroutine min_grid_cell_area(mx,my,mbc,dx,dy,
     &      area,minvalue)
      implicit none

      integer mx,my,mbc
      double precision dx,dy,dxdy
      double precision minvalue
      integer i,j

      include 'metric_terms.i'

c     # minvalue comes in with a value;  we only
c     # compare it here.
      dxdy = dx*dy
      do i = 1,mx
         do j = 1,my
            minvalue = min(minvalue,area(i,j)/dxdy)
         enddo
      enddo

      end

      subroutine max_grid_cell_area(mx,my,mbc,dx,dy,
     &      area,maxvalue)
      implicit none

      integer mx,my,mbc
      double precision dx,dy,dxdy
      double precision maxvalue
      integer i,j

      include 'metric_terms.i'

c     # maxvalue comes in with a value;  we only
c     # compare it here.
      dxdy = dx*dy
      do i = 1,mx
         do j = 1,my
            maxvalue = max(maxvalue,area(i,j)/dxdy)
         enddo
      enddo

      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   bvp :    A nonlinear ODE eigenvalue problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

  DOUBLE PRECISION pi

  pi = 4.d0*ATAN(1.d0)

  F(1) = U(2)
  F(2) = -( PAR(1)*pi )**2 * U(1) + U(1)**2

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:2) = 0.0d0

  U = 0.0d0

END SUBROUTINE STPNT

SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
  DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

  FB = (/ U0(1), U1(1) /)

END SUBROUTINE BCND

SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
  DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

  FI = (/ U(1)-PAR(2) /)

END SUBROUTINE ICND

SUBROUTINE FOPT
END SUBROUTINE FOPT

SUBROUTINE PVLS
END SUBROUTINE PVLS


!*****************************************************************************************
!> author: Jacob Williams
!
!  Use the gif module to create a sample animated gif.
!
!# See also
!  * [Make a circle illusion animation](http://codegolf.stackexchange.com/questions/34887/make-a-circle-illusion-animation)

    program circle_illusion

    use, intrinsic :: iso_fortran_env, only: wp=>real64
    use gif_module

    implicit none

    logical,parameter :: new = .true.

    integer,parameter  :: n        = 200  !! size of image (square)
    real(wp),parameter :: rcircle  = n/2  !! radius of the big circle
    integer,parameter  :: time_sep = 5    !! deg

    real(wp),parameter :: deg2rad = acos(-1.0_wp)/180.0_wp

    integer,dimension(:,:,:),allocatable :: pixel    !! pixel values

    real(wp),dimension(2) :: xy
    integer,dimension(2)  :: ixy
    real(wp)              :: r,t
    integer               :: i,j,k,row,col,m,n_cases,ang_sep,iframe
    character(len=10)     :: istr

    integer,dimension(3,0:5)  :: colormap
    integer,parameter  :: white = 0
    integer,parameter  :: gray  = 1
    integer,parameter  :: red   = 2
    integer,parameter  :: green = 3
    integer,parameter  :: blue  = 4
    integer,parameter  :: black = 5

    colormap(:,black) = [0,0,0]
    colormap(:,white) = [255,255,255]
    colormap(:,gray)  = [200,200,200]
    colormap(:,red)   = [255,0,0]
    colormap(:,green) = [0,255,0]
    colormap(:,blue)  = [0,0,255]

    if (new) then
        ang_sep = 5
        n_cases = 3
    else
        ang_sep = 20
        n_cases = 0
    end if

    !how many frames:
    iframe=0
    do k=0,355,time_sep
        iframe=iframe+1
    end do
    allocate(pixel(iframe,0:n,0:n))

    iframe=0
    do k=0,355,time_sep

        !frame number:
        iframe=iframe+1

        !clear entire image:
        pixel(iframe,:,:) = white

        if (new) call draw_circle(n/2,n/2,red,n/2)

        !draw polar grid:
        do j=0,180-ang_sep,ang_sep
            do i=-n/2, n/2
                call spherical_to_cartesian(dble(i),dble(j)*deg2rad,xy)
                call convert(xy,row,col)
                if (new) then
                    pixel(iframe,row,col) = gray
                else
                    pixel(iframe,row,col) = black
                end if
            end do
        end do

        !draw dots:
        do m=0,n_cases
            do j=0,360-ang_sep,ang_sep
                r = sin(m*90.0_wp*deg2rad + (k + j)*deg2rad)*rcircle
                t = dble(j)*deg2rad
                call spherical_to_cartesian(r,t,xy)
                call convert(xy,row,col)
                if (new) then
                    !call draw_circle(row,col,black,10)    !v2
                    !call draw_circle(row,col,m,5)         !v2
                    call draw_circle(row,col,mod(j,3)+3,5) !v3
                else
                    call draw_square(row,col,red)          !v1
                end if
            end do
        end do

    end do

    call write_animated_gif('animated_gif_1.gif',pixel,colormap,delay=5)

    deallocate(pixel)

    contains
!*****************************************************************************************

    !*************************************************************************************
    !> author: Jacob Williams
    !
    !  Draw a square.

        subroutine draw_square(r,c,icolor)

        implicit none
        integer,intent(in) :: r      !! row of center
        integer,intent(in) :: c      !! col of center
        integer,intent(in) :: icolor !! color value

        integer,parameter :: d = 10 !square size

        pixel(iframe,max(0,r-d):min(n,r+d),max(0,c-d):min(n,c+d)) = icolor

        end subroutine draw_square
    !*************************************************************************************

    !*************************************************************************************
    !> author: Jacob Williams
    !
    !  Draw a circle.

        subroutine draw_circle(r,c,icolor,d)

        implicit none

        integer,intent(in) :: r      !! row of center
        integer,intent(in) :: c      !! col of center
        integer,intent(in) :: icolor !! color value
        integer,intent(in) :: d      !! diameter

        integer :: i,j

        do i=max(0,r-d),min(n,r+d)
            do j=max(0,c-d),min(n,c+d)
                if (sqrt(dble(i-r)**2 + dble(j-c)**2)<=d) &
                    pixel(iframe,i,j) = icolor
            end do
        end do

        end subroutine draw_circle
    !*************************************************************************************

    !*************************************************************************************
    !> author: Jacob Williams
    !
    !  Convert from x,y to row,col.

        subroutine convert(xy,row,col)

        implicit none

        real(wp),dimension(2),intent(in) :: xy  !! coordinates
        integer,intent(out) :: row
        integer,intent(out) :: col

        row = int(-xy(2) + n/2.0_wp)
        col = int( xy(1) + n/2.0_wp)

        end subroutine convert
    !*************************************************************************************

    !*************************************************************************************
    !> author: Jacob Williams
    !
    !  Convert spherical to cartesian coordinates.

        subroutine spherical_to_cartesian(r,theta,xy)

        implicit none

        real(wp),intent(in) :: r
        real(wp),intent(in) :: theta
        real(wp),dimension(2),intent(out) :: xy

        xy(1) = r * cos(theta)
        xy(2) = r * sin(theta)

        end subroutine spherical_to_cartesian
    !*************************************************************************************

    end program circle_illusion
!*****************************************************************************************


!/*****************************************************************************/
! *
! *  Elmer/Ice, a glaciological add-on to Elmer
! *  http://elmerice.elmerfem.org
! *
! *
! *  This program is free software; you can redistribute it and/or
! *  modify it under the terms of the GNU General Public License
! *  as published by the Free Software Foundation; either version 2
! *  of the License, or (at your option) any later version.
! *
! *  This program is distributed in the hope that it will be useful,
! *  but WITHOUT ANY WARRANTY; without even the implied warranty of
! *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! *  GNU General Public License for more details.
! *
! *  You should have received a copy of the GNU General Public License
! *  along with this program (in file fem/GPL-2); if not, write to the
! *  Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
! *  Boston, MA 02110-1301, USA.
! *
! *****************************************************************************/
! ******************************************************************************
FUNCTION Bueler ( Model, nodenumber, coord) RESULT(elevation)
   USE Types
   USE DefUtils
   IMPLICIT NONE
   TYPE(Model_t) :: Model
   INTEGER :: nodenumber
   REAL(KIND=dp) :: coord(3), elevation

   REAL(KIND=dp), PARAMETER :: L = 361.25d03, H0 = 2.06d03, n = 3.0_dp, minh=100.0_dp
   REAL(KIND=dp) :: T1, T2, H, R

   R = SQRT(coord(1)*coord(1) + coord(2)*coord(2))
   T1 = ( H0/((n - 1.0_dp)**(n/(2.0_dp*n + 2.0_dp))) )
   T2 = (n + 1.0_dp)*(R/L) - n*((R/L)**((n + 1.0_dp)/n)) + &
        n*((1.0_dp - (R/L))**((n + 1.0_dp)/n) ) - 1.0
   H =  T1 * ( T2**(n/(2.0*n + 2.0)) )
   elevation = MAX(H,minh)
 END FUNCTION Bueler


      subroutine rotsdm(zz, u, nch)
c     rotsdm rotates the spectral density matrix applying a rotation matrix u
c     zz is the spectral density matrix in compact storage mode, i. e.
c     only the diagonal terms and those below the diagonal are stored. There are
c     nch*(nch+1)/2 elements.
c     u is the full rotation matrix, i.e a nch x nch matrix, though many elements
c     are 0.

      complex zz(*), zzz(7,7), a(7,7)
      real u(7,7)

c     make the full matrix zzz from the compact SDM zz
      kj = 0
      do k = 1, nch
         do j = 1, k
            kj = kj + 1
            zzz(j,k) = (zz(kj))
            zzz(k,j) = conjg(zz(kj))
         enddo
      enddo

c     now multiply u from left with zzz
      do i = 1, nch
         do j = 1,nch
            a(i,j) = (0.0,0.0)
            do k = 1,nch
               a(i,j) = a(i,j) + u(i,k)*zzz(k,j)
            enddo
         enddo
      enddo
c     and now the transposed of u from the right to a
      do i = 1, nch
         do j = 1,nch
            zzz(i,j) = (0.0,0.0)
            do k = 1,nch
               zzz(i,j) = zzz(i,j) + a(i,k) * u(j,k)
            enddo
         enddo
      enddo

c     finally, restore the full matrix zzz in the compact zz
      kj = 0
      do k = 1, nch
         do j = 1,k
            kj = kj + 1
            zz(kj) = zzz(k,j)
         enddo
      enddo

      return
      end


      PROGRAM xmrqmin
C     driver for routine mrqmin
      INTEGER NPT,MA
      REAL SPREAD
      PARAMETER(NPT=100,MA=6,SPREAD=0.001)
      INTEGER i,ia(MA),idum,iter,itst,j,k,mfit
      REAL alamda,chisq,fgauss,gasdev,ochisq,x(NPT),y(NPT),sig(NPT),
     *     a(MA),covar(MA,MA),alpha(MA,MA),gues(MA)
      EXTERNAL fgauss
      DATA a/5.0,2.0,3.0,2.0,5.0,3.0/
      DATA gues/4.5,2.2,2.8,2.5,4.9,2.8/
      idum=-911
C     first try a sum of two Gaussians
      do 12 i=1,NPT
        x(i)=0.1*i
        y(i)=0.0
        do 11 j=1,MA,3
          y(i)=y(i)+a(j)*exp(-((x(i)-a(j+1))/a(j+2))**2)
11      continue
        y(i)=y(i)*(1.0+SPREAD*gasdev(idum))
        sig(i)=SPREAD*y(i)
12    continue
      mfit=MA
      do 13 i=1,mfit
        ia(i)=1
13    continue
      do 14 i=1,MA
        a(i)=gues(i)
14    continue
      do 16 iter=1,2
        alamda=-1
        call mrqmin(x,y,sig,NPT,a,ia,MA,covar,alpha,
     *       MA,chisq,fgauss,alamda)
        k=1
        itst=0
1       write(*,'(/1x,a,i2,t18,a,f10.4,t43,a,e9.2)') 'Iteration #',k,
     *       'Chi-squared:',chisq,'ALAMDA:',alamda
        write(*,'(1x,t5,a,t13,a,t21,a,t29,a,t37,a,t45,a)') 'A(1)',
     *       'A(2)','A(3)','A(4)','A(5)','A(6)'
        write(*,'(1x,6f8.4)') (a(i),i=1,6)
        k=k+1
        ochisq=chisq
        call mrqmin(x,y,sig,NPT,a,ia,MA,covar,alpha,
     *       MA,chisq,fgauss,alamda)
        if (chisq.gt.ochisq) then
          itst=0
        else if (abs(ochisq-chisq).lt.0.1) then
          itst=itst+1
        endif
        if (itst.lt.4) then
          goto 1
        endif
        alamda=0.0
        call mrqmin(x,y,sig,NPT,a,ia,MA,covar,alpha,
     *       MA,chisq,fgauss,alamda)
        write(*,*) 'Uncertainties:'
        write(*,'(1x,6f8.4/)') (sqrt(covar(i,i)),i=1,6)
        write(*,'(1x,a)') 'Expected results:'
        write(*,'(1x,f7.2,5f8.2/)') 5.0,2.0,3.0,2.0,5.0,3.0
        if (iter.eq.1) then
          write(*,*) 'press return to continue with constraint'
          read(*,*)
          write(*,*) 'Holding a(2) and a(5) constant'
          do 15 j=1,MA
            a(j)=a(j)+.1
15        continue
          a(2)=2.0
          ia(2)=0
          a(5)=5.0
          ia(5)=0
        endif
16    continue
      END

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


! { dg-do run }
!
! PR fortran/44646
!
! DO CONCURRENT
!
implicit none
integer :: i, j
integer :: A(5,5)

A = 0.0
do concurrent (i=1:5, j=1:5, (i/=j))
  if (i == 5) cycle
  A(i,j) = i*j
end do

if (any (A(:,1) /= [0,  2,  3,  4, 0])) STOP 1
if (any (A(:,2) /= [2,  0,  6,  8, 0])) STOP 2
if (any (A(:,3) /= [3,  6,  0, 12, 0])) STOP 3
if (any (A(:,4) /= [4,  8, 12,  0, 0])) STOP 4
if (any (A(:,5) /= [5, 10, 15, 20, 0])) STOP 5

A = -99

do concurrent (i = 1 : 5)
  forall (j=1:4, i/=j)
    A(i,j) = i*j
  end forall
  if (i == 5) then
    A(i,i) = -i
  end if
end do

if (any (A(:,1) /= [-99,   2,   3,   4,  5])) STOP 6
if (any (A(:,2) /= [  2, -99,   6,   8, 10])) STOP 7
if (any (A(:,3) /= [  3,   6, -99,  12, 15])) STOP 8
if (any (A(:,4) /= [  4,   8,  12, -99, 20])) STOP 9
if (any (A(:,5) /= [-99, -99, -99, -99, -5])) STOP 10

end


program test
  integer :: a(10, 10), b(10,10), c(10, 10)
  integer:: i = 1,j =1

  do while (i <= 10)
    j = 1
    do while (j <= 10)
      a(j,i) = i
      b(j,i) = j

      IF (i >= 5 .and. j >= 5) THEN
        b(j,i) = b(1,1) + j * j
      END IF

      j = j + 1
    end do
    i = i + 1
  end do

  i = 1
  IF (b(1,1) >= 0) THEN
    do while (i <= 10)
      j = 1
      do while (j <= 10)
        c(j,i) = a(j,i) + b(j,i)
        j = j + 1
      end do
      i = i + 1
    end do
  END IF

  print *, c
end program test


! fortran statement function is a function-like declaration, made in a single statement.
! refer : https://www.obliquity.com/computer/fortran/function.html
!         https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnb9/index.html
program square
	implicit none;

	integer num;
 	integer F;
	F(num) = num * num;
	print *, "Enter number : ";
 	read  *, num;
	write(*,*) "Square of ", num, " is : ", F(num);
	!print *, "Square of ", num, " is : ", F(num);

end program square


module imc_global_phys_data

implicit none

real(kind=8), parameter :: c  = 3.d10
real(kind=8), parameter :: pi = 3.14159265359d0
real(kind=8), parameter :: h  = 4.1356675d-18                   ! KeV.s
real(kind=8), parameter :: sb = 2. * pi**5 / (15. * h**3*c**2)  ! keV^-3.cm^-2.s^-1 (flux-like)
real(kind=8), parameter :: a  = 4.d0 * sb / c

real(kind=8), parameter :: invc   = 1. / c
real(kind=8), parameter :: invh   = 1. / h
real(kind=8), parameter :: invh3  = 1. / h**3
real(kind=8), parameter :: x15pi4 = 15. / pi**4

end module imc_global_phys_data


      subroutine qltri3(p2sq,p3sq,msq,musq,Ival)
      implicit none
      include 'qlconstants.f'
      double precision p2sq,p3sq,msq,musq,m2sqb,m3sqb,r
      double complex fac,qllnrat,Ival(-2:0),wlog2,wlog3,wlogm,
     . dilog2,dilog3,qlLi2omrat

      m2sqb = msq-p2sq
      m3sqb = msq-p3sq
      dilog2= qlLi2omrat(m2sqb,msq)
      dilog3= qlLi2omrat(m3sqb,msq)

      wlog2=qllnrat(m2sqb,msq)
      wlog3=qllnrat(m3sqb,msq)
      wlogm=qllnrat(musq,msq)
      r =(m3sqb-m2sqb)/m2sqb

      Ival(-2)=czip
      if (abs(r) .lt. 1d-6) then
      Ival(-1)=dcmplx((1d0-r/2d0)/m2sqb)
      Ival(0)=wlogm-dcmplx((msq+p2sq)/p2sq*wlog2)
      Ival(0)=Ival(0)-chalf*r*((msq**2-2d0*p2sq*msq-p2sq**2)*wlog2
     .+p2sq*(dcmplx(msq+p2sq)+p2sq*wlogm))/p2sq**2
      Ival(0)=Ival(0)/dcmplx(m2sqb)
      else
      fac=dcmplx(1d0/(p2sq-p3sq))
      Ival(-1)=fac*(wlog3-wlog2)
      Ival(0)=Ival(-1)*wlogm
     . +fac*(dilog2-dilog3+(wlog2**2-wlog3**2))
      endif
      return
      end


      SUBROUTINE GCLOUD(FREQY,T,CLW,Z_CLW)

      ES = 191.4 - 0.378*T
      TAU = 0.00199*EXP(2140/T)/T
      X = 6.283*FREQY*TAU
      EZ = 4.9
      RPE = EZ + (ES-EZ)/(1+X*X)
      XIPE = -(EZ -ES)*X/(1+X*X)
      Z_CLW = 0.188*CLW*FREQY*XIPE/((RPE+2)**2 + (XIPE)**2)
      RETURN
      END


!	Find the gradient of the conditional log posterior.
!	mask indicates which items are present.
!	condmeans is the vector of conditional means of scale factors.
!	linth is the linear component of the log density.
!	lintran is the linear transformation of the latent vector.
!	means is the vector of means of scale factors.
!	quadth is the quadratic component of the log density.
!	theta is the value of the latent vector.
function gradtheta(mask,condmeans,linth,lintran,means,quadth,theta)
implicit none

logical,intent(in)::mask(:)
real(kind=8),intent(in)::condmeans(:,:),linth(:),lintran(:,:),means(:,:),quadth(:,:),theta(:)
real(kind=8)::gradtheta(size(theta))
real(kind=8)::itempart(size(lintran,1))
!	item is an item
integer::item
itempart=0.0_8
do item=1,size(mask)
	if(mask(item))then
		itempart=itempart+(condmeans(:,item)-means(:,item))
	end if
end do
gradtheta=linth+2.0_8*matmul(quadth,theta)+matmul(transpose(lintran),itempart)
return
end function gradtheta


      SUBROUTINE LNPLPT (LX,LY,LZ, AL,BL,CL, AP,BP,CP,DP, XI,YI,ZI)

C  Given a line and a plane, find point of intersection.

C  Input parameters
C    LX,LY,LZ    : point on the line
C    AL,BL,CL    : direction of line
C    AP,BP,CP,DP : co-efficients of plane
C  Output parameters
C    XI,YI,ZI    : point of intersection

      REAL   U, LX,LY,LZ, AL,BL,CL, AP,BP,CP,DP, XI,YI,ZI, DOTPRD

      U = - (DOTPRD (AP,BP,CP, LX,LY,LZ) + DP) /
     1       DOTPRD (AP,BP,CP, AL,BL,CL)

      XI = LX + AL*U
      YI = LY + BL*U
      ZI = LZ + CL*U

      END


module derivative_mod_gpu
    use cudafor
    implicit none
    contains

        attributes(global) subroutine derivative_halo_gpu_kernel(u,du,n1, n2, n3,factors)
        !! divergence_mod :
        !! Compute the divergence using mod function to access neighbours on boundaries.
        !! The memory access on boundaries in not-contigous.
        real*8::u(-1:n1+2,-1:n2+2,-1:n3+2)
        real*8::du(n1,n2,n3),factors(5)
        integer, value, intent(in) :: n1, n2, n3

        integer  :: i, j,k, l, xn(5),yn(5),zn(5)
        real*8 :: ux(5), uy(5), uz(5)

        i = (blockIdx%x-1) * blockDim%x + threadIdx%x
        j = (blockIdx%y-1) * blockDim%y + threadIdx%y
        k = (blockIdx%z-1) * blockDim%z + threadIdx%z

!!        print *,i,j,k

          du(i, j, k) = (u(i - 2, j, k) + u(i, j - 2, k) + u(i, j, k - 2)) * factors(1) + &
                                  (u(i - 1, j, k) + u(i, j - 1, k) + u(i, j, k - 1)) * factors(2) + &
                                  (u(i, j, k)     + u(i, j, k)     + u(i, j, k)    ) * factors(3) + &
                                  (u(i + 1, j, k) + u(i, j + 1, k) + u(i, j, k + 1)) * factors(4) + &
                                  (u(i + 2, j, k) + u(i, j + 2, k) + u(i, j, k + 2)) * factors(5)

    end subroutine derivative_halo_gpu_kernel

        subroutine derivative_halo_gpu_dev(u,du,n1,n2,n3,factors)
                integer,value,intent(in)::n1,n2,n3
                real*8::u(-1:n1+2,-1:n2+2,-1:n3+2)
                real*8::du(n1,n2,n3),factors(5)
                integer::block_size(3)
                type(dim3) :: grid_sp,block_sp
                block_size(1)=32;block_size(2)=4;block_size(3)=4
                block_sp   = dim3(block_size(1),block_size(2),block_size(3))
                grid_sp    = dim3(n1/block_sp%x,n2/block_sp%y,n3/block_sp%z)
                !$acc host_data use_device(u,du,factors)
                !!$acc data present(u,du,factors)
                call derivative_halo_gpu_kernel<<<grid_sp,block_sp>>>(u,du,n1,n2,n3,factors)
!! CHECK THIS::                call cuda_get_last_error()
                !$acc wait
                !!$acc end data
                !$acc end host_data
        end subroutine derivative_halo_gpu_dev

end module derivative_mod_gpu


!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------- MISFIT ROUTINES ------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
module misfit

public :: misfit_rms
public :: misfit_chi2

!==================================================================================================!
contains
!==================================================================================================!

subroutine misfit_rms(obs,pre,n,rms)
!----
! Calculate the root-mean-squared misfit between an observed and predicted set of points:
!
!     RMS = sqrt(sum((obs-pre)^2)/n)
!-----

use io, only: stderr

implicit none

! Arguments
integer :: n
double precision :: obs(n), pre(n), rms

! Local variables
integer :: i
double precision :: dif(n)

! Check that n is greater than zero
if (n.le.0) then
    write(stderr,*) 'misfit_rms: n is less than or equal to zero'
endif

! Initialize RMS misfit
rms = 0.0d0

! Add differences squared to RMS
do i = 1,n
    dif(i) = obs(i)-pre(i)
    dif(i) = dif(i)*dif(i)
    rms = rms + dif(i)
enddo

! Take square root
rms = sqrt(rms/n)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine misfit_chi2(obs,pre,cov,isCovMatrixDiagonal,n,chi2)
!----
! Calculate the chi-squared misfit between an observed and predicted set of points:
!
!     chi2 = dif_tr * cov_mat^(-1) * dif
!
! where
!
!     dif = obs-pre
!     dif_tr = transpose(dif)
!     cov_mat = covariance matrix
!-----

#ifdef USE_LAPACK
use solver, only: solve_dsysv
#endif

use io, only: stderr

implicit none

! Arguments
integer :: n
double precision :: obs(n), pre(n), cov(n,n), chi2
logical :: isCovMatrixDiagonal

! Local variables
integer :: i, ierr
double precision :: dif(n), vec(n)

! Check that n is greater than zero
if (n.le.0) then
    write(stderr,*) 'misfit_chi2: n is less than or equal to zero'
endif

! Initialize chi-squared value
chi2 = 0.0d0

! Calculate difference between observed and predicted
dif = obs-pre

! Calculate dif_trans*cov^(-1)*dif
if (isCovMatrixDiagonal) then
    do i = 1,n
        chi2 = chi2 + dif(i)*dif(i)/cov(i,1)
    enddo
else

#ifdef USE_LAPACK
    call solve_dsysv(cov,dif,vec,n,ierr)
    do i = 1,n
        chi2 = chi2 + dif(i)*vec(i)
    enddo
#else
    call usage('misfit_chi2: cannot calculate chi-squared for non-diagonal covariance matrix '//&
               'without LAPACK')
#endif

endif

return
end subroutine

end module


program operations

    implicit none
    real(kind=4)                 :: blas1_result
    real(kind=4), dimension(3)   :: v, w, blas2_result
    real(kind=4), dimension(3,3) :: A, B, blas3_result
    integer                      :: i, j, k
    real                         :: start
    real                         :: finish

    interface
        subroutine vector_vector_multiply(v, w, result)
            implicit none
            real(kind=4), dimension(:), intent(in) :: v
            real(kind=4), dimension(:), intent(in) :: w
            real(kind=4), intent(out)              :: result
        end subroutine

        subroutine matrix_vector_multiply(A, v, result)
            implicit none
            real(kind=4), dimension(:,:), intent(in)  :: A
            real(kind=4), dimension(:)  , intent(in)  :: v
            real(kind=4), dimension(:)  , intent(out) :: result
        end subroutine

        subroutine matrix_matrix_multiply(A, B, result)
            implicit none
            real(kind=4), dimension(:,:), intent(in)  :: A
            real(kind=4), dimension(:,:), intent(in)  :: B
            real(kind=4), dimension(:,:), intent(out) :: result
        end subroutine
    end interface

    do i = 1, size(v)
        v(i) = i
        w(i) = i+1
    end do

    do i = 1, size(A(:,1))
        do j = 1, size(A(1,:))
            A(i,j) = i
            B(i,j) = i+1
        end do
    end do

    ! Memory requirements
    print *, "Memory occupied v = ", sizeof(v), " bytes"
    print *, "Memory occupied A = ", sizeof(A), " bytes"

    ! Values stored
    print *, "v = [ "
    do i = 1, size(v)
        print *, v(i)
    end do
    print *, " ]."

    print *, "w = [ "
    do i = 1, size(w)
        print *, w(i)
    end do
    print *, " ]."

    print *, "A = [ "
    do i = 1, size(A(:,1))
        print *, A(i,:)
    end do
    print *, " ]."

    print *, "B = [ "
    do i = 1, size(B(:,1))
        print *, B(i,:)
    end do
    print *, " ]."

    ! Intrinsic Fortran operations
    start  = 0.
    finish = 0.
    call cpu_time(start)
    blas1_result = dot_product(v, w)
    blas3_result = matmul(A, B)
    call cpu_time(finish)

    print '("CPU time dot_product, matmul = ",f12.10," seconds.")', finish-start
    print *, "intrinsic dot_product(v, w) = ", blas1_result
    print *, "intrinsic matmul(A, B) = [ "
    do i = 1, size(blas3_result(:,1))
        print *, blas3_result(i,:)
    end do
    print *, " ]"

    ! Coded BLAS operations
    start  = 0.
    finish = 0.
    call cpu_time(start)
    call vector_vector_multiply(v, w, blas1_result)
    call cpu_time(finish)
    print '("CPU time blas 1 = ",f12.10," seconds.")', finish-start

    start  = 0.
    finish = 0.
    call cpu_time(start)
    call matrix_vector_multiply(A, v, blas2_result)
    call cpu_time(finish)
    print '("CPU time blas 2 = ",f12.10," seconds.")', finish-start

    start  = 0.
    finish = 0.
    call cpu_time(start)
    call matrix_matrix_multiply(A, B, blas3_result)
    call cpu_time(finish)
    print '("CPU time blas 3 = ",f12.10," seconds.")', finish-start

    print *, "BLAS 1 = ", blas1_result
    print *, "BLAS 2 = [ "
    do i = 1, size(blas2_result)
        print *, blas2_result(i)
    end do
    print *, " ]."
    print *, "BLAS 3 = [ "
    do i = 1, size(blas3_result(:,1))
        print *, blas3_result(i,:)
    end do
    print *, " ]"

end program operations

!! BLAS 1 operation
subroutine vector_vector_multiply(v, w, result)
    implicit none
    real(kind=4), dimension(:), intent(in) :: v
    real(kind=4), dimension(:), intent(in) :: w
    real(kind=4), intent(out)              :: result
    integer                                :: i

    result = 0.
    do i = 1, size(v)
        result = result + v(i) * w(i)
    end do

end subroutine

!! BLAS 2 operation
subroutine matrix_vector_multiply(A, v, result)
    implicit none
    real(kind=4), dimension(:,:), intent(in)  :: A
    real(kind=4), dimension(:)  , intent(in)  :: v
    real(kind=4), dimension(:)  , intent(out) :: result
    integer                                   :: i, j

    result = 0.
    do i = 1, size(A(:,1))
        do j = 1, size(A(1,:))
            result(i) = result(i) + A(i,j) * v(j)
        end do
    end do

end subroutine

!! BLAS 3 operation
subroutine matrix_matrix_multiply(A, B, result)
    implicit none
    real(kind=4), dimension(:,:), intent(in)  :: A
    real(kind=4), dimension(:,:), intent(in)  :: B
    real(kind=4), dimension(:,:), intent(out) :: result
    integer                                   :: i, j, k

    result = 0.
    do k = 1, size(A(:,1))
        do i = 1, size(A(:,1))
            do j = 1, size(A(1,:))
                result(i,k) = result(i,k) + A(i,j) * B(j,i)
            end do
        end do
    end do

end subroutine


program main
    use MathClass
    use ArrayClass
    use LinearSolverClass
    implicit none

    integer(int32) :: i, num_data,sampling_rate
    real(real64),allocatable :: coeff(:),fit_coeff(:)
    real(real64),allocatable :: true_answer(:)
    real(real64),allocatable :: training_data(:,:)

    real(real64) :: err
    type(IO_) :: f
    type(Random_) :: random

    ! create training data
    true_answer = [0.5d0,100.0d0,0.10d0, 1.0d0, 200.0d0, -0.20d0]
    call f%open("step_response.txt","w")
    num_data = 50000
    sampling_rate = 100 !Hz

    do i=1,num_data
        write(f%fh,*) dble(i-1)/dble(sampling_rate) ,&
            offset_function(t=dble(i-1)/dble(sampling_rate) ,params=true_answer)&
            +random%gauss(mu=0.0d0,sigma=0.010d0)
    enddo

    call f%close()
    call f%plot(option="with lines")

    ! read training data
    training_data = zeros(num_data,2)
    call f%open("step_response.txt")
    do i=1,size(training_data,1)
        read(f%fh,*) training_data(i,1:2)
    enddo
    call f%close()

    ! initial guess
    !(1)coeff = [0.3d0,50.0d0,0.00d0, 1.0d0, 200.0d0, 0.00d0]
    coeff =          [0.10d0,  100.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  200.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  300.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  400.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  500.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  600.0d0,  0.0d0]
    coeff = coeff // [0.10d0,  700.0d0,  0.0d0]

    ! fitting by Robbin-Monro algorithm (SGD)
    do i_i=1,10000

        fit_coeff = fit(f=offset_function,training_data=training_data, params=coeff ,&
            eta=0.00001d0,max_itr=30, error=err,use_ratio=0.0000030d0,logfile="SGD.log")
        coeff = fit_coeff
        print *, fit_coeff(:)

        call f%open("SGD_fit.txt","w")
        do i=0,num_data
            call f%write(dble(i)/100.0d0, offset_function(t=dble(i)/100.0d0,params=fit_coeff ) )
        enddo
        call f%close()

    enddo
    ! show result
    call f%open("training_data.txt","w")
    do i=1,size(training_data,1)
        call f%write(training_data(i,1), training_data(i,2) )
    enddo
    call f%close()

    print *, "--- check ---"

    print *, fit_coeff(:)
    print *, true_answer(:)

contains

real(real64) function offset_function(t,params)
    real(real64),intent(in) :: t
    real(real64),intent(in) :: params(:)
    integer(int32) :: n
    integer(int32) :: ii

    n = (size(params) - mod(size(params),3))/3
    offset_function = 0.0d0

    do ii=1,n
        offset_function = offset_function + sigmoid(x=t,params=params( (ii-1)*3+1:(ii-1)*3+3 ) )
    enddo

end function

end program main


module matrix_simple_mod
  implicit none

! define a new type mat_obj
  type mat_obj
    integer :: N=0
    integer :: M=0
    real, dimension(:,:), pointer :: A => null()
    contains
     procedure :: create => createMat
     procedure :: free => freeMat
  end type mat_obj

CONTAINS

subroutine createMat(mat, N,M)
 implicit none
! create a new object mat of type mat_obj
 class(mat_obj), intent(inout)       :: mat
 integer, intent(in) :: N,M

print*, "create"
 mat%N=N
 mat%M=M
 print*, N,M
 allocate(mat%A(mat%N,mat%M))
!initialize mat with random numbers
 call random_number(mat%A)
! The matrix can be big so we
! write 4 elements only mat%A(1,1),     mat%A(mat%N,1)
!                       mat%A(1,mat%M), mat(mat%N, mat%M)
 print*, mat%A( (/1,mat%N /), (/1, mat%M /) )
end subroutine createMat

subroutine freeMat(mat)
 implicit none
! create a new object mat of tpye mat_obj
 class(mat_obj)       :: mat
 deallocate( mat%A )
end subroutine freeMat
end module matrix_simple_mod


PROGRAM doy

!  Purpose:
!    This program calculates the day of year corresponding to a
!    specified date.  It illustrates the use of counting loops
!    and the SELECT CASE construct.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/13/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
INTEGER :: day         ! Day (dd)
INTEGER :: day_of_year ! Day of year
INTEGER :: i           ! Index variable
INTEGER :: leap_day    ! Extra day for leap year
INTEGER :: month       ! Month (mm)
INTEGER :: year        ! Year (yyyy)

! Get day, month, and year to convert
WRITE (*,*) 'This program calculates the day of year given the '
WRITE (*,*) 'current date.  Enter current month (1-12), day(1-31),'
WRITE (*,*) 'and year in that order:  '
READ (*,*) month, day, year

! Check for leap year, and add extra day if necessary
IF ( MOD(year,400) == 0 ) THEN
   leap_day = 1           ! Years divisible by 400 are leap years
ELSE IF ( MOD(year,100) == 0 ) THEN
   leap_day = 0           ! Other centuries are not leap years
ELSE IF ( MOD(year,4) == 0 ) THEN
   leap_day = 1           ! Otherwise every 4th year is a leap year
ELSE
   leap_day = 0           ! Other years are not leap years
END IF

! Calculate day of year
day_of_year = day
DO i = 1, month-1

   ! Add days in months from January to last month
   SELECT CASE (i)
   CASE (1,3,5,7,8,10,12)
      day_of_year = day_of_year + 31
   CASE (4,6,9,11)
      day_of_year = day_of_year + 30
   CASE (2)
      day_of_year = day_of_year + 28 + leap_day
   END SELECT

END DO

! Tell user
WRITE (*,*) 'Day         = ', day
WRITE (*,*) 'Month       = ', month
WRITE (*,*) 'Year        = ', year
WRITE (*,*) 'day of year = ', day_of_year

END PROGRAM doy


!*****************************************************************************************
!> author: Jacob Williams
!  date: 4/14/2015
!  license: BSD
!
!  Unit test for [[pyplot_module]].

    program test

    use, intrinsic :: iso_fortran_env, only : wp => real64
    use pyplot_module, only : pyplot

    implicit none

    integer,parameter :: n = 100

    real(wp), dimension(n)   :: x     !! x values
    real(wp), dimension(n)   :: y     !! y values
    real(wp), dimension(n)   :: yerr  !! error values for bar chart
    real(wp), dimension(n)   :: sx    !! sin(x) values
    real(wp), dimension(n)   :: cx    !! cos(x) values
    real(wp), dimension(n)   :: zx    !!
    real(wp), dimension(n)   :: tx    !! sin(x)*cos(x) values
    real(wp), dimension(n,n) :: z     !! z matrix for contour plot
    type(pyplot)             :: plt   !! pytplot handler
    integer                  :: i     !! counter
    integer                  :: j     !! counter
    real(wp)                 :: r2    !! temp variable
    real(wp), dimension(n,n) :: mat   !! image values
    integer                  :: istat !! status code

    real(wp),parameter :: pi = acos(-1.0_wp)
    real(wp),parameter :: deg2rad = pi/180.0_wp

    !generate some data:
    x    = [(real(i,wp), i=0,size(x)-1)]/5.0_wp
    sx   = sin(x)
    cx   = cos(x)
    tx   = sx * cx
    zx   = 0.0_wp
    yerr = abs(sx*.25_wp)

    do i=1,n
        do j=1,n
            mat(i,j) = sin(real(i,wp)*real(j,wp))
        end do
    end do

    !2d line plot:
    call plt%initialize(grid=.true.,xlabel='angle (rad)',figsize=[20,10],&
                        title='plot test',legend=.true.,axis_equal=.true.,&
                        tight_layout=.true.)
    call plt%add_plot(x,sx,label='$\sin (x)$',linestyle='b-o',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x,cx,label='$\cos (x)$',linestyle='r-o',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x,tx,label='$\sin (x) \cos (x)$',linestyle='g-o',markersize=2,linewidth=1,istat=istat)
    call plt%savefig('plottest.png', pyfile='plottest.py',istat=istat)

    !bar chart:
    tx = 0.1_wp !for bar width
    call plt%initialize(grid=.true.,xlabel='angle (rad)',&
                        title='bar test',legend=.true.,figsize=[20,10],&
                        font_size = 20,&
                        axes_labelsize = 20,&
                        xtick_labelsize = 20,&
                        ytick_labelsize = 20,&
                        legend_fontsize = 20 )
    call plt%add_bar(x=x,height=sx,width=tx,label='$\sin (x)$',&
                        color='r',yerr=yerr,xlim=[0.0_wp, 20.0_wp],align='center',istat=istat)
    call plt%savefig('bartest.png', pyfile='bartest.py',istat=istat)

    !contour plot:
    x = [(real(i,wp), i=0,n-1)]/100.0_wp
    y = [(real(i,wp), i=0,n-1)]/100.0_wp
    do i=1,n
        do j=1,n
            r2 = x(i)**2 + y(j)**2
            z(i,j) = sin(x(i))*cos(y(j))*sin(r2)/(1.0_wp+log(r2+1.0_wp))
        end do
    end do
    call plt%initialize(grid=.true.,xlabel='x angle (rad)',&
                        ylabel='y angle (rad)',figsize=[10,10],&
                        title='Contour plot test', real_fmt='*',&
                        axisbelow=.false.)
    call plt%add_contour(x, y, z, label='contour', linestyle='-', &
                         linewidth=2, filled=.true., cmap='bone', colorbar=.true.,&
                         istat=istat)
    call plt%savefig('contour.png',pyfile='contour.py',istat=istat)

    !image plot:
    call plt%initialize(grid=.true.,xlabel='x',ylabel='y',figsize=[20,20],&
                        title='imshow test',&
                        real_fmt='(F9.3)')
    call plt%add_imshow(mat,xlim=[0.0_wp, 100.0_wp],ylim=[0.0_wp, 100.0_wp],istat=istat)
    call plt%savefig('imshow.png', pyfile='imshow.py',istat=istat)

    !histogram chart:
    x = [0.194,0.501,-1.241,1.425,-2.217,-0.342,-0.979,0.909,0.994,0.101,       &
         -0.131,-0.627,0.463,1.404,0.036,-2.000,0.109,1.250,-1.035,-1.115,      &
          0.935,0.496,1.100,0.770,-1.307,-0.693,-0.072,-1.331,-0.701,           &
         -0.494,0.666,-0.313,-0.430,-0.654,1.638,-0.334,-0.418,0.550,-0.034,    &
          0.473,0.704,0.801,-0.157,0.055,-0.057,-1.049,-1.022,0.495,0.756,      &
          0.149,0.543,-0.813,-0.171,-0.994,-1.532,0.502,1.324,-0.593,-0.467,    &
          0.372,-0.904,1.255,0.931,-0.779,1.529,-0.036,0.783,0.292,-0.792,      &
          -0.223,-0.325,0.225,-0.492,-0.941,0.065,1.300,-1.241,-1.124,-0.499,   &
          1.233,-0.845,-0.948,-1.060,1.103,-1.154,-0.594,0.335,-1.423,0.571,    &
         -0.903,1.129,-0.372,-1.043,-1.327,0.147,1.056,1.068,-0.699,0.988,-0.630]

    call plt%initialize(grid=.true.,xlabel='x',&
                        title='hist test',&
                        legend=.true.,figsize=[20,10],&
                        font_size = 20,&
                        axes_labelsize = 20,&
                        xtick_labelsize = 20,&
                        ytick_labelsize = 20,&
                        legend_fontsize = 20 )

    call plt%add_hist(x=x, label='x', normed=.true.,istat=istat)
    call plt%savefig('histtest1.png', pyfile='histtest1.py',istat=istat)

    call plt%initialize(grid=.true.,xlabel='x',&
                        title='cumulative hist test',&
                        legend=.true.,figsize=[20,10],&
                        font_size = 20,&
                        axes_labelsize = 20,&
                        xtick_labelsize = 20,&
                        ytick_labelsize = 20,&
                        legend_fontsize = 20 )

    call plt%add_hist(x=x, label='x', bins=8, cumulative=.true.,istat=istat)
    call plt%savefig('histtest2.png', &
                        pyfile='histtest2.py', &
                        dpi='200', &
                        transparent=.true.,istat=istat)

    !3D plot:
    call plt%initialize(grid=.true.,&
                        xlabel='x (km)',ylabel='y (km)',zlabel='z (km)',&
                        title='Orbit',&
                        axis_equal=.true.,&
                        mplot3d=.true.,&
                        figsize=[20,10])

    x    = [(real(i,wp), i=0,size(x)-1)]/5.0_wp
    sx   = 7000.0_wp * cos(x * deg2rad)
    cx   = 7000.0_wp * sin(x * deg2rad)
    zx = 0.0_wp
    call plt%add_3d_plot(sx,cx,zx,&
                            label='orbit',linestyle='r-',&
                            linewidth=2,istat=istat)
    call plt%add_sphere(6378.0_wp,0.0_wp,0.0_wp,0.0_wp,&
                        color='Blue',n_facets=500,&
                        antialiased=.true.,istat=istat)
    call plt%savefig('orbit.png', &
                      pyfile='orbit.py', &
                      dpi='200', &
                      transparent=.true.,istat=istat)

    end program test
!*****************************************************************************************


module quadglobal
use mpmodule
implicit none
integer ndebug, nerror, nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2, &
  nwords1, nwords2
end module

program tquaderf

!   David H. Bailey      2004-08-14
!   This is the ARPREC Fortran-90 version.

!   This software is provided for research purposes only.
!   Commercial usage requires license agreement.

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.

!   This program demonstrates the quadrature routine 'quaderf', which employs
!   the error function.  The function quaderf is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   finite open interval.  It can also be used for certain integrals on
!   infinite intervals, by making a suitable change of variable -- see below.
!   While this routine is not quite as efficient as quadgs for functions that
!   are regular on a closed interval, it can be used for functions with an
!   integrable singularity at one or both of the endpoints.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Note that an integral of a function on an infinite interval can be
!   converted to an integral on a finite interval by means of a suitable
!   change of variable.  Example (here the notation "inf" means infinity):

!   Int_0^inf f(t) dt  =  Int_0^1 f(t) dt + Int_1^inf f(t) dt
!                      =  Int_0^1 f(t) dt + Int_0^1 f(1/t)/t^2 dt

!   Inputs set in parameter statement below:
!   kdebug Debug level setting.  Default = 2.
!   ndp1   Primary working precision, in digits; may not exceed mpipl in
!          mp_mod.f.
!   ndp2   Secondary working precision, in digits; may not exceed mpipl in
!          mp_mod.f.  By default, ndp2 = ndp1.  For some problems, it is
!          necessary to set ndp2 > ndp1, typically ndp2 = 2*ndp1, to obtain
!          a result accurate to ndp1 digits.  Look for message from quaderf.
!   neps1  Log10 of the primary tolerance.  By default, neps1 = - ndp1.
!   neps2  Log10 of the secondary tolerance.  By default, neps2 = - ndp2.
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!          (possibly doubles) the number of accurate digits in the result,
!          but also roughly doubles the run time.  nq1 must be at least 2.
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!          default it is set to 12 * 2^nq1.  Increase nq2 if directed by a
!          message produced in initqerf.  Note that the dimension of the
!          wk and xk arrays starts with -1, so the length of these arrays is
!          (nq2+2) * (mpwds+5) eight-byte words.

use mpmodule
use mpmodulex
use quadglobal
implicit none
save
integer i, kdebug, ndp1, ndp2, neps1, neps2, nq1, nq2, n1
parameter (kdebug = 2, ndp1 = 400, ndp2 = 800, neps1 = -ndp1, neps2 = -ndp2, &
  nq1 = 10, nq2 = 12 * 2 ** nq1)
double precision dplog10q, d1, d2, second, tm0, tm1
type (mp_real) err, quaderf, fun01, fun02, fun03, fun04, fun05, fun06, fun07, &
  fun08, fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, &
  t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2)
type (mp_realx) x1, x2
external quaderf, fun01, fun02, fun03, fun04, fun05, fun06, fun07, fun08, &
  fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, second

call mpinit (ndp1)
call mpinitx (ndp2)
call mpsetprec (ndp1)
call mpgetprecwords (nwords1)
call mpsetprec (ndp2)
call mpgetprecwords (nwords2)
call mpsetprecwords (nwords1)
ndigits1 = ndp1
ndigits2 = ndp2
nepsilon1 = neps1
nepsilon2 = neps2
mpoud = ndp1
ndebug = kdebug
nerror = 0
nquadl = nq1
write (6, 1) nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2
1 format ('Quaderf test:  Quadlevel =',i6/'Digits1 =',i6,'  Digits2 =',i6, &
  '  Epsilon1 =',i6,' Epsilon2 =',i6)

!   Initialize quadrature tables wk and xk (weights and 1 - abscissas).

tm0 = second ()
call initqerf (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite itervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun01, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call mpwrite (6, t1)
t2 = 0.25d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun02, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = (mppic - 2.d0 + 2.d0 * mpl02) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)')
call mpsetprecwords (nwords2)
x1 = 0.d0
x2 = 0.5d0 * mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quaderf (fun03, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * (exp (0.5d0 * mppic) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun04, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 5.d0 * mppic**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 15)
15 format (/&
  'Continuous functions on finite itervals, but non-diff at an endpoint'// &
  'Problem 5: Int_0^1 sqrt(t)*log(t) dt = -4/9')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun05, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = mpreal (-4.d0) / 9.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 16)
16 format (/'Problem 6: Int_0^1 sqrt(1-t^2) dt = pi/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun06, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.25d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 17)
17 format (/&
  'Functions on finite intervals with integrable singularity at an endpoint.'//&
  'Problem 7: Int_0^1 sqrt(t)/sqrt(1-t^2) dt = 2*sqrt(pi)*gamma(3/4)/gamma(1/4)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun07, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 2.d0 * sqrt (mppic) * gamma (mpreal (0.75d0)) / gamma (mpreal (0.25d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 18)
18 format (/'Problem 8: Int_0^1 log(t)^2 dt = 2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun08, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 2.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 19)
19 format (/'Problem 9: Int_0^(pi/2) log(cos(t)) dt = -pi*log(2)/2')
call mpsetprecwords (nwords2)
x1 = 0.d0
x2 = 0.5d0 * mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quaderf (fun09, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = -0.5d0 * mppic * mpl02
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 20)
20 format (/'Problem 10: Int_0^(pi/2) sqrt(tan(t)) dt = pi*sqrt(2)/2')
call mpsetprecwords (nwords2)
x1 = 0.d0
x2 = 0.5d0 * mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quaderf (fun10, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic * sqrt (mpreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 21)
21 format (/&
  'Functions on an infinite interval (requiring a two-step solution'//&
  'Problem 11: Int_0^inf 1/(1+t^2) dt = pi/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun11, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 22)
22 format (/'Problem 12: Int_0^inf e^(-t)/sqrt(t) dt = sqrt(pi)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun12, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 23)
23 format (/'Problem 13: Int_0^inf e^(-t^2/2) dt = sqrt(pi/2)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun13, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (0.5d0 * mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 24)
24 format (/&
  'Oscillatory functions on an infinite interval.'//&
  'Problem 14: Int_0^inf e^(-t)*cos(t) dt = 1/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quaderf (fun14, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/'Problem 15: Int_0^inf sin(t)/t = pi/2')
call mpsetprecwords (nwords2)
x1 = 0.d0
x2 = mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quaderf (fun15a, x1, x2, nq1, nq2, wk, xk)
x2 = 1.d0 / mppic
t2 = quaderf (fun15b, x1, x2, nq1, nq2, wk, xk)
t3 = t1 + 40320.d0 * t2 - 1.d0 / mppic + 2.d0 / mppic ** 3 &
  - 24.d0 / mppic ** 5 + 720.d0 / mppic ** 7
tm1 = second ()
write (6, 3) tm1 - tm0
t4 = 0.5d0 * mppic
call decmdq (t4 - t3, d1, n1)
write (6, 4) d1, n1
write (6, 26)
26 format ('Prob 15 error may be 40,000 X higher than estimated error.')

stop
end

function fun01 (t)

!   fun01(t) = t * log(1+t)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun01, t1
type (mp_realx) t

t1 = t
fun01 = t1 * log (1.d0 + t1)
return
end

function fun02 (t)

!   fun02(t) = t^2 * arctan(t)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun02, t1
type (mp_realx) t

t1 = t
fun02 = t1 ** 2 * atan (t1)
return
end

function fun03 (t)

!   fun03(t) = e^t * cos(t)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun03, t1
type (mp_realx) t

t1 = t
fun03 = exp(t1) * cos(t1)
return
end

function fun04 (t)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun04, t1, t2
type (mp_realx) t

t1 = t
t2 = sqrt (2.d0 + t1**2)
fun04 = atan(t2) / ((1.d0 + t1**2) * t2)
return
end

function fun05 (t)

!    fun05(t) = sqrt(t)*log(t)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun05, t1
type (mp_realx) t

t1 = t
if (t1 >= 0.d0) then
  fun05 = sqrt (t1) * log (t1)
else
  fun05 = 0.d0
endif
return
end

function fun06 (t)

!    fun06(t) = sqrt(1-t^2)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun06, t1
type (mp_realx) t

t1 = t
if (t1 <= 1.d0) then
  fun06 = sqrt (1.d0 - t1**2)
else
  fun06 = 0.d0
endif
return
end

function fun07 (t)

!   fun07(t) = sqrt (t) / sqrt(1-t^2)

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun07, t1, t2
type (mp_realx) t

t1 = t
call mpsetprecwords (nwords2)
t2 = 1.d0 - t
call mpsetprecwords (nwords1)
if (t1 >= 0.d0 .and. t2 > 0.d0) then
  fun07 = sqrt (t1) / sqrt (t2 * (1.d0 + t1))
else
  fun07 = 0.d0
endif
return
end

function fun08 (t)

!   fun08(t) = log(t)^2

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun08, t1
type (mp_realx) t

t1 = t
if (t1 > 0.d0) then
  fun08 = log (t1) ** 2
else
  fun08 = 0.d0
endif
return
end

function fun09 (t)

!   fun09(t) = log (cos (t))

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun09, t1, t2
type (mp_realx) t

t1 = t
if (t1 < 0.25d0 * mppic) then
  fun09 = log (cos (t1))
else
  call mpsetprecwords (nwords2)
  t2 = 0.5d0 * mppicx - t
  call mpsetprecwords (nwords1)
  if (t2 > 0.d0) then
    fun09 = log (sin (t2))
  else
    fun09 = 0.d0
  endif
endif
return
end

function fun10 (t)

!   fun10(t) = sqrt(tan(t))

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun10, t1, t2
type (mp_realx) t

t1 = t
if (t1 < 0.25d0 * mppic) then
  fun10 = sqrt (tan (t1))
else
  call mpsetprecwords (nwords2)
  t2 = 0.5d0 * mppicx - t
  call mpsetprecwords (nwords1)
  if (t2 > 0.d0) then
    fun10 = 1.d0 / sqrt (tan (t2))
  else
    fun10 = 0.d0
  endif
endif
return
end

function fun11 (t)

!   fun11(t) = 1/(u^2(1+(1/u-1)^2)) = 1/(1 - 2*u + u^2)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun11, t1
type (mp_realx) t

t1 = t
fun11 = 1.d0 / (1.d0 - 2.d0 * t1 + 2.d0 * t1 ** 2)
return
end

function fun12 (t)

!   fun12(t) = e^(-(1/t-1)) / sqrt(t^3 - t^4)

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun12, t1, t2
type (mp_realx) t

t1 = t
call mpsetprecwords (nwords2)
t2 = 1.d0 - t
call mpsetprecwords (nwords1)
if (t1 > 0.d0 .and. t2 > 0.d0) then
  fun12 = exp (1.d0 - 1.d0/t1) / sqrt (t1 ** 3 * t2)
else
  fun12 = 0.d0
endif
return
end

function fun13 (t)

!   fun13(t) = e^(-(1/t-1)^2/2) / t^2

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun13, t1, t2
type (mp_realx) t

t1 = t
if (t1 > 0.25d0 / sqrt (dble (ndigits1))) then
  t2 = 1.d0 / t1 - 1.d0
  fun13 = exp (-0.5d0 * t2 ** 2) / t1 ** 2
else
  fun13 = 0.d0
endif
return
end

function fun14 (t)

!   fun14(t) = e^(-(1/t-1)) * cos (1/t-1) / t^2

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun14, t1, t2
type (mp_realx) t

t1 = t
if (t1 > 0.25d0 / ndigits1) then
  t2 = 1.d0 / t1 - 1.d0
  fun14 = exp (-t2) * cos (t2) / t1 ** 2
else
  fun14 = 0.d0
endif
return
end

function fun15a (t)

!   fun15a(t) = sin(t)/t

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun15a, t1
type (mp_realx) t

t1 = t
fun15a = sin (t1) / t1
return
end

function fun15b (t)

!   fun15b(t) = t^7 * sin(1/t)

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun15b, t1
type (mp_realx) t
real*8 dplog10q
external dplog10q

t1 = t
if (-dplog10q (t1) < ndigits1) then
  fun15b = t1**7 * sin (1.d0 / t1)
else
  fun15b = 0.d0
endif
return
end

subroutine initqerf (nq1, nq2, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk using the
!   function x(t) = erf(t) = 1 - erfc(t).  The argument nq2 is the space
!   allocated for wk and xk in the calling program.  By default it is set to
!   12 * 2^nq1.  Increase nq2 if directed by a message produced below.
!   Upon completion, wk(-1) = nq1, and xk(-1) = n, the maximum space parameter
!   for these arrays.  In other words, the arrays occupy (wk(i), i = -1 to n)
!   and (xk(i), i = -1 to n), where n = xk(-1).   The array x_k contains
!   1 minus the abscissas; the wk array contains the weights at these abscissas.

!   David H Bailey    2004-08-14

use mpmodule
use quadglobal
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2
real*8 h
parameter (iprint = 1000)
type (mp_real) eps2, p2, spi, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqerf: Error function quadrature initialization')
endif

eps2 = mpreal (10.d0) ** nepsilon2
p2 = 0.5d0 * mppic
spi = 2.d0 / sqrt (mppic)
h = 0.5d0 ** (nq1 - 2)
wk(-1) = dble (nq1)

do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, nq2
  t1 = dble (k) * h
  xk(k) = erfc (t1)
  wk(k) = spi * exp (- t1 ** 2)
  call mpgetpar ('mpier', ierror)
  if (ierror > 0) goto 120
  if (wk(k) < eps2) goto 100
enddo

write (6, 2) nq2
2 format ('initqerf: Table space parameter is too small; value =',i8)
nerror = 91
goto 130

100 continue

xk(-1) = dble (k)
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqerf: Table spaced used =',i8)
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqerf: Error in quadrature initialization; code =',i5)

130  continue

return
end

function quaderf (fun, x1, x2, nq1, nq2, wk, xk)

!   This routine computes the integral of the function in fun on the interval
!   [x1, x2], with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   xk and wk are precomputed tables of abscissas and weights.  The function
!   fun is not evaluated at x = x1 or x2.  The array x_k contains 1 minus
!   the abscissas; the wk array contains the weights at these abscissas.

!   David H. Bailey     2004-08-14

use mpmodule
use mpmodulex
use quadglobal
implicit none
integer i, ierror, ip(0:100), iz1, iz2, izx, j, k, k1, k2, n, nds, nq1, nq2, &
  nqq1
parameter (izx = 5)
logical log1, log2
real*8 d1, d2, d3, d4, dplog10q, h
type (mp_real) c10, eps1, eps2, epsilon1, epsilon2, err, fun, &
  quaderf, tsum, s1, s2, s3, t1, t2, t3, tw1, tw2, twi1, twi2, twmx, &
  wk(-1:nq2), xk(-1:nq2)
type (mp_realx) ax, bx, x1, x2, xki, xt1, xx1, xx2
external fun, dplog10q

nds = mpoud
mpoud = 56
call mpsetprecwords (nwords2)
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
call mpsetprecwords (nwords1)
epsilon1 = mpreal (10.d0) ** nepsilon1
epsilon2 = mpreal (10.d0) ** nepsilon2
tsum = 0.d0
s1 = 0.d0
s2 = 0.d0
h = 4.d0
c10 = 10.d0

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quaderf: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 140
endif
nqq1 = dble (wk(-1))
n = dble (xk(-1))

do k = 0, nqq1
  ip(k) = 2 ** k
enddo

do k = 1, nq1
  h = 0.5d0 * h
  s3 = s2
  s2 = s1
  k1 = ip(nqq1-k)
  k2 = ip(nqq1-k+1)
  iz1 = 0
  iz2 = 0
  twmx = 0.d0

!   Evaluate function at level k in x, avoiding unnecessary computation.

  do i = 0, n, k1
    if (mod (i, k2) /= 0 .or. k == 1) then
      call mpsetprecwords (nwords2)
      xki = xk(i)
      xt1 = 1.d0 - xki
      xx1 = - ax * xt1 + bx
      xx2 = ax * xt1 + bx
      log1 = xx1 > x1
      log2 = xx2 < x2
      call mpsetprecwords (nwords1)

      if (log1 .and. iz1 < izx) then
        t1 = fun (xx1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw1 = t1 * wk(i)
        twi1 = abs (tw1)
        if (twi1 < epsilon1) then
          iz1 = iz1 + 1
        else
          iz1 = 0
        endif
      else
        t1 = 0.d0
        tw1 = 0.d0
      endif

      if (i > 0 .and. log2 .and. iz2 < izx) then
        t2 = fun (xx2)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw2 = t2 * wk(i)
        twi2 = abs (tw2)
        if (twi2 < epsilon1) then
          iz2 = iz2 + 1
        else
          iz2 = 0
        endif
      else
        t2 = 0.d0
        tw2 = 0.d0
      endif

      tsum = tsum + tw1 + tw2
      twmx = max (twmx, abs (tw1), abs (tw2))
    endif
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.
!   Twi1 and twi2 are the final nonzero values of abs(tw1) and abs(tw2).

  s1 =  ax * h * tsum
  eps1 = twmx * epsilon1
  eps2 = max (twi1, twi2)
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0
  d4 = dplog10q (eps2) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    err = c10 ** nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3, d4)))
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quaderf: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
    call mpwrite (6, s1)
  endif

  if (k >= 3 .and. err < eps1) goto 140
  if (k >= 3 .and. err < eps2) goto 120
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quaderf: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
goto 140

120 continue

write (6, 4) nint (dplog10q (abs (err))), ndigits2
4 format ('quaderf: Estimated error = 10^',i5/&
  'Increase secondary prec (Ndigits2) for greater accuracy. Current value =',i4)
goto 140

130 continue

if (ierror > 0) nerror = ierror + 100
write (6, 5) nerror
5 format ('quaderf: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quaderf = s1
mpoud = nds
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


! Program to test nested forall
program forall2
  implicit none
  integer a(4,4,2)
  integer i, j, k, n

  a(:,:,1) = reshape((/ 1, 2, 3, 4,&
                        5, 6, 7, 8,&
                        9,10,11,12,&
                       13,14,15,16/), (/4,4/))
  a(:,:,2) = a(:,:,1) + 16
  n=4
  k=1
  ! Mirror half the matrix
  forall (i=k:n)
   forall (j=1:5-i)
     a(i,j,:) = a(j,i,:)
   end forall
  end forall

  if (any (a(:,:,1) &
      .ne. reshape((/ 1, 5, 9,13,&
                      2, 6,10, 8,&
                      3, 7,11,12,&
                      4,14,15,16/),(/4,4/)))) call abort
  if (any (a(:,:,2) .ne. a(:,:,1) + 16)) call abort
end


module functions
  implicit none
contains

function binsearch_2(n,a)
  implicit none
  integer(2) :: binsearch_2,left,right,mid
  integer(2) :: n,a(:)

  left=1
  right=size(a)
  if ( n >= a(right) ) then
    binsearch_2=right
    return
  end if
  do while ( .true. )
    mid=(left+right)/2
    if ( left == mid .or. n == a(mid) ) exit
    if ( n > a(mid) ) then
      left=mid
    else
      right=mid
    end if
  end do
  binsearch_2=mid
  return
end function binsearch_2

function binsearch_8(n,a)
  implicit none
  integer(2) :: binsearch_8,left,right,mid
  integer(8) :: n,a(:)

  left=1
  right=size(a)
  if ( n >= a(right) ) then
    binsearch_8=right
    return
  end if
  do while ( .true. )
    mid=(left+right)/2
    if ( left == mid .or. n == a(mid) ) exit
    if ( n > a(mid) ) then
      left=mid
    else
      right=mid
    end if
  end do
  binsearch_8=mid
  return
end function binsearch_8

function nchoosek(n,k)
  implicit none
  integer(2) :: k,n,i,ia,ib
  integer(8) :: nchoosek
  real(8) :: A,B

  if ( k < n-k ) then
    ia=n-k+1
    ib=k
  else
    ia=k+1
    ib=n-k
  end if
  A=1;B=1
  do i=ia,n
    A=A*i
  end do
  do i=2,ib
    B=B*i
  end do
  nchoosek=A/B+0.5
  return
end function nchoosek

function complement(a,m)
  implicit none
  integer(2) :: i,j,m
  integer(2) :: a(:),c(m)
  integer(2) :: complement(m)

  c=1
  c(a)=0
  j=0
  complement=0
  do i=1,m
    if ( c(i) /= 0 ) then
      j=j+1
      complement(j)=i
    end if
  end do
  return
end function complement

function width(i_1,i_2,i_4,i_8)
  integer(1) :: width
  integer(1),optional :: i_1
  integer(2),optional :: i_2
  integer(4),optional :: i_4
  integer(8),optional :: i_8
  character(len=20) :: w

  if ( present(i_1) ) write(w,'(I20)') i_1
  if ( present(i_2) ) write(w,'(I20)') i_2
  if ( present(i_4) ) write(w,'(I20)') i_4
  if ( present(i_8) ) write(w,'(I20)') i_8
  width=len_trim(adjustl(w))
end function width

function norm(A)
  implicit none
  real(8) :: norm
  real(8) :: A(3)

  norm=dsqrt(A(1)**2+A(2)**2+A(3)**2)
  return
end function norm

function cross(A,B)
  implicit none
  real(8) :: cross(3)
  real(8) :: A(3),B(3)

  cross(1)=A(2)*B(3)-A(3)*B(2)
  cross(2)=A(3)*B(1)-A(1)*B(3)
  cross(3)=A(1)*B(2)-A(2)*B(1)
  return
end function cross

function trace(A)
  implicit none
  integer(1) :: trace,A(:,:)

  trace=A(1,1)+A(2,2)+A(3,3)
  return
end function trace

function det(A)
  implicit none
  integer(1) :: det
  integer(1) :: A(3,3)

  det=    A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
  det=det-A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
  det=det+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
  return
end function det

function det2(A)
  implicit none
  real(8) :: det2,A(2,2)

  det2=A(1,1)*A(2,2)-A(1,2)*A(2,1)
  return
end function det2

function det3(A)
  implicit none
  real(8) :: det3,A(3,3)

  det3=     A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
  det3=det3-A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
  det3=det3+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
  return
end function det3

function inverse(A)
  implicit none
  real(8) :: inverse(3,3)
  real(8) :: A(3,3)
  integer(1) :: ind(2,3),i,j

  ind(:,1)=(/ 2, 3 /)
  ind(:,2)=(/ 1, 3 /)
  ind(:,3)=(/ 1, 2 /)
  do i=1,3
    do j=1,3
      inverse(j,i)=(-1)**(i+j)*det2(A(ind(:,i),ind(:,j)))
    end do
  end do
  inverse=inverse/det3(A)
  return
end function inverse

recursive subroutine sort(A,left,right)
  implicit none
  integer(2),intent(in out) :: A(:)
  integer(2),intent(in) :: left,right
  integer(2) :: temp,t
  integer(2) :: i,j

  if ( left > right ) then
    return
  end if
  temp=A(left)
  i=left
  j=right
  do while ( i /= j )
    do while ( A(j) >= temp .and. i < j )
      j=j-1
    end do
    do while ( A(i) <= temp .and. i < j )
      i=i+1
    end do
    if ( i < j ) then
      t=A(i)
      A(i)=A(j)
      A(j)=t
    end if
  end do
  A(left)=A(i)
  A(i)=temp
  call sort(A,left,i-1_2)
  call sort(A,i+1_2,right)
end subroutine sort

end module functions


! A cellular automaton that tries to generate a BIBD
! for the given parameters
program bibd_ca

  use incidence_structure
  use utils

  implicit none

  type(IncidenceStructure) is
  integer opt_steps
  integer v,k,lmbd
  integer i,j
  real r_r,b_r
  character(100) f

  ! If the number of command line params is invalid, print instructions
  if (command_argument_count() /= 3 .and. command_argument_count() /= 4) then
     write (*,*) "Usage:"
     call get_command_argument(0,f)
     write (*,*) f ,"v k λ [opt_steps]"
     stop
  else
     call get_command_argument(1,f)
     read (f,"(I10)") v
     call get_command_argument(2,f)
     read (f,"(I10)") k
     call get_command_argument(3,f)
     read (f,"(I10)") lmbd
     if(command_argument_count() == 4) then
         call get_command_argument(4,f)
         read (f,"(I10)") opt_steps
     else
         opt_steps=0
     endif
  endif

  call seedRandomGenerator()
  call construct(is,v,k,lmbd)

  if(opt_steps > is%v * is%b) opt_steps = is%v*is%b

  call randomCA_BIBD(is,opt_steps)

  print *, "An incidence matrix for the given parameters found:"
  call writeMatrix(is)

  ! Memory cleanup
  call deconstruct(is)
end program bibd_ca

subroutine randomCA_BIBD(is, opt_steps)
  use mtmod
  use incidence_structure
  use n_opt

  implicit none

  type(IncidenceStructure) is
  integer opt_steps

  integer maxChangeFactor, changeFactor
  integer row, active_col, dormant_col
  integer i, point
  integer inc_ratio, min_dim, max_dim
  integer cfa, cfd

  integer v,r,b,k,lambda

  v=is%v
  r=is%r
  b=is%b
  k=is%k
  lambda=is%lambda

  min_dim = min(is%v, is%b)
  max_dim = max(is%v, is%b)

  maxChangeFactor = (v-1)*(abs(r-lambda)) + b

  is%incidences(1:v,1:r)=1
  call updateCache(is)

  ! Rince and repeat until BIBD
  do while(.true.)
     call increment(is%generations,1)
     if (isBIBD(is)) return
     if(nOpt(opt_steps, opt_steps, is)) return

     ! Pick a random row, and an active and a dormant cell in it
     row = randomInt(is%v)+1
     active_col = randomInt(is%b)+1
     do while(.not.active(is,row,active_col))
        active_col = randomInt(is%b)+1
     enddo

     dormant_col = randomInt(is%b)+1
     do while(.not.dormant(is,row,dormant_col))
        dormant_col = randomInt(is%b)+1
     enddo

     cfD = changeFactor(is,row,dormant_col)
     cfA = changeFactor(is,row,active_col)

     i=randomInt(maxChangefactor)
     if(i<cfD .and. i<cfA) then
        ! Exchange places
        call flip(is,row,active_col)
        call flip(is,row,dormant_col)
     endif

  enddo
end subroutine randomCA_BIBD

integer function changeFactor(is,row,col)
  use incidence_structure
  implicit none

  type(IncidenceStructure) is
  integer row,col

  integer delta
  integer i

  changefactor = 0

  ! v * (abs(lambda - r))
  do i=1, is%v
     if(i .eq. row) cycle
     delta = is%lambda - is%row_intersection(row, i)

     if(active(is,row,col).and.active(is,i,col).and.delta<0) then
        call decrement(changefactor, delta)
     else if(active(is,row,col).and.dormant(is,i,col).and.delta<0) then
        call increment(changefactor, delta)
     else if(dormant(is,row,col).and.active(is,i,col).and.delta>0) then
        call increment(changefactor, delta)
     else if(dormant(is,row,col).and.dormant(is,i,col).and.delta>0) then
        call decrement(changefactor, delta)
     endif
  enddo

  !do i=1, is%b
  !   if(i .eq. col) cycle
  !   delta = is%lambda - is%col_intersection(col, i)
  !   if(active(is,row,col).and.active(is,row,i).and.delta<0) then
  !      call decrement(changefactor, delta)
  !   else if(dormant(is,row,col).and.active(is,col,i).and.delta>0) then
  !      call increment(changefactor, delta)
  !   endif
  !enddo

  delta = is%k - is%sum_in_col(col)
  if (active(is,row,col)) then
     call decrement(changefactor, delta)
  else if (dormant(is,row,col)) then
     call increment(changefactor, delta)
  endif

  changeFactor = max(changeFactor, 0)

  return
end function changeFactor