      SUBROUTINE MATRF2(M,N,C,INDEX,ALPHA,NN,NZ,A,SNR,RNR,FEJLM)
C--------------------------------------------------------------------
C
C   PURPOSE
C   -------
C   The subroutine generates sparse (rectangular or square) matrices.
C   The dimensions of the matrix and the average number of nonzero
C   elements per row can be specified by the user. Moreover, the user
C   can also change the sparsity pattern and the condition number of the
C   matrix. The non-zero elements of the desired matrix will be
C   accumulated (in an arbitrary order) in the first NZ positions of
C   array A. The column and the row numbers of the non-zero element
C   stored in A(I), I=1,...,NZ, will be found in SNR(I) and RNR(I),
C   respectively. The matrix generated by this subroutine is of the
C   class F(M,N,C,R,ALPHA) (see reference).
C
C   Note: If A is the sparse matrix of type F(M,N,C,R,ALPHA), then
C
C           min|A(i,j)| = 1/ALPHA,
C
C           max|A(i,j)| = max(INDEX*N - N,10*ALPHA).
C
C
C   CONTRIBUTOR: Ernest E. Rothman
C                Cornell Theory Center/Cornell National Supercomputer
C                Facility.
C                e-mail address: BITNET:   eer@cornellf
C                                INTERNET: eer@cornellf.tn.cornell.edu
C
C   minor modifications by Y. Saad. April 26, 1990.
C
C   Note: This subroutine has been copied from the following reference.
C         The allowable array sizes have been changed.
C
C   REFERENCE: Zlatev, Zahari; Schaumburg, Kjeld; Wasniewski, Jerzy;
C      "A testing Scheme for Subroutines Solving Large Linear Problems",
C      Computers and Chemistry, Vol. 5, No. 2-3, pp. 91-100, 1981.
C
C
C   INPUT PARAMETERS
C   ----------------
C   M    - Integer. The number of rows in the desired matrix.
C          N < M+1 < 9000001 must be specified.
C
C   N    - Integer. The number of columns in the desired matrix.
C          21 < N < 9000001 must be specified.
C
C   C    - Integer. The sparsity pattern can be changed by means of this
C          parameter.  10 < C < N-10  must be specified.
C
C   INDEX - Integer.  The average number of non-zero elements per row in
C           the matrix will be equal to INDEX.
C           1 < INDEX < N-C-8 must be specified.
C
C   ALPHA - Real. The condition number of the matrix can be changed
C           BY THIS PARAMETER. ALPHA > 0.0 MUST BE SPECIFIED.
C           If ALPHA is approximately equal to 1.0 then the generated
C           matrix is well-conditioned. Large values of ALPHA will
C           usually produce ill-conditioned matrices. Note that no
C           round-off errors during the computations in this subroutine
C           are made if ALPHA = 2**I (where I is an arbitrary integer
C           which produces numbers in the machine range).
C
C   NN    - Integer. The length of arrays A, RNR, and SNR (see below).
C           INDEX*M+109 < NN < 9000001 must be specified.
C
C
C   OUTPUT PARAMETERS
C   -----------------
C   NZ    - Integer. The number of non-zero elements in the matrix.
C
C   A(NN) - Real array. The non-zero elements of the matrix generated
C           are accumulated in the first NZ locations of array A.
C
C   SNR(NN) - INTEGER array. The column number of the non-zero element
C           kept in A(I), I=1,...NZ, is stored in SNR(I).
C
C   RNR(NN) - Integer array. The row number of the non-zero element
C           kept in A(I), I=1,...NZ, is stored in RNR(I).
C
C   FEJLM - Integer. FEJLM=0 indicates that the call is successful.
C           Error diagnostics are given by means of positive values of
C           this parameter as follows:
C             FEJLM = 1    -  N       is out of range.
C             FEJLM = 2    -  M       is out of range.
C             FEJLM = 3    -  C       is out of range.
C             FEJLM = 4    -  INDEX   is out of range.
C             FEJLM = 5    -  NN      is out of range.
C             FEJLM = 7    -  ALPHA   is out of range.
C
C
C
C
      REAL*8 A, ALPHA, ALPHA1
      INTEGER M, N, NZ, C, NN, FEJLM, M1, NZ1, RR1, RR2, RR3, K
      INTEGER M2, N2
      INTEGER SNR, RNR
      DIMENSION A(NN), SNR(NN), RNR(NN)
      M1 = M
      FEJLM = 0
      NZ1 = INDEX*M + 110
      K = 1
      ALPHA1 = ALPHA
      INDEX1 = INDEX - 1
C
C  Check the parameters.
C
      IF(N.GE.22) GO TO 1
2     FEJLM = 1
      RETURN
1     IF(N.GT.9000000) GO TO 2
      IF(M.GE.N) GO TO 3
4     FEJLM = 2
      RETURN
3     IF(M.GT.9000000) GO TO 4
      IF(C.LT.11)GO TO 6
      IF(N-C.GE.11)GO TO 5
6     FEJLM = 3
      RETURN
5     IF(INDEX.LT.1) GO TO 12
      IF(N-C-INDEX.GE.9)GO TO 13
12    FEJLM = 4
13    IF(NN.GE.NZ1)GO TO 7
8     FEJLM = 5
      RETURN
7     IF(NN.GT.9000000)GO TO 8
      IF(ALPHA.GT.0.0)GO TO 9
      FEJLM = 6
      RETURN
9     CONTINUE
C
C  End of the error check. Begin to generate the non-zero elements of
C  the required matrix.
C
      DO 20 I=1,N
      A(I) = 1.0d0
      SNR(I) = I
20    RNR(I) = I
      NZ = N
      J1 = 1
      IF(INDEX1.EQ.0) GO TO 81
      DO 21 J = 1,INDEX1
      J1 = -J1
      DO 22 I=1,N
      A(NZ+I) = dfloat(J1*J*I)
      IF(I+C+J-1.LE.N)SNR(NZ+I) = I + C + J - 1
      IF(I+C+J-1.GT.N)SNR(NZ+I) = C + I + J - 1 - N
22    RNR(NZ + I) = I
21    NZ = NZ + N
81    RR1 = 10
      RR2 = NZ
      RR3 = 1
25    CONTINUE
      DO 26 I=1,RR1
      A(RR2 + I) = ALPHA*dfloat(I)
      SNR(RR2+I) = N - RR1 + I
      RNR(RR2+I) = RR3
26    CONTINUE
      IF(RR1.EQ.1) GO TO 27
      RR2 = RR2 + RR1
      RR1 = RR1 - 1
      RR3 = RR3 + 1
      GO TO 25
27    NZ = NZ + 55
29    M1 = M1 - N
      ALPHA = 1.0d0/ALPHA
      IF(M1.LE.0) GO TO 28
      N2 = K*N
      IF(M1.GE.N)M2 = N
      IF(M1.LT.N)M2 = M1
      DO 30 I=1,M2
      A(NZ+I) = ALPHA*dfloat(K+1)
      SNR(NZ + I) = I
30    RNR(NZ + I) = N2 + I
      NZ = NZ + M2
      IF(INDEX1.EQ.0) GO TO 82
      J1 = 1
      DO 41 J = 1,INDEX1
      J1 = -J1
      DO 42 I = 1,M2
      A(NZ+I) = ALPHA*dFLOAT(J*J1)*(dfloat((K+1)*I)+1.0d0)
      IF(I+C+J-1.LE.N)SNR(NZ+I) = I + C + J - 1
      IF(I+C+J-1.GT.N)SNR(NZ+I) = C + I + J - 1 - N
42    RNR(NZ + I) = N2 + I
41    NZ = NZ +M2
82    K = K + 1
      GO TO 29
28    CONTINUE
      ALPHA = 1.0d0/ALPHA1
      RR1 = 1
      RR2 = NZ
35    CONTINUE
      DO 36 I = 1,RR1
      A(RR2+I) = ALPHA*dfloat(RR1+1-I)
      SNR(RR2+I) = I
      RNR(RR2+I) = N - 10 + RR1
36    CONTINUE
      IF(RR1.EQ.10) GO TO 34
      RR2 = RR2 + RR1
      RR1 = RR1 + 1
      GO TO 35
34    NZ = NZ + 55
      ALPHA = ALPHA1
      RETURN
      END
      SUBROUTINE DCN(AR,IA,JA,N,NE,IC,NN,IERR)
C-----------------------------------------------------------------------
C
C   PURPOSE
C   -------
C   The subroutine generates sparse (square) matrices of the type
C   D(N,C).  This type of matrix has the following characteristics:
C   1's in the diagonal, three bands at the distance C above the
C   diagonal (and reappearing cyclicly under it), and a 10 x 10
C   triangle of elements in the upper right-hand corner.
C   Different software libraries require different storage schemes.
C   This subroutine generates the matrix in the storage  by
C   indices mode.
C
C
C   Note: If A is the sparse matrix of type D(N,C), then
C
C       min|A(i,j)| = 1,     max|A(i,j)| = max(1000,N + 1)
C
C
C
C   CONTRIBUTOR: Ernest E. Rothman
C                Cornell Theory Center/Cornell National Supercomputer
C                Facility.
C                e-mail address: BITNET:   eer@cornellf
C                                INTERNET: eer@cornellf.tn.cornell.edu
C
C
C   REFERENCE
C   ---------
C   1) Zlatev, Zahari; Schaumburg, Kjeld; Wasniewski, Jerzy;
C      "A Testing Scheme for Subroutines Solving Large Linear Problems",
C       Computers and Chemistry, Vol. 5, No. 2-3, pp. 91-100, 1981.
C   2) Osterby, Ole and Zletev, Zahari;
C      "Direct Methods for Sparse Matrices";
C       Springer-Verlag 1983.
C
C
C
C   INPUT PARAMETERS
C   ----------------
C   N    - Integer. The size of the square matrix.
C          N > 13 must be specified.
C
C   NN   - Integer. The dimension of integer arrays IA and JA and
C          real array AR. Must be at least NE.
C
C   IC   - Integer. The sparsity pattern can be changed by means of this
C          parameter.  0 < IC < N-12  must be specified.
C
C
C   OUTPUT PARAMETERS
C   -----------------
C   NE   - Integer. The number of nonzero elements in the sparse matrix
C          of the type D(N,C). NE = 4*N + 55.
C
C   AR(NN) - Real array. (Double precision)
C            Stored entries of a sparse matrix to be generated by this
C            subroutine.
C            NN is greater then or equal to, NE, the number of
C            nonzeros including a mandatory diagonal entry for
C            each row. Entries are stored by indices.
C
C   IA(NN) - Integer array.
C            Pointers to specify rows for the stored nonzero entries
C            in AR.
C
C   JA(NN) - Integer array.
C            Pointers to specify columns for the stored nonzero entries
C            in AR.
C
C   IERR   - Error parameter is returned as zero on successful
C             execution of the subroutine.
C             Error diagnostics are given by means of positive values
C             of this parameter as follows:
C             IERR = 1    -  N       is out of range.
C             IERR = 2    -  IC      is out of range.
C             IERR = 3    -  NN      is out of range.
C
C----------------------------------------------------------------------
C
      real*8 ar(nn)
      integer ia(nn), ja(nn), ierr
      ierr = 0
c
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Check the input parameters:
c
      if(n.le.13)then
         ierr = 1
         return
      endif
      if(ic .le. 0 .or. ic .ge. n-12)then
         ierr = 2
         return
      endif
      ne = 4*n+55
      if(nn.lt.ne)then
         ierr = 3
         return
      endif
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c Begin to generate the nonzero elements as well as the row and column
c pointers:
c
      do 20 i=1,n
        ar(i) = 1.0d0
        ia(i) = i
        ja(i) = i
20    continue
      ilast = n
      do 30 i=1,n-ic
        it = ilast + i
        ar(it) = 1.0 + dfloat(i)
        ia(it) = i
        ja(it) = i+ic
30    continue
      ilast = ilast + n-ic
      do 40 i=1,n-ic-1
        it = ilast + i
        ar(it) = -dfloat(i)
        ia(it) = i
        ja(it) = i+ic+1
40    continue
      ilast = ilast + n-ic-1
      do 50 i=1,n-ic-2
        it = ilast + i
        ar(it) = 16.0d0
        ia(it) = i
        ja(it) = i+ic+2
50    continue
      ilast = ilast + n-ic-2
      icount = 0
      do 70 j=1,10
        do 60 i=1,11-j
         icount = icount + 1
         it = ilast + icount
         ar(it) = 100.0d0 * dfloat(j)
         ia(it) = i
         ja(it) = n-11+i+j
60    continue
70    continue
      icount = 0
      ilast = 55 + ilast
      do 80 i=n-ic+1,n
        icount = icount + 1
        it = ilast + icount
        ar(it) = 1.0d0 + dfloat(i)
        ia(it) = i
        ja(it) = i-n+ic
80    continue
      ilast = ilast + ic
      icount = 0
      do 90 i=n-ic,n
        icount = icount + 1
        it = ilast + icount
        ar(it) = -dfloat(i)
        ia(it) = i
        ja(it) = i-n+ic+1
90    continue
      ilast = ilast + ic + 1
      icount = 0
      do 100 i=n-ic-1,n
        icount = icount + 1
        it = ilast + icount
        ar(it) = 16.0d0
        ia(it) = i
        ja(it) = i-n+ic+2
100   continue
c     ilast = ilast + ic + 2
c     if(ilast.ne.4*n+55) then
c     write(*,*)' ilast equal to ', ilast
c     write(*,*)' ILAST, the number of nonzeros, should = ', 4*n + 55
c     stop
c     end if
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      return
      end
      SUBROUTINE ECN(N,IC,NE,IA,JA,AR,NN,IERR)
C----------------------------------------------------------------------
C
C   PURPOSE
C   -------
C   The subroutine generates sparse (square) matrices of the type
C   E(N,C).  This type of matrix has the following characteristics:
C   Symmetric, positive-definite, N x N matrices with 4 in the diagonal
C   and -1 in the two sidediagonal and in the two bands at the distance
C   C from the diagonal. These matrices are similar to matrices obtained
C   from using the five-point formula in the discretization of the
C   elliptic PDE.
C
C
C   Note: If A is the sparse matrix of type E(N,C), then
C
C       min|A(i,j)| = 1,     max|A(i,j)| = 4
C
C
C
C   CONTRIBUTOR: Ernest E. Rothman
C                Cornell Theory Center/Cornell National Supercomputer
C                Facility.
C                e-mail address: BITNET:   eer@cornellf
C                                INTERNET: eer@cornellf.tn.cornell.edu
C
C
C   REFERENCE
C   ---------
C   1) Zlatev, Zahari; Schaumburg, Kjeld; Wasniewski, Jerzy;
C      "A Testing Scheme for Subroutines Solving Large Linear Problems",
C       Computers and Chemistry, Vol. 5, No. 2-3, pp. 91-100, 1981.
C   2) Osterby, Ole and Zletev, Zahari;
C      "Direct Methods for Sparse Matrices";
C       Springer-Verlag 1983.
C
C
C
C   INPUT PARAMETERS
C   ----------------
C   N    - Integer. The size of the square matrix.
C          N > 2 must be specified.
C
C   NN   - Integer. The dimension of integer arrays IA and JA and
C          real array AR. Must be at least NE.
C
C   NN  - Integer. The dimension of integer array JA. Must be at least
C          NE.
C
C   IC   - Integer. The sparsity pattern can be changed by means of this
C          parameter.  1 < IC < N   must be specified.
C
C
C
C   OUTPUT PARAMETERS
C   -----------------
C   NE   - Integer. The number of nonzero elements in the sparse matrix
C          of the type E(N,C). NE = 5*N - 2*IC - 2 .
C
C   AR(NN)  - Real array.
C             Stored entries of the sparse matrix A.
C             NE is the number of nonzeros including a mandatory
C             diagonal entry for each row.
C
C   IA(NN)  - Integer array.(Double precision)
C             Pointers to specify rows for the stored nonzero entries
C             in AR.
C
C   JA(NN) - Integer array.
C             Pointers to specify columns for the stored nonzero entries
C             in AR.
C
C   IERR    - Error parameter is returned as zero on successful
C             execution of the subroutine.
C             Error diagnostics are given by means of positive values
C             of this parameter as follows:
C             IERR = 1    -  N       is out of range.
C             IERR = 2    -  IC      is out of range.
C             IERR = 3    -  NN      is out of range.
C
C---------------------------------------------------------------------
C
C
      real*8 ar(nn)
      integer ia(nn), ja(nn), n, ne, ierr
      ierr = 0
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
Check the input parameters:
c
      if(n.le.2)then
         ierr = 1
         return
      endif
      if(ic.le.1.or.ic.ge.n)then
         ierr = 2
         return
      endif
c
      ne = 5*n-2*ic-2
      if(nn.lt.ne)then
         ierr = 3
         return
      endif
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c Begin to generate the nonzero elements as well as the row and column
c pointers:
c
      do 20 i=1,n
      ar(i) = 4.0d0
      ia(i) = i
      ja(i) = i
20    continue
      ilast = n
      do 30 i=1,n-1
      it = ilast + i
      ar(it) = -1.0d0
      ia(it) = i+1
      ja(it) = i
30    continue
      ilast = ilast + n - 1
      do 40 i=1,n-1
      it = ilast + i
      ar(it) = -1.0d0
      ia(it) = i
      ja(it) = i+1
40    continue
      ilast = ilast + n-1
      do 50 i=1,n-ic
      it = ilast + i
      ar(it) = -1.0d0
      ia(it) = i+ic
      ja(it) = i
50    continue
      ilast = ilast + n-ic
      do 60 I=1,n-ic
      it = ilast + i
      ar(it) = -1.0d0
      ia(it) = i
      ja(it) = i+ic
60    continue
c      ilast = ilast + n-ic
c      if(ilast.ne.5*n-2*ic-2) then
c      write(*,*)' ilast equal to ', ilast
c      write(*,*)' ILAST, the no. of nonzeros, should = ', 5*n-2*ic-2
c      stop
c      end if
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      return
      end


use ArrayClass
use IOClass

real(real64),allocatable :: x(:), fx(:),dfdx(:),I_f_dx(:)
type(IO_) :: f

x = linspace([0.0d0,20.0d0],10000)
fx = zeros(10000)
fx = sin(x)
dfdx = d_dx(x=x,fx=fx)
I_f_dx = I_dx(x=x,fx=fx)

call f%open("fx.txt")
call f%write(x,fx)
call f%close()
call f%plot()

call f%open("dfdx.txt")
call f%write(x,dfdx)
call f%close()
call f%plot()

call f%open("I_f_dx.txt")
call f%write(x,I_f_dx)
call f%close()
call f%plot()

end


MODULE nrtype
!	Symbolic names for kind types of 4-, 2-, and 1-byte integers:
	INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
	INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
	INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
!	Symbolic names for kind types of single- and double-precision reals:
	INTEGER, PARAMETER :: SP = KIND(1.0)
	INTEGER, PARAMETER :: DP = KIND(1.0D0)
!	Symbolic names for kind types of single- and double-precision complex:
	INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
	INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
!	Symbolic name for kind type of default logical:
	INTEGER, PARAMETER :: LGT = KIND(.true.)
!	Frequently used mathematical constants (with precision to spare):
	REAL(DP), PARAMETER :: PI     =  3.141592653589793238462643383279502884197_dp
	REAL(DP), PARAMETER :: TWOPI  =  6.283185307179586476925286766559005768394_dp
	REAL(DP), PARAMETER :: ZERO   =  0.0_dp
	REAL(DP), PARAMETER :: ONE    =  1.0_dp
    REAL(DP), PARAMETER :: TWO    =  2.0_dp
    REAL(DP), PARAMETER :: THREE  =  3.0_dp
    REAL(DP), PARAMETER :: FOUR   =  4.0_dp
    REAL(DP), PARAMETER :: FIVE   =  5.0_dp
    REAL(DP), PARAMETER :: SIX    =  6.0_dp
    REAL(DP), PARAMETER :: EIGHT  =  8.0_dp
    REAL(DP), PARAMETER :: NINE   =  9.0_dp
    REAL(DP), PARAMETER :: TEN    = 10.0_dp
    REAL(DP), PARAMETER :: DOZEN  = 12.0_dp
    REAL(DP), PARAMETER :: TWFOUR = 24.0_dp

    REAL(DP), PARAMETER :: HALF           = 0.5_dp
    REAL(DP), PARAMETER :: ONEHALF        = 1.5_dp
    REAL(DP), PARAMETER :: QUARTER        = 0.25_dp
    REAL(DP), PARAMETER :: RAD_TO_DEGREES = 180.0_dp / PI
    REAL(DP), PARAMETER :: DEGREES_TO_RAD = PI / 180.0_dp
END MODULE nrtype


module types

    !! In this module we define so-called "kind"-parameters, which can be used
    !! to control the precision of the floating point reals in the program.
    !!
    !! Also we define the value of some constants
    !!
    !! ** Note:  It is not necessary to alter in this module **

    ! Get "kind" parameters for single, double, and quad precision floating-point reals
    ! (ref: http://fortranwiki.org/fortran/show/Real+precision)
    integer, parameter ::                              &
        sp = kind(1.0),                                &
        dp = selected_real_kind(2*precision(1.0_sp)),  &
        qp = selected_real_kind(2*precision(1.0_dp))
    !
    ! Select working precision
    integer, parameter :: wp = dp

    ! Constants
!    real(wp), parameter ::  pi = 4*atan(1.0_wp) ! Fortran 2003+
    real(wp), parameter ::  pi = 3.14159265358979323848_wp ! Fortran 90/95

end module types


include 'header.h'
program fft_lc
  use dyn_lc
  use rand_fun
  implicit none

  integer               :: i
  real                  :: sum, mean
  real   , allocatable  :: datah(:), re(:), im(:)

  character (len = 200) :: filename

  filename = '/Users/gullo/Work/BHB_project/CygX1_Ole/fft_test_lc.txt'
  open(10, file = filename)

  dim_lc = 8
  allocate(lc(dim_lc))

  do i = 1, dim_lc
     read(10,*) lc(i)
  enddo

  write(*,*) '-----------------------------------'
  sum = 0.0
  do i = 1, dim_lc
     write(*,*) lc(i)
     sum = sum + lc(i)
  enddo
  mean = sum / real(dim_lc)
  write(*,*) 'sum of the time series', sum
  write(*,*) 'mean of the time series', mean
  write(*,*) '-----------------------------------'

  ! allocate(datah(2 * dim_lc))
  ! do i = 1, dim_lc
  !    datah(2 * i - 1) = lc(i)
  !    datah(2 * i)     = 0.0
  ! end do

  ! call four1(datah, dim_lc, 1)
  ! do i = 1, dim_lc
  !    write(*,*) i, datah(2 * i - 1), datah(2 * i)
  ! enddo

  allocate(re(dim_lc / 2))
  allocate(im(dim_lc / 2))
  call FT_not_fast(lc, re, im, dim_lc)

  do i = 1, dim_lc / 2
     write(*,*) i, re(i), im(i)
  enddo

  ! call periodogram_frac_rms(lc, pds, dim_lc)

end program fft_lc


      double precision function randlc(x, a)

c---------------------------------------------------------------------
c
c   This routine returns a uniform pseudorandom double precision number in the
c   range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The returned value RANDLC is normalized to be
c   between 0 and 1, i.e. RANDLC = 2^(-46) * x_1.  X is updated to contain
c   the new seed x_1, so that subsequent calls to RANDLC using the same
c   arguments will generate a continuous sequence.

      implicit none
      double precision x, a
      integer*8 Lx, La, a1, a2, x1, x2, xa
      double precision d2m46
      parameter(d2m46=0.5d0**46)

      Lx = x
      La = A
      a1 = ibits(La, 23, 23)
      a2 = ibits(La, 0, 23)
      x1 = ibits(Lx, 23, 23)
      x2 = ibits(Lx, 0, 23)
      xa = ishft(ibits(a1*x2+a2*x1, 0, 23), 23) + a2*x2
      Lx   = ibits(xa,0, 46)
      x    = dble(Lx)
      randlc = d2m46*x
      return
      end

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

      SUBROUTINE VRANLC (N, X, A, Y)
      implicit none
      integer n, i
      double precision x, a, y(*)
      integer*8 Lx, La, a1, a2, x1, x2, xa
      double precision d2m46
      parameter(d2m46=0.5d0**46)

      Lx = X
      La = A
      a1 = ibits(La, 23, 23)
      a2 = ibits(La, 0, 23)
      do i = 1, N
         x1 = ibits(Lx, 23, 23)
         x2 = ibits(Lx, 0, 23)
         xa = ishft(ibits(a1*x2+a2*x1, 0, 23), 23) + a2*x2
         Lx   = ibits(xa,0, 46)
         y(i) = d2m46*dble(Lx)
      end do
      x = dble(Lx)
      return
      end


program main
    implicit none
    integer :: clock, n
    integer, allocatable :: seed(:)
    integer(4) :: i, n_tot = 100000000
    real(8), parameter :: l = 0.d0, r = 1.d0, b = 0.d0, t = 1.d0
    real(8) :: x, y, z, H
    real(8) :: integral = 0.d0

    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)
    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = x * (r - l) + l
        call RANDOM_NUMBER(y)
        y = y * (t - b) + b
        call func(x, y, z)
        call inArea(x, y, H)
        integral = integral + z * H
    end do
    integral = (r - l) * (t - b) / n_tot * integral
    write(*,'(f10.5)') integral
end program main

subroutine func(x, y, z)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: x, y
    real(8), intent(out) :: z

    z = x * y
end subroutine func

subroutine inArea(x, y, H)
    ! judge whether the dot is in the integral area
    real(8), intent(in) :: x, y
    real(8), intent(out) :: H

    H = 1.d0
end subroutine inArea


!!# FUNCTION MODULE <<FUN_xyAREA>>
MODULE FUN_xyAREA

!!## PURPOSE
!! Calculate the unsigned AREA of various shapes.

!!## DETAILS
!! The current shapes supported are
!! @ ellipse <El>
!! @ slices <Sli>

!!## DEPENDENCIES
USE FUN_xySAREA                               !!((03-A-FUN_xySAREA.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyAREA_El
 MODULE PROCEDURE xyAREA_El_Rsp
 MODULE PROCEDURE xyAREA_El_Rdp
END INTERFACE
INTERFACE xyAREA_Sli
 MODULE PROCEDURE xyAREA_Sli_Rsp
 MODULE PROCEDURE xyAREA_Sli_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyAREA_El
PUBLIC :: xyAREA_El_Rsp
PUBLIC :: xyAREA_El_Rdp
PUBLIC :: xyAREA_Sli
PUBLIC :: xyAREA_Sli_Rsp
PUBLIC :: xyAREA_Sli_Rdp

!!## MODULE PROCEDURES
CONTAINS

!!### FUNCTION <<xyAREA_El_Rsp>>
FUNCTION xyAREA_El_Rsp( El ) RESULT(AREA)

!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp ,ONLY: c_PI             !!((02-A-PAR_Constants_Rsp.f90))

INCLUDE "04-B-FUN_xyAREA_El.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyAREA_El.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <<xyAREA_El_Rdp>>
FUNCTION xyAREA_El_Rdp( El ) RESULT(AREA)

!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp ,ONLY: c_PI             !!((02-A-PAR_Constants_Rdp.f90))

INCLUDE "04-B-FUN_xyAREA_El.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyAREA_El.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <<xyAREA_Sli_Rsp>>
FUNCTION xyAREA_Sli_Rsp( N , Sli ) RESULT(AREA)

!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp ,ONLY: c_PI             !!((02-A-PAR_Constants_Rsp.f90))

INCLUDE "04-B-FUN_xyAREA_Sli.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyAREA_Sli.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <<xyAREA_Sli_Rdp>>
FUNCTION xyAREA_Sli_Rdp( N , Sli ) RESULT(AREA)

!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp ,ONLY: c_PI             !!((02-A-PAR_Constants_Rdp.f90))

INCLUDE "04-B-FUN_xyAREA_Sli.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyAREA_Sli.f90.bdy"
!!--end--
END FUNCTION

END MODULE


! cooling_Dalgarno.f90 $Id: 96606cd7f07380a2be60ac88d2c80a5209c1785f $
!***********************************************************************
FUNCTION cooling_Dalgarno (self, temp)
!
! Fit to cooling profile, merged between Dalgarno & McCray(1972)
! for low temp, and Raymond, Cox & Smith(1976) for high temp.
! C4/H4 corrected relative to sncool.pro to make it smooth at T=1e5.

  implicit none
  class(cooling_t):: self
  real(kind=dp) cooling_Dalgarno, temp, qq
  real(kind=dp), parameter:: &
    TE1=10.0, &
    TE2=2000.0, &
    TE3=8000.0, &
    TE4=2.5e4, &
    TE5=1.0e5, &
    TE6=2.5e5, &
    TE7=4.0e5, &
    TE8=4.5e7, &
    C1=2.0, &
    C2=1.5, &
    C3=5.0, &
    C4=0.83, &
    C5=0.0, &
    C6=-2.54, &
    C7=-0.49, &
    C8=0.5, &
    H1=8.00e15, &
    H2=3.58e17, &
    H3=7.79e03, &
    H4=1.70e22, &
    H5=2.38e26, &
    H6=1.22e20, &
    H7=4.00e28, &
    H8=1.07e21

    if      (temp .le. T_MC) then
      qq=0.
    else if (temp .le. TE2) then
      qq=H1*temp**C1
    else if (temp .le. TE3) then
      qq=H2*temp**C2
    else if (temp .le. TE4) then
      qq=H3*temp**C3
    else if (temp .le. TE5) then
      qq=H4*temp**C4
    else if (temp .le. TE6) then
      qq=H5*temp**C5
    else if (temp .le. TE7) then
      qq=H6*temp**C6*1e20
    else if (temp .le. TE8) then
      qq=H7*temp**C7
    else
      qq=H8*temp**C8
    end if
    cooling_Dalgarno=qq*4e-28
END FUNCTION


! As the derivative of the object function is not available, the optimiser must need only
! evaluations of the function to be minimized. this makes selection of an algorithm simpler,
! although potential benefits of methods that use the derivative are not available.
! The downhill simplex method is robust but potentially slow. Given that the optimization of this
! particular object function does not involve lots of variables it is unlikely a faster or more complicated
! (i.e. direction set method or PSO) algorithm is needed. It is short and self-contained.

MODULE DownhillSimplex

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: RunNelderMead

  NAMELIST /opt/ c_reflect, c_expand, c_contract, c_shrink, threshold, maxSteps
  REAL(8) :: c_reflect, c_expand, c_contract, c_shrink, threshold
  INTEGER :: maxSteps

  CONTAINS

!*

  ! needs to take an object function as an argument to pass to the nelder-mead optimizer
  ! right now is just importing a fixed object function from module ObjectFunctions
  SUBROUTINE RunNelderMead(guess,lambda,logUnit,printDetails)

    ! #DES: Driver for Nelder-Mead optimizer, checks sanity of input, creates guess and informs the log.
    !       guess is the point around which the simplex should be built
    !       lambda is the characteristic length scale in each dimension
    IMPLICIT NONE

    REAL(8), INTENT(IN) :: guess(:), lambda(:)
    INTEGER, INTENT(IN) :: logUnit
    LOGICAL, INTENT(IN) :: printDetails
    REAL(8) :: simplex(SIZE(guess)+1,SIZE(guess))
    REAL(8) :: optimum(SIZE(guess)), optValue
    LOGICAL :: converged = .FALSE.
    INTEGER :: i

    WRITE(logUnit,'(A)') "*   Initializing Nelder-Mead Downhill Simplex   *"
    WRITE(logUnit,*)
    WRITE(logUnit,'(A24,I6)')   "Parameter Space Size  = ", SIZE(guess)
    WRITE(logUnit,'(A24,I6)')   "Points in Simplex     = ", SIZE(guess) + 1

    CALL ProcessNameList(logUnit)
    CALL GenerateSimplex(guess,lambda,logUnit,simplex)
    CALL NelderMead(simplex,logUnit,printDetails,optimum,optValue,converged)

    IF (converged .EQV. .TRUE.) THEN
      WRITE(logUnit,'(A)') "Downhill Simplex Converged"
    ELSE
      WRITE(logUnit,'(A)') "Downhill Simplex Not Converged"
    ENDIF

    WRITE(logUnit,'(A,F15.8,A)',ADVANCE="NO") "Best value located = ", optValue, " at:"
    DO i = 1, SIZE(optimum)
      WRITE(logUnit,'(F15.8,1X)',ADVANCE='NO') optimum(i)
    ENDDO
    WRITE(logUnit,*)
    WRITE(logUnit,*)

  END SUBROUTINE RunNelderMead

!*

  SUBROUTINE GenerateSimplex(guess,lambda,logUnit,simplex)

    USE EVBParameters, ONLY : objectFunction
    IMPLICIT NONE

    REAL(8), INTENT(IN)  :: guess(:), lambda(:)
    INTEGER, INTENT(IN)  :: logUnit
    REAL(8), INTENT(OUT) :: simplex(SIZE(guess)+1,SIZE(guess))
    REAL(8) :: functionValues(SIZE(simplex,1)+1)      ! object function evaluated at each point
    INTEGER :: m, n, i

    n = SIZE(guess)
    m = n + 1

    !generate a simplex from the input point - should be done in own routine/function
    simplex(:,:)      = 0.0d0
    functionValues(:) = 0.0d0
    simplex(1,:)      = guess(:)
    functionValues(1) = objectFunction(simplex(1,:))

    DO i = 2, m
      simplex(i,:) = guess(:)
      simplex(i,i-1) = simplex(i,i-1) + lambda(i-1)
      functionValues(i) = objectFunction(simplex(i,:))
    ENDDO

    WRITE(logUnit,'(A16)') "Initial simplex:"
    CALL WriteSimplex(simplex,functionValues,logUnit)

  END SUBROUTINE GenerateSimplex

!*

  SUBROUTINE NelderMead(initialSimplex,logUnit,debug,optimum,optValue,converged)

    USE EVBParameters, ONLY : objectFunction
    IMPLICIT NONE

    REAL(8), INTENT(IN)  :: initialSimplex(:,:) ! m x n, each row is an n-dimensional vector
    INTEGER, INTENT(IN)  :: logUnit
    LOGICAL, INTENT(IN)  :: debug
    REAL(8), INTENT(OUT) :: optimum(SIZE(initialSimplex,2))
    REAL(8), INTENT(OUT) :: optValue
    LOGICAL, INTENT(OUT) :: converged

    REAL(8) :: simplex(SIZE(initialSimplex,1),SIZE(initialSimplex,2))
    REAL(8) :: functionValues(SIZE(initialSimplex,1)+1)      ! object function evaluated at each point
    INTEGER :: step, n, m, i
    REAL(8) :: f_reflect, f_expand, f_contract
    REAL(8) :: reflectedPoint(SIZE(initialSimplex,2)),  expandedPoint(SIZE(initialSimplex,2))
    REAL(8) :: contractedPoint(SIZE(initialSimplex,2)), centroidPoint(SIZE(initialSimplex,2))

    converged    = .FALSE.
    optimum(:)   = 0.0d0
    optValue      = 0.0d0
    simplex(:,:) = initialSimplex(:,:)
    n            = SIZE(simplex,2)
    m            = n + 1

    DO i = 1, m
      functionValues(i) = objectFunction(simplex(i,:))
    ENDDO

    !repeat until convergence or excessive compute time
    DO step = 1, maxSteps

      CALL BubbleSort(simplex,functionValues)  ! sort ascending (f(x1) smallest, f(n+1) largest)
      IF (debug .EQV. .TRUE.) WRITE(logUnit,'(A5,I0.4,A8,F10.4)') "STEP ", step, " f(x) = ", functionValues(1)

      IF (functionValues(1) < threshold) THEN ! convergence test

        converged = .TRUE.
        optimum(:) = simplex(1,:)
        optValue = functionValues(1)
        RETURN

      ENDIF

      centroidPoint(:) = centroid(simplex(1:n,:))

      !reflect
      reflectedPoint(:) = centroidPoint(:) + (c_reflect * (centroidPoint(:)-simplex(m,:)))
      f_reflect = objectFunction(reflectedPoint)

      IF ((f_reflect >= functionValues(1)) .AND. (f_reflect < functionValues(n))) THEN

        IF (debug .EQV. .TRUE.) WRITE(logUnit,*) "REFLECTING"
        simplex(m,:) = reflectedPoint(:)
        functionValues(m) = f_reflect
        CYCLE

      ELSE IF (f_reflect < functionValues(1)) THEN

        !expand
        expandedPoint(:) = centroidPoint(:) + (c_expand * (reflectedPoint(:) - centroidPoint(:)))
        f_expand = objectFunction(expandedPoint)
        IF (f_expand < f_reflect) THEN
          IF (debug .EQV. .TRUE.) WRITE(logUnit,*) "EXPANDING"
          simplex(m,:) = expandedPoint(:)
          functionValues(m) = f_expand
        ELSE
          IF (debug .EQV. .TRUE.) WRITE(logUnit,*) "REFLECTING"
          simplex(m,:) = reflectedPoint(:)
          functionValues(m) = f_reflect
        ENDIF
        CYCLE

      ELSE
        !contract
        contractedPoint(:) = centroidPoint(:) + (c_contract * (simplex(m,:) - centroidPoint(:)))
        f_contract = objectFunction(contractedPoint)
        IF (f_contract < functionValues(m)) THEN
          IF (debug .EQV. .TRUE.) WRITE(logUnit,*) "CONTRACTING"
          simplex(m,:) = contractedPoint(:)
          functionValues(m) = f_contract
          CYCLE
        ELSE
          !shrink
          IF (debug .EQV. .TRUE.) WRITE(logUnit,*) "SHRINKING"
          DO i = 2, m
            simplex(i,:) = simplex(1,:) + c_shrink * (simplex(i,:) - simplex(1,:))
          ENDDO
        ENDIF

      ENDIF

    ENDDO

    ! If optimization fails, return best value located
    optimum(:) = simplex(1,:)
    optValue = functionValues(1)
    RETURN

END SUBROUTINE NelderMead

!*

  SUBROUTINE BubbleSort(simplex,functionValues)

    ! #DES: Basic bubble sort algorithm, can be replaced if necessary.

    IMPLICIT NONE
    REAL(8) :: simplex(:,:), functionValues(:)
    reaL(8) :: f_temp, x_temp(SIZE(simplex,2))
    INTEGER :: i, j, m

    m = SIZE(simplex,1)
    DO i = 1, m !loop over vectors
      DO j = m, i+1, -1
        IF (functionValues(j-1) > functionValues(j)) THEN

          f_temp = functionValues(j-1)
          functionValues(j-1) = functionValues(j)
          functionValues(j) = f_temp

          x_temp(:) = simplex(j-1,:)
          simplex(j-1,:) = simplex(j,:)
          simplex(j,:) = x_temp(:)

        ENDIF
      ENDDO
    ENDDO

  END SUBROUTINE BubbleSort

!*

  FUNCTION centroid(input)

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: input(:,:) !each row a vector
    REAL(8) :: centroid(SIZE(input,2))
    INTEGER :: i, j, m, n

    m = SIZE(input,1)
    n = SIZE(input,2)

    centroid(:) = 0.0d0
    DO i = 1, m
      DO j = 1, n
        centroid(j) = centroid(j) + input(i,j)
      ENDDO
    ENDDO

    centroid(:) = centroid(:) / SIZE(input,2)

  END FUNCTION centroid

!*

  SUBROUTINE WriteSimplex(simplex,functionValues,unit)

    ! #DES: Write the provided simplex coords/values to unit.

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: unit
    REAL(8), INTENT(IN) :: simplex(:,:), functionValues(:)
    INTEGER :: i, j

    DO i = 1, SIZE(simplex,1)
      WRITE(unit,'(I0.3,1X)',ADVANCE='NO') i
      DO j = 1, SIZE(simplex,2)
        WRITE(unit,'(F10.3,1X)',ADVANCE='NO') simplex(i,j)
      ENDDO
      WRITE(unit,'(F10.3)') functionValues(i)
    ENDDO
    WRITE(unit,*)

  END SUBROUTINE WriteSimplex

!*

  SUBROUTINE ProcessNameList(logUnit)

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: logUnit

    CALL ReadNameList(logUnit)
    CALL CheckNameList()
    CALL PrintNameList(logUnit)

  END SUBROUTINE ProcessNameList

!*

  SUBROUTINE ReadNameList(logUnit)

    ! #DES: Open, read and close the namelist file opt.nml

    USE FileIO, ONLY : OpenFile, CloseFile
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: logUnit
    INTEGER, PARAMETER :: nmlUnit = 20
    LOGICAL :: fileRead

    CALL OpenFile(nmlUnit,"opt.nml","read",success=fileRead)

    !standard algorithm parameter values
    c_reflect  = 1.0d0
    c_expand   = 2.0d0
    c_contract = 0.5d0
    c_shrink   = 0.5d0
    threshold  = 1.0d-10
    maxSteps   = 100

    IF (fileRead .EQV. .TRUE.) THEN
      WRITE(logUnit,'(A)') "Optimization parameters will be read from opt.nml"
      READ(nmlUnit,NML=opt)
      CALL CloseFile(nmlUnit)
    ELSE
      WRITE(logUnit,'(A)') "Namelist opt.nml could not be read - default optimization parameters will be used"
    ENDIF

  END SUBROUTINE ReadNameList

!*

  SUBROUTINE CheckNameList()

    ! There must be additional constraints on these values - expand > 1, 0 < contract < 1 CHECK

    IMPLICIT NONE

    IF (threshold  < 0.0d0) STOP "Illegal (-ve) value of threshold in DownhillSimplex:CheckNameList"
    IF (c_reflect  < 0.0d0) STOP "Illegal (-ve) value of c_reflect in DownhillSimplex:CheckNameList"
    IF (c_expand   < 0.0d0) STOP "Illegal (-ve) value of c_expand in DownhillSimplex:CheckNameList"
    IF (c_contract < 0.0d0) STOP "Illegal (-ve) value of c_contract in DownhillSimplex:CheckNameList"
    IF (c_shrink   < 0.0d0) STOP "Illegal (-ve) value of c_shrink in DownhillSimplex:CheckNameList"
    IF (maxSteps   < 1)     STOP "Illegal (-ve) value of maxSteps in DownhillSimplex:CheckNameList"

  END SUBROUTINE CheckNameList

!*

  SUBROUTINE PrintNameList(logUnit)

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: logUnit

    WRITE(logUnit,'(A)') "*    Optimization Parameters    *"
    WRITE(logUnit,*) ""
    WRITE(logUnit,'(A,F6.2)') "Reflection Coefficient (alpha)  = ", c_reflect
    WRITE(logUnit,'(A,F6.2)') "Expansion Coefficient (beta)    = ", c_expand
    WRITE(logUnit,'(A,F6.2)') "Contraction Coefficient (gamma) = ", c_contract
    WRITE(logUnit,'(A,F6.2)') "Shrinking Coefficient (sigma)   = ", c_shrink
    WRITE(logUnit,'(A,F6.2)') "Convergence Threshold           = ", threshold
    WRITE(logUnit,'(A,I6)')   "Maximum Steps                   = ", maxSteps
    WRITE(logUnit,*)

  END SUBROUTINE PrintNameList

END MODULE DownhillSimplex

!  SUBROUTINE WriteVector(input,unit)
!    ! #DES: Print a vector to a single line on the provided unit.
!    IMPLICIT NONE
!    INTEGER, INTENT(IN) :: unit
!    REAL(8), INTENT(IN) :: input(:)
!    INTEGER :: i
!    DO i = 1, SIZE(input)
!      WRITE(unit,'(F6.2)',ADVANCE='NO') input(i)
!    ENDDO
!    WRITE(unit,*)
!  END SUBROUTINE WriteVector


C Copyright (C) 2002, 2004, 2005, 2006 Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.
C
C    $Id: hs071_f.f.in 661 2006-03-12 23:19:03Z andreasw $
C
C =============================================================================
C
C     This is an example for the usage of IPOPT.
C     It implements problem 71 from the Hock-Schittkowsky test suite:
C
C     min   x1*x4*(x1 + x2 + x3)  +  x3
C     s.t.  x1*x2*x3*x4                   >=  25
C           x1**2 + x2**2 + x3**2 + x4**2  =  40
C           1 <=  x1,x2,x3,x4  <= 5
C
C     Starting point:
C        x = (1, 5, 5, 1)
C
C     Optimal solution:
C        x = (1.00000000, 4.74299963, 3.82114998, 1.37940829)
C
C =============================================================================
C
C
C =============================================================================
C
C                            Main driver program
C
C =============================================================================
C
      program example
C
      implicit none
C
C     include the Ipopt return codes
C
      include 'IpReturnCodes.inc'
C
C     Size of the problem (number of variables and equality constraints)
C
      integer     N,     M,     NELE_JAC,     NELE_HESS,      IDX_STY
      parameter  (N = 4, M = 2, NELE_JAC = 8, NELE_HESS = 10)
      parameter  (IDX_STY = 1 )
C
C     Space for multipliers and constraints
C
      double precision LAM(M)
      double precision G(M)
C
C     Vector of variables
C
      double precision X(N)
C
C     Vector of lower and upper bounds
C
      double precision X_L(N), X_U(N), Z_L(N), Z_U(N)
      double precision G_L(M), G_U(M)
C
C     Private data for evaluation routines
C     This could be used to pass double precision and integer arrays untouched
C     to the evaluation subroutines EVAL_*
C
      double precision DAT(2)
      integer IDAT(1)
C
C     Place for storing the Ipopt Problem Handle
C
C     for 32 bit platforms
      integer IPROBLEM
      integer IPCREATE
CC     for 64 bit platforms:
C      integer*8 IPROBLEM
C      integer*8 IPCREATE
C
      integer IERR
      integer IPSOLVE, IPADDSTROPTION
      integer IPADDNUMOPTION, IPADDINTOPTION
      integer IPOPENOUTPUTFILE
C
      double precision f
      integer i
C
C     Set initial point and bounds:
C
      data X   / 1d0, 5d0, 5d0, 1d0/
      data X_L / 1d0, 1d0, 1d0, 1d0 /
      data X_U / 5d0, 5d0, 5d0, 5d0 /
C
C     Set bounds for the constraints
C
      data G_L / 25d0, 40d0 /
      data G_U / 1d40, 40d0 /
C
C     The following are the Fortran routines for computing the model
C     functions and their derivatives - their code can be found furhter
C     down in this file.
C
      external EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS
C
C     First create a handle for the Ipopt problem (and read the options
C     file)
C
      IPROBLEM = IPCREATE(N, X_L, X_U, M, G_L, G_U, NELE_JAC, NELE_HESS,
     1     IDX_STY, EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS)
      if (IPROBLEM.eq.0) then
         write(*,*) 'Error creating an Ipopt Problem handle.'
         stop
      endif
C
C     Open an output file
C
      IERR = IPOPENOUTPUTFILE(IPROBLEM, 'IPOPT.OUT', 5)
      if (IERR.ne.0 ) then
         write(*,*) 'Error opening the Ipopt output file.'
         goto 9000
      endif
C
C     Note: The following options are only examples, they might not be
C           suitable for your optimization problem.
C
C     Set a string option
C
      IERR = IPADDSTROPTION(IPROBLEM, 'mu_strategy', 'adaptive')
      if (IERR.ne.0 ) goto 9990
C
C     Set an integer option
C
      IERR = IPADDINTOPTION(IPROBLEM, 'max_iter', 3000)
      if (IERR.ne.0 ) goto 9990
C
C     Set a double precision option
C
      IERR = IPADDNUMOPTION(IPROBLEM, 'tol', 1.d-7)
      if (IERR.ne.0 ) goto 9990
C
C     As a simple example, we pass the constants in the constraints to
C     the EVAL_C routine via the "private" DAT array.
C
      DAT(1) = 0.d0
      DAT(2) = 0.d0
C
C     Call optimization routine
C
      IERR = IPSOLVE(IPROBLEM, X, G, F, LAM, Z_L, Z_U, IDAT, DAT)
C
C     Output:
C
      if( IERR.eq.IP_SOLVE_SUCCEEDED ) then
         write(*,*)
         write(*,*) 'The solution was found.'
         write(*,*)
         write(*,*) 'The final value of the objective function is ',f
         write(*,*)
         write(*,*) 'The optimal values of X are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'X  (',i,') = ',X(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the lower bounds are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'Z_L(',i,') = ',Z_L(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the upper bounds are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'Z_U(',i,') = ',Z_U(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the equality constraints are:'
         write(*,*)
         do i = 1, M
            write(*,*) 'LAM(',i,') = ',LAM(i)
         enddo
         write(*,*)
      else
         write(*,*)
         write(*,*) 'An error occoured.'
         write(*,*) 'The error code is ',IERR
         write(*,*)
      endif
C
 9000 continue
C
C     Clean up
C
      call IPFREE(IPROBLEM)
      stop
C
 9990 continue
      write(*,*) 'Error setting an option'
      goto 9000
      end
C
C =============================================================================
C
C                    Computation of objective function
C
C =============================================================================
C
      subroutine EV_F(N, X, NEW_X, F, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X
      double precision F, X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      F = X(1)*X(4)*(X(1)+X(2)+X(3)) + X(3)
      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of gradient of objective function
C
C =============================================================================
C
      subroutine EV_GRAD_F(N, X, NEW_X, GRAD, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X
      double precision GRAD(N), X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      GRAD(1) = X(4)*(2d0*X(1)+X(2)+X(3))
      GRAD(2) = X(1)*X(4)
      GRAD(3) = X(1)*X(4) + 1d0
      GRAD(4) = X(1)*(X(1)+X(2)+X(3))
      IERR = 0
      return
      end
C
C =============================================================================
C
C                     Computation of equality constraints
C
C =============================================================================
C
      subroutine EV_G(N, X, NEW_X, M, G, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X, M
      double precision G(M), X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      G(1) = X(1)*X(2)*X(3)*X(4) - DAT(1)
      G(2) = X(1)**2 + X(2)**2 + X(3)**2 + X(4)**2 - DAT(2)
      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of Jacobian of equality constraints
C
C =============================================================================
C
      subroutine EV_JAC_G(TASK, N, X, NEW_X, M, NZ, ACON, AVAR, A,
     1     IDAT, DAT, IERR)
      integer TASK, N, NEW_X, M, NZ
      double precision X(N), A(NZ)
      integer ACON(NZ), AVAR(NZ), I
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C     structure of Jacobian:
C
      integer AVAR1(8), ACON1(8)
      data  AVAR1 /1, 2, 3, 4, 1, 2, 3, 4/
      data  ACON1 /1, 1, 1, 1, 2, 2, 2, 2/
      save  AVAR1, ACON1
C
      if( TASK.eq.0 ) then
        do I = 1, 8
          AVAR(I) = AVAR1(I)
          ACON(I) = ACON1(I)
        enddo
      else
        A(1) = X(2)*X(3)*X(4)
        A(2) = X(1)*X(3)*X(4)
        A(3) = X(1)*X(2)*X(4)
        A(4) = X(1)*X(2)*X(3)
        A(5) = 2d0*X(1)
        A(6) = 2d0*X(2)
        A(7) = 2d0*X(3)
        A(8) = 2d0*X(4)
      endif
      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of Hessian of Lagrangian
C
C =============================================================================
C
      subroutine EV_HESS(TASK, N, X, NEW_X, OBJFACT, M, LAM, NEW_LAM,
     1     NNZH, IRNH, ICNH, HESS, IDAT, DAT, IERR)
      implicit none
      integer TASK, N, NEW_X, M, NEW_LAM, NNZH, i
      double precision X(N), OBJFACT, LAM(M), HESS(NNZH)
      integer IRNH(NNZH), ICNH(NNZH)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C     structure of Hessian:
C
      integer IRNH1(10), ICNH1(10)
      data  IRNH1 /1, 2, 2, 3, 3, 3, 4, 4, 4, 4/
      data  ICNH1 /1, 1, 2, 1, 2, 3, 1, 2, 3, 4/
      save  IRNH1, ICNH1

      if( TASK.eq.0 ) then
         do i = 1, 10
            IRNH(i) = IRNH1(i)
            ICNH(i) = ICNH1(i)
         enddo
      else
         do i = 1, 10
            HESS(i) = 0d0
         enddo
C
C     objective function
C
         HESS(1) = OBJFACT * 2d0*X(4)
         HESS(2) = OBJFACT * X(4)
         HESS(4) = OBJFACT * X(4)
         HESS(7) = OBJFACT * (2d0*X(1) + X(2) + X(3))
         HESS(8) = OBJFACT * X(1)
         HESS(9) = OBJFACT * X(1)
C
C     first constraint
C
         HESS(2) = HESS(2) + LAM(1) * X(3)*X(4)
         HESS(4) = HESS(4) + LAM(1) * X(2)*X(4)
         HESS(5) = HESS(5) + LAM(1) * X(1)*X(4)
         HESS(7) = HESS(7) + LAM(1) * X(2)*X(3)
         HESS(8) = HESS(8) + LAM(1) * X(1)*X(3)
         HESS(9) = HESS(9) + LAM(1) * X(1)*X(2)
C
C     second constraint
C
         HESS(1) = HESS(1) + LAM(2) * 2d0
         HESS(3) = HESS(3) + LAM(2) * 2d0
         HESS(6) = HESS(6) + LAM(2) * 2d0
         HESS(10)= HESS(10)+ LAM(2) * 2d0
      endif
      IERR = 0
      return
      end


      real*8 function thetaq(iwhere)
      character*100 id,revision,revdate
      data id/'$RCSfile: thetaq.f,v $'/
      data revision/'$Revision: 1.3 $'/
      data revdate/'$Date: 1994/03/12 17:59:03 $'/
      real*8 factor
      real*8 tl,tsat,ppow,tpow,alph,fq,theta,pfac
      integer iwhere

c
      include "const.h"
      include "sendit.h"
c
      if(iwhere.eq.1) then
         alph=cpd+(cw*qtota)
         tpow=rd/alph
         factor=dexp(qsa*lv/(tea*alph))
         thetaq=tea*((1000./pda)**tpow)*factor
      else
         alph=cpd+(cw*qtota)
         tl=tsat(pda,tea,qtota)
         tpow=con2*fq(qtota)
         theta=tea*((1000./pda)**tpow)
         ppow=1./tpow
         pfac=(theta/tl)**ppow
         factor=(pfac**(-1.12*qtota))*dexp(qtota*lv/(tl*alph))
         thetaq=factor*theta
      end if
c
      return
      end


	FUNCTION PR_TMCK  ( tmpc )
C************************************************************************
C* PR_TMCK								*
C*									*
C* This function computes TMPK from TMPC.  The following equation is	*
C* used:								*
C*									*
C*                   TMPK = TMPC + TMCK					*
C*									*
C* REAL PR_TMCK  ( TMPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_TMCK		REAL		Temperature in Kelvin		*
C**									*
C* Log:									*
C* M. Goodman/RDS	 3/84	Original source code			*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpc ) )  THEN
	    PR_TMCK = RMISSD
	  ELSE
	    PR_TMCK = tmpc + TMCK
	END IF
C*
	RETURN
	END


! =============================================================================
!                       Test ellipse reflection
!
!         This unit test checks the reflection of parcels which is
!         applied after splitting to ensure the centres of the child
!         parcels are within the domain.
! =============================================================================
program test_ellipse_reflection
    use unit_test
    use constants, only : pi, zero, one, two, three, four, f12, f14
    use parcel_container
    use parcel_bc, only : apply_reflective_bc
    use parcel_ellipse, only : get_ab, get_angle
    use parameters, only : update_parameters, lower, dx, vcell, extent, nx, nz
    implicit none

    integer :: iter
    double precision :: angle, ab, B11, B12, error, a2, b2

    nx = 10
    nz = 10
    extent = (/one, one/)
    lower  = (/zero, zero/)

    call update_parameters

    n_parcels = 1
    call parcel_alloc(1)

    error = zero

    parcels%volume(1) = f14 * vcell

    ab = get_ab(parcels%volume(1))
    a2 = four * ab
    b2 = f14 * ab

    do iter = 0, 360
        angle = dble(iter) * pi / 180.0d0

        !
        ! lower boundary check
        !

        parcels%position(:, 1) = (/f12, - f12 * dx(2)/)
        B11 = a2 * dcos(angle) ** 2 + b2 * dsin(angle) ** 2
        B12 = f12 * (a2 - b2) * dsin(two * angle)
        parcels%B(1, 1) = B11
        parcels%B(2, 1) = B12

        call apply_reflective_bc(parcels%position(:, 1), parcels%B(:, 1))

        call check_result('lower')

        !
        ! upper boundary check
        !

        angle = dble(iter) * pi / 180.0d0

        parcels%position(:, 1) = (/f12, one + f12 * dx(2)/)
        B11 = a2 * dcos(angle) ** 2 + b2 * dsin(angle) ** 2
        B12 = f12 * (a2 - b2) * dsin(two * angle)
        parcels%B(1, 1) = B11
        parcels%B(2, 1) = B12

        call apply_reflective_bc(parcels%position(:, 1), parcels%B(:, 1))

        call check_result('upper')
    enddo

    call print_result_dp('Test ellipse reflection', error, atol=1.0e-14)

    call parcel_dealloc

    contains

        subroutine check_result(bc)
            character(*), intent(in) :: bc

            ! get_angle computes the angle in the first and fourth quadrant, i.e.,
            ! -pi/2 <= get_angle <= pi/2
            if (angle > pi / two .and. angle <= three * pi / two) then
                angle = angle - pi
            else if (angle > three * pi / two) then
                angle = angle - two * pi
            endif

            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) + B12))
            error = max(error, abs(angle + get_angle(parcels%B(1, 1), parcels%B(2, 1), &
                                                     parcels%volume(1))))
            error = max(error, abs(f12 - parcels%position(1, 1)))

            if (bc == 'lower') then
                error = max(error, abs(f12 * dx(2) - parcels%position(2, 1)))
            else
                error = max(error, abs(one - f12 * dx(2) - parcels%position(2, 1)))
            endif
        end subroutine check_result

end program test_ellipse_reflection


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!                   chu :     Chua's circuit
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION ab,h,pi,alpha,beta,RK,a0,a1,x,y,z

      ab(x)=2*x*DATAN(RK*x)/pi
      h(x)=a1*x + 0.5*(a0-a1) * ( ab(x+1) - ab(x-1) )

       pi=4*DATAN(1.d0)
       alpha=PAR(1)
       beta =PAR(2)
       RK   =PAR(3)
       a0   =PAR(4)
       a1   =PAR(5)

       x=U(1)
       y=U(2)
       z=U(3)

       F(1)= alpha * ( y - h(x) )
       F(2)=  x - y + z
       F(3)= -beta * y

      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)=-1
       PAR(2)= 14.3
       PAR(3)= 10.
       PAR(4)= -1./7.
       PAR(5)= 2./7.

       U(1)=0.
       U(2)=0.
       U(3)=0.

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program euler_056
   use EulerCommon
   integer(int64), dimension(200) :: ab
   integer(int64) :: a,b, s, max_s ,max_a, max_b

   max_s = 0
   do a=90,99
      do b=90,99
         call powers(a,b,ab)
         s = sum(ab)
         if (s > max_s) then
            max_s = s
            max_a = a
            max_b = b
         end if
      end do
   end do
   print *,max_a, max_b, max_s

contains
   subroutine powers(a,b,ab)
      integer(int64), intent(in) :: a,b
      integer(int64), intent(out) :: ab(200)
      integer(int64) :: i, max_n

      ab(:) = 0
      ab(1) = a
      max_n = max(200_int64,b*int(log10(real(a)),int64)+3_int64)
      call checkTensInArray(max_n,ab)
      do i=2,b
         ab(:) = ab(:)*a
         call checkTensInArray(max_n,ab)
      end do !- i
   end subroutine powers

end program euler_056


!projection on the simplex splace
! update project method on 2019-Aug-3: based on the paper
! Fast projection onto the simplex and the l1 ball
! Laurent Condat, 2016
    subroutine simplex_projection(x,z,d,n)
    implicit none
    integer,intent(in)::n
    real*8,parameter::project_eps = 0.0
    real*8,intent(in)::d
    integer,dimension(n)::isSelect
    real*8,dimension(n),intent(in)::z
    real*8,dimension(n),intent(out)::x
    real*8::pivot
    real*8:: sum_k,get_sum
    real*8,dimension(n)::tempz
    integer::i,now,pre,counter
    logical st,loop
    real*8 dnor
    integer,dimension(n)::set_i
    x=0.0
    pivot=(sum(z)-d)/n
    loop =  .true.
    isSelect = 1
    counter = 0
    do while(loop)
        pre = sum(isSelect)
        isSelect = 0
        tempz=0
        do i=1,n
            if(z(i)>pivot+project_eps) then
                isSelect(i) = 1
                tempz(i) = z(i)
            end if
        end do
        pivot = (sum(tempz)-1+(n-sum(isSelect))*project_eps)/sum(isSelect)
        if (sum(isSelect).eq.pre) then
            loop = .false.
        else
            loop = .true.
        end if
        counter=counter+1
        if (counter>100) then
            write(*,*)  "Warning: the projection method and can not get of loop"
            pause
        end if
    end do
    do i =1, n
        x(i) = max(z(i)-pivot,project_eps)
    end do
    return

!     do i=1,n
!     !	x(i)=z(i)+(d-sum(z(:)))/(n*1.0)
!         x(i)=z(i)+(d-get_sum(z(1:n),n))/(n*1.0)
!     end do

! 10	set_i=0
!     st=.true.
!     sum_k=0.0
!     do i=1,n
!         !if (x(i)>0.0) then
!         if (x(i) > project_eps) then
!             set_i(i) = 1
!             sum_k = sum_k + x(i)
!         endif
!         !if (x(i)<0.0) then
!         if (x(i) < project_eps) then
!             st =.false.
!             sum_k = sum_k + project_eps
!         end if
!     end do
!     if (st) then
!         return
!     end if
!     dnor = (sum(set_i(:))*1d0)
!     do i = 1,n
!         if (set_i(i)==0) then
!              !x(i)=0.0
!             x(i) = project_eps
!         else if (set_i(i) == 1) then
!             x(i) = x(i) + (d-sum_k)/dnor
!         end if
!     end do
!     go to 10

    end subroutine

		real*8 function get_sum(x,n)
		implicit none
		integer n
		real*8 x(n)
		integer i
		get_sum=0.0
		do i=1,n
			get_sum=get_sum+x(i)
		end do
		return
		end


!*****************************************************************************************
!>
!  Test of the object-oriented interface.

program root_tests_oo

    use root_module, wp => root_module_rk
    use iso_fortran_env, only: output_unit

    implicit none

    real(wp) :: root,ax,bx,xzero,fzero,error
    integer :: iflag
    character(len=1000) :: line

    real(wp),parameter :: ftol = 1.0e-15_wp
    real(wp),parameter :: rtol = 1.0e-13_wp
    real(wp),parameter :: atol = 1.0e-16_wp
    integer,parameter  :: maxiter = 1000

    character(len=*),parameter :: fmt  = '(A25,   1X,A25,   1X,A25,  1X,A5,1X,A5)' !! format for header
    character(len=*),parameter :: dfmt = '(E25.10,1X,E25.10,1X,E25.6,1X,I5,1X,I5)' !! format for results

    type,extends(muller_solver) :: my_solver
        integer :: ifunc = 0
        integer :: n = 1
    end type my_solver
    type(my_solver) :: solver

    ! case 19
    ax = 0.0_wp
    bx = 1.0_wp
    root = 0.22370545765466_wp

    call solver%initialize(f,ftol,rtol,atol,maxiter); solver%n = 3
    call solver%solve(ax,bx,xzero,fzero,iflag)

    error = xzero-root

    write(output_unit,fmt) repeat('-',25),repeat('-',25),repeat('-',25),repeat('-',5),repeat('-',5)
    write(output_unit,fmt) 'error','x','f','evals','iflag'
    write(output_unit,fmt) repeat('-',25),repeat('-',25),repeat('-',25),repeat('-',5),repeat('-',5)

    write(line, dfmt) error,xzero,fzero,solver%ifunc,iflag
    write(output_unit, '(A)') trim(line)

    contains

    function f(me,x)

        !! function to find the root of.

        class(root_solver),intent(inout) :: me
        real(wp),intent(in) :: x
        real(wp) :: f

        real(wp) :: dn

        select type(me)
        class is (my_solver)

            me%ifunc = me%ifunc + 1

            dn = real(me%n, wp)
            f = 2.0_wp*x*exp(-dn) - 2.0_wp*exp(-dn*x) + 1.0_wp

        end select

    end function f

    end program root_tests_oo
!*****************************************************************************************


program ieee_tricks
    implicit none
    real, parameter :: infinity = huge(real(0.0))
    real :: result, r

    call random_number(r)
    result = 1.0/min(0.0, r)
    print '(A, E10.5)', '1.0/0.0 =', result
    if (result < -infinity .or. infinity < result) then
        print '(A)', 'Infinity found'
    end if

    result = 0.0/min(0.0, r)
    print '(A, E10.5)', '1.0/0.0 =', result
    if (result /= result) then
        print '(A)', 'NaN found'
    end if
end program ieee_tricks


      subroutine caxpy ( n, ca, cx, incx, cy, incy )

c*********************************************************************72
c
cc CAXPY computes constant times a vector plus a vector.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in CX and CY.
c
c    Input, complex CA, the multiplier of CX.
c
c    Input, complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, complex CY(*), the second vector.
c    On output, CY(*) has been replaced by CY(*) + CA * CX(*).
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      complex ca
      complex cx(*)
      complex cy(*)
      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer n

      if ( n .le. 0 ) then
        return
      end if

      if ( abs ( real ( ca ) ) + abs ( aimag ( ca ) ) .eq. 0.0 ) then
        return
      end if
c
c  Code for both increments equal to 1.
c
      if ( incx .eq. 1 .and. incy .eq. 1 ) then

        do i = 1, n
          cy(i) = cy(i) + ca * cx(i)
        end do
c
c  Code for unequal increments or equal increments
c  not equal to 1.
c
      else

        if ( incx .lt. 0 ) then
          ix = ( - n + 1 ) * incx + 1
        else
          ix = 1
        end if

        if ( incy .lt. 0 ) then
          iy = ( - n + 1 ) * incy + 1
        else
          iy = 1
        end if

        do i = 1, n
          cy(iy) = cy(iy) + ca * cx(ix)
          ix = ix + incx
          iy = iy + incy
        end do

      end if

      return
      end
      subroutine ccopy ( n, cx, incx, cy, incy )

c*********************************************************************72
c
cc CCOPY copies a vector, x, to a vector, y.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in CX and CY.
c
c    Input, complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Output, complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      complex cx(*),cy(*)
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments
c  not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        cy(iy) = cx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
   20 do i = 1,n
        cy(i) = cx(i)
      end do

      return
      end
      function cdotc ( n, cx, incx, cy, incy )

c*********************************************************************72
c
cc CDOTC forms the conjugated  dot product of two vectors.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, complex CDOTC, the conjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      complex cdotc
      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n

      ctemp = (0.0,0.0)
      cdotc = (0.0,0.0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments
c  not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ctemp = ctemp + conjg(cx(ix))*cy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      cdotc = ctemp
      return
c
c  code for both increments equal to 1
c
   20 do i = 1,n
        ctemp = ctemp + conjg(cx(i))*cy(i)
      end do

      cdotc = ctemp
      return
      end
      function cdotu ( n, cx, incx, cy, incy )

c*********************************************************************72
c
cc CDOTU forms the dot product of two vectors.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, complex CDOTU, the unconjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      complex cdotu
      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n

      ctemp = (0.0,0.0)
      cdotu = (0.0,0.0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments
c  not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ctemp = ctemp + cx(ix)*cy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      cdotu = ctemp
      return
c
c  code for both increments equal to 1
c
   20 do i = 1,n
        ctemp = ctemp + cx(i)*cy(i)
      end do

      cdotu = ctemp

      return
      end
      subroutine crotg ( ca, cb, c, s )

c*********************************************************************72
c
cc CROTG generates a Givens rotation.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c    Given values A and B, this routine computes:
c
c    If A = 0:
c
c      R = B
c      C = 0
c      S = (1,0).
c
c    If A /= 0:
c
c      ALPHA = A / abs ( A )
c      NORM  = sqrt ( ( abs ( A ) )^2 + ( abs ( B ) )^2 )
c      R     = ALPHA * NORM
c      C     = abs ( A ) / NORM
c      S     = ALPHA * conj ( B ) / NORM
c
c    In either case, the computed numbers satisfy the equation:
c
c    (         C    S ) * ( A ) = ( R )
c    ( -conj ( S )  C )   ( B ) = ( 0 )
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input/output, complex CA; on input, the value A.  On output,
c    the value R.
c
c    Input, complex CB, the value B.
c
c    Output, real C, the cosine of the Givens rotation.
c
c    Output, complex S, the sine of the Givens rotation.
c
      implicit none

      complex ca,cb,s
      real c
      real norm,scale
      complex alpha

      if ( cabs(ca) .eq. 0.0 ) then
         c = 0.
         s = (1.,0.)
         ca = cb
      else
         scale = cabs(ca) + cabs(cb)
         norm = scale * sqrt((cabs(ca/scale))**2 + (cabs(cb/scale))**2)
         alpha = ca /cabs(ca)
         c = cabs(ca) / norm
         s = alpha * conjg(cb) / norm
         ca = alpha * norm
      end if

      return
      end
      subroutine cscal ( n, ca, cx, incx )

c*********************************************************************72
c
cc CSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, complex CA, the multiplier.
c
c    Input/output, complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
      implicit none

      complex ca,cx(*)
      integer i,incx,n,nincx

      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c  code for increment not equal to 1
c
      nincx = n*incx
      do i = 1,nincx,incx
        cx(i) = ca*cx(i)
      end do
      return
c
c  code for increment equal to 1
c
   20 do i = 1,n
        cx(i) = ca*cx(i)
      end do

      return
      end
      subroutine csrot ( n, cx, incx, cy, incy, c, s )

c*********************************************************************72
c
cc CSROT applies a plane rotation.
c
c  Discussion:
c
c    The cos and sin (c and s) are real and the vectors cx and cy are complex.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, complex CX(*), one of the vectors to be rotated.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, complex CY(*), one of the vectors to be rotated.
c
c    Input, integer INCY, the increment between successive elements of CY.
c
c    Input, real C, S, parameters (presumably the cosine and sine of
c    some angle) that define a plane rotation.
c
      implicit none

      complex cx(1),cy(1),ctemp
      real c,s
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ctemp = c*cx(ix) + s*cy(iy)
        cy(iy) = c*cy(iy) - s*cx(ix)
        cx(ix) = ctemp
        ix = ix + incx
        iy = iy + incy
      end do

      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ctemp = c*cx(i) + s*cy(i)
        cy(i) = c*cy(i) - s*cx(i)
        cx(i) = ctemp
      end do
      return
      end
      subroutine csscal ( n, sa, cx, incx )

c*********************************************************************72
c
cc CSSCAL scales a complex vector by a real constant.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real SA, the multiplier.
c
c    Input/output, complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of
c    the vector CX.
c
      implicit none

      complex cx(*)
      real sa
      integer i,incx,n,nincx

      if( n.le.0 .or. incx.le.0 )return

      if(incx.eq.1)go to 20
c
c  code for increment not equal to 1
c
      nincx = n*incx
      do i = 1,nincx,incx
        cx(i) = cmplx ( sa*real(cx(i)), sa*aimag(cx(i)) )
      end do
      return
c
c  code for increment equal to 1
c
   20 do i = 1,n
        cx(i) = cmplx ( sa*real(cx(i)), sa*aimag(cx(i)) )
      end do

      return
      end
      subroutine cswap ( n, cx, incx, cy, incy )

c*********************************************************************72
c
cc CSWAP interchanges two vectors.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, complex CX(*), one of the vectors to swap.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, complex CY(*), one of the vectors to swap.
c
c    Input, integer INCY, the increment between successive elements of CY.
c
      implicit none

      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal
c  to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ctemp = cx(ix)
        cx(ix) = cy(iy)
        cy(iy) = ctemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ctemp = cx(i)
        cx(i) = cy(i)
        cy(i) = ctemp
      end do

      return
      end
      function icamax ( n, cx, incx )

c*********************************************************************72
c
cc ICAMAX finds the index of element having maximum absolute value.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, integer ICAMAX, the index of the element of maximum
c    absolute value.
c
      implicit none

      complex cx(*)
      integer icamax
      real smax
      integer i,incx,ix,n
      complex zdum
      real cabs1
      cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))

      icamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      icamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = cabs1(cx(1))
      ix = ix + incx
      do i = 2,n
         if(cabs1(cx(ix)).le.smax) go to 5
         icamax = i
         smax = cabs1(cx(ix))
    5    ix = ix + incx
      end do

      return
c
c        code for increment equal to 1
c
   20 smax = cabs1(cx(1))
      do i = 2,n
        if ( smax .lt. cabs1(cx(i)) ) then
          icamax = i
          smax = cabs1(cx(i))
        end if
      end do

      return
      end
      function scasum ( n, cx, incx )

c*********************************************************************72
c
cc SCASUM takes the sum of the absolute values of a complex vector.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, real SCASUM, the sum of the absolute values.
c
      implicit none

      complex cx(*)
      real scasum
      real stemp
      integer i,incx,n,nincx

      scasum = 0.0e0
      stemp = 0.0e0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do i = 1,nincx,incx
        stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
      end do
      scasum = stemp
      return
c
c        code for increment equal to 1
c
   20 do i = 1,n
        stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
      end do

      scasum = stemp

      return
      end
      function scnrm2 ( n, x, incx )

c*********************************************************************72
c
cc SCNRM2 returns the euclidean norm of a complex vector.
c
c  Discussion:
c
c    This routine uses single precision complex arithmetic.
c
c    SCNRM2 := sqrt ( sum ( conjg ( x(1:n) ) * x(1:n) ) )
c            = sqrt ( dot_product ( x(1:n), x(1:n) ) )
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Sven Hammarling
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, real SCNRM2, the norm of the vector.
c
      implicit none

      integer incx
      integer ix
      integer n
      real one
      parameter ( one = 1.0e+0 )
      real scnrm2
      complex x( * )
      real zero
      parameter ( zero = 0.0e+0 )

      real                  norm, scale, ssq, temp
      intrinsic             abs, aimag, real, sqrt

      if( n.lt.1 .or. incx.lt.1 )then
         norm  = zero
      else
         scale = zero
         ssq   = one
c        The following loop is equivalent to this call to the LAPACK
c        auxiliary routine:
c        CALL CLASSQ( N, X, INCX, SCALE, SSQ )
c
         do ix = 1, 1 + ( n - 1 )*incx, incx
            if( real( x( ix ) ).ne.zero )then
               temp = abs( real( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
            if( aimag( x( ix ) ).ne.zero )then
               temp = abs( aimag( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
         end do
         norm  = scale * sqrt( ssq )
      end if

      scnrm2 = norm

      return
      end


program euler_method
use iso_fortran_env, only: real64
implicit none

abstract interface
  ! a derivative dy/dt as function of y and t
  function derivative(y, t)
    use iso_fortran_env, only: real64
    real(real64) :: derivative
    real(real64), intent(in) :: t, y
  end function
end interface

real(real64), parameter :: T_0 = 100, T_room = 20, k = 0.07, a = 0, b = 100, &
    h(3) = [2.0, 5.0, 10.0]

integer :: i

! loop over all step sizes
do i = 1, 3
  call euler(newton_cooling, T_0, a, b, h(i))
end do

contains

! Approximates y(t) in y'(t) = f(y, t) with y(a) = y0 and t = a..b and the
! step size h.
subroutine euler(f, y0, a, b, h)
  procedure(derivative) :: f
  real(real64), intent(in) :: y0, a, b, h
  real(real64) :: t, y

  if (a > b) return
  if (h <= 0) stop "negative step size"

  print '("# h = ", F0.3)', h

  y = y0
  t = a

  do
    print *, t, y
    t = t + h
    if (t > b) return
    y = y + h * f(y, t)
  end do
end subroutine

! Example: Newton's cooling law, f(T, _) = -k*(T - T_room)
function newton_cooling(T, unused) result(dTdt)
  real(real64) :: dTdt
  real(real64), intent(in) :: T, unused
  dTdt = -k * (T - T_room)
end function

end program


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the user supplied module phaml_user_mod
!----------------------------------------------------

module phaml_user_mod

!----------------------------------------------------
! This module contains user global data.
!
! This version illustrates eigenvalue problems via the Schroedinger Equation
! for a simple harmonic oscillator where the cross section of the well is an
! ellipse with axes determined by prob_param.
! -uxx -uyy + prob_param*(x^2+3*y^2)/2 * u = lambda * u
! prob_param must be positive.
!
! For num_eval=1 and lambda0=-huge(0.), the eigenvalue is
! sqrt(prob_param*(2+sqrt(3)))
! and the solution (wave function) is
! exp(-sqrt(prob_param/8)*(x^2+sqrt(3)*y^2).
!
!----------------------------------------------------

!----------------------------------------------------
! Other modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Global variables

real(my_real), save :: prob_param
!----------------------------------------------------

end module phaml_user_mod


! ----------------------------------------------------------------------
      real function AScurv(df,x,min,max,shp,mid,asy)
! ----------------------------------------------------------------------

      implicit none
      integer df    ! Equation form: 1 = integral, 2 = 1st derivative
      real  x       ! X Value
      real  min     ! Minimum Value
      real  max     ! Maximum Value
      real  shp     ! Function Shape
      real  mid     ! X Value in which y = (max - min) / 2.
      real  asy     ! Asymetry

      select case(df)
      case(1)
          !Integral form
          AScurv = max + ((min - max) / ((1.d0 + (x/mid)**shp)**asy))

      case(2)
          !1st derivative
          AScurv = -asy * (min-max) * ((1.d0+(x/mid)**shp)**(-asy-1.d0)) * (shp*(x/mid)**(shp-1.d0)) * (1.d0/mid)

      end select
      return
      end
!-----------------------------------------------------------------------


module ZerowithRidders

    use iso_fortran_env
    implicit none

    INTEGER, parameter :: qp = REAL64
    INTEGER, parameter :: maxi = 2000
    REAL(qp), parameter :: tol = 1.E-6

    abstract interface
        pure function ResidualFunction(x,parameters)
            Double precision, intent(in) :: x
            Double precision, intent(in), optional :: parameters(:)
            Double precision :: ResidualFunction
        end function ResidualFunction
    end interface

contains
    pure function FINDZEROWITHRIDDERS( ResidualFuncao, parameters, x_min, x_max )

        !use iso_fortran_env
        implicit none

        !!! declarações

        !maxi = < Maximum iterations number >
        !ε := < Tolerance value for the residual >
        ! varin := < variable value at left boundary >
        ! varout := < variable value at right boundary >
        ! resin :=ResidualFunction(varin;...)
        ! resout :=ResidualFunction(varout;...)
        !INTEGER, parameter :: maxi = 2000
        !REAL(REAL64), parameter :: tol = 1.E-6
        REAL(qp) :: varin, varout, resin, resout, vartemp,restemp,varguess,res
        procedure(ResidualFunction) :: ResidualFuncao
        REAL(qp), intent(in) :: parameters(:)
        REAL(qp), intent(in) :: x_min, x_max
        REAL(qp) :: FINDZEROWITHRIDDERS
        INTEGER :: i

        varin = x_min
        varout = x_max
        resin = ResidualFuncao(varin, parameters)
        resout = ResidualFuncao(varout, parameters)
        res = 1000.
        i=0
        !restemp = 1000.
        !print *, "inside 1", varin, varout, resin, resout
        !print *, maxi, res, tol

        DO WHILE ( (i .LT. maxi) .AND. (abs(res) .GE. tol)  )
            varguess = (varin + varout)/2.
            res = ResidualFuncao(varguess, parameters)
            !print *, varguess, res
            vartemp=varguess+(varguess-varin)*sign(res,resin-resout)/(sqrt(res**2 - resin*resout))
            restemp = ResidualFuncao(vartemp, parameters)
            !print *, vartemp, restemp
            if (res*restemp < 0) then
                varin = varguess
                resin = res
                varout = vartemp
                resout = restemp
            else
                if (restemp*resin < 0) then
                    varout = vartemp
                    resout = restemp
                else
                    varin = vartemp
                    resin = restemp
                end if
            end if
            i = i + 1
            !print *, i
        END DO
        !FINDZEROWITHRIDDERS = vartemp
        if (abs(res)<abs(restemp)) then
            FINDZEROWITHRIDDERS = varguess
        else
            FINDZEROWITHRIDDERS = vartemp
        end if
    end function

    subroutine FINDZEROWITHRIDDERS_R( ResidualFuncao, xzero, parameters, x_min, x_max, outparameters)

        implicit none

        INTEGER :: i = 0
        REAL(qp) :: varin, varout, resin, resout, vartemp,restemp,varguess,res
        procedure(ResidualFunction) :: ResidualFuncao
        REAL(qp), intent(in), optional :: parameters(:)
        REAL(qp), intent(in) :: x_min, x_max
        REAL(qp), dimension(2), intent(out), optional :: outparameters
        REAL(qp), intent(out) :: xzero

        varin = x_min
        varout = x_max
        resin = ResidualFuncao(varin, parameters)
        resout = ResidualFuncao(varout, parameters)
        res = 1000.

        DO WHILE ( (i .LT. maxi) .AND. (abs(res) .GE. tol)  )
            varguess = (varin + varout)/2.
            res = ResidualFuncao(varguess, parameters)
            vartemp=varguess+(varguess-varin)*sign(res,resin-resout)/(sqrt(res**2 - resin*resout))
            restemp = ResidualFuncao(vartemp, parameters)
            if (res*restemp < 0) then
                varin = varguess
                resin = res
                varout = vartemp
                resout = restemp
            else
                if (restemp*resin < 0) then
                    varout = vartemp
                    resout = restemp
                else
                    varin = vartemp
                    resin = restemp
                end if
            end if
            i = i + 1
            !print *, i
        END DO
        outparameters(1)=i
        !xzero = vartemp
        if (abs(res)<abs(restemp)) then
            xzero = varguess
        else
            xzero = vartemp
        end if
    end subroutine

end module ZerowithRidders


PROGRAM A_PLUS_B
    INTEGER :: A, B, C
    READ(*,*) A, B, C

    WRITE(*,"(I0)") MOD(A+B, C)
    WRITE(*,"(I0)") MOD(MOD(A, C) + MOD(B, C), C)
    WRITE(*,"(I0)") MOD(A*B, C)
    WRITE(*,"(I0)") MOD(MOD(A, C) * MOD(B, C), C)
END PROGRAM


      PROGRAM xtutest
C     driver for routine tutest
      INTEGER NPTS,NSHFT,MPTS
      REAL EPS,VAR1,VAR2
      PARAMETER(NPTS=5000,MPTS=1000,EPS=0.02,VAR1=1.0,
     *     VAR2=4.0,NSHFT=10)
      INTEGER i,idum,j
      REAL data1(NPTS),data2(MPTS),fctr1,fctr2,gasdev,prob,shift,t
C     generate two Gaussian distributions of different variance
      idum=-51773
      fctr1=sqrt(VAR1)
      do 11 i=1,NPTS
        data1(i)=fctr1*gasdev(idum)
11    continue
      fctr2=sqrt(VAR2)
      do 12 i=1,MPTS
        data2(i)=(NSHFT/2.0)*EPS+fctr2*gasdev(idum)
12    continue
      write(*,'(1x,a,f6.2)') 'Distribution #1 : variance = ',VAR1
      write(*,'(1x,a,f6.2/)') 'Distribution #2 : variance = ',VAR2
      write(*,'(1x,t4,a,t18,a,t25,a)') 'Shift','T','Probability'
      do 14 i=1,NSHFT+1
        call tutest(data1,NPTS,data2,MPTS,t,prob)
        shift=(i-1)*EPS
        write(*,'(1x,f6.2,2f12.2)') shift,t,prob
        do 13 j=1,NPTS
          data1(j)=data1(j)+EPS
13      continue
14    continue
      END

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


subroutine thunderegg_fort_apply_bc_default(blockno, mx, my,mbc,meqn,xlower,ylower, &
    dx,dy,t,intersects_bc,bctype,rhs,g_bc, cons_check, flux_sum)

    implicit none

    external g_bc
    integer blockno, mx,my,mbc,meqn,intersects_bc(0:3),bctype(0:3), cons_check
    double precision xlower,ylower,dx,dy, t, flux_sum(0:3)
    double precision rhs(1-mbc:mx+mbc,1-mbc:my+mbc)

    !! Dummy argument needed to apply BC
    double precision q(1-mbc:mx+mbc,1-mbc:my+mbc)

    integer i,j, iface, idir, i1, ig, j1, jg
    double precision d, h, x, y, g, g_bc, dx2, dy2, qlap
    double precision a,b

    do i = 1-mbc,mx+mbc
        do j = 1-mbc,my+mbc
            q(i,j) = 0
        end do
    end do

    do iface = 0,3
        if (intersects_bc(iface) .ne. 0) then
            idir = iface/2   !! direction : 0 or 1

            if (bctype(iface) .eq. 1) then
                a = 1
                b = 0
            elseif (bctype(iface) .eq. 2) then
                a = 0
                b = 1
            endif

            if (idir == 0) then
                h = dx
            else
                h = dy
            endif

            d = (a/2.d0 + b/h)
            if (d .eq. 0) then
                write(6,*) 'thunderegg_fort_apply_bc_default : ill-defined BCs'
                stop
            endif

            if (idir == 0) then
                if (iface .eq. 0) then
                    i1 = 1
                    ig = 0
                elseif (iface .eq. 1) then
                    i1 = mx+1
                    ig = mx+1
                endif
                !! location at interface
                x = xlower + (i1 - 1)*dx

                do j = 1,my
                    y = ylower + (j-0.5)*dy

                    !! inhomogeneity
                    g = g_bc(iface,t,x,y)

                    !! Assume uI == 0
                    q(ig,j) = g/d
                end do
            elseif (idir == 1) then
                if (iface .eq. 2) then
                    j1 = 1
                    jg = 0
                elseif (iface .eq. 3) then
                    j1 = my+1
                    jg = my+1
                endif
                !! location at interface
                y = ylower + (j1 - 1)*dy

                do i = 1,mx
                    x = xlower + (i-0.5)*dx

                    !! inhomogeneity
                    g = g_bc(iface,t,x,y)

                    !! Assume uI == 0
                    q(i,jg) = g/d
                end do
            endif

            !! Ghost cells now all filled in.  Now apply Laplacian

            !! This could be done more efficiently
            dx2 = dx*dx
            dy2 = dy*dy
            do i = 1,mx
                do j = 1,my
                    qlap = (q(i-1,j) - 2*q(i,j) + q(i+1,j))/dx2 + &
                          (q(i,j-1) - 2*q(i,j) + q(i,j+1))/dy2
                    rhs(i,j) = rhs(i,j) - qlap
                end do
            end do
        end if
    end do

end subroutine thunderegg_fort_apply_bc_default


FUNCTION student(t, ndf, normal) RESULT(fn_val)

!  Calculates the two-tailed probability of Student's t.
!  The user must supply a function `normal' to calculate the area under the
!  normal distribution curve, such as Applied Statistics algorithm AS 66.

!  Translation from Algol by Alan Miller, CSIRO Division of Mathematics
!  & Statistics, Clayton, Victoria 3169, Australia of:

!  Algorithm 395: Student's t-distribution by G.W. Hill
!  Comm. A.C.M., vol.13(10), 617-619, October 1970

!  N.B. The number of degrees of freedom is not necessarily an integer

!  Arguments:
!  t       double precision    Value of Student's t
!  ndf     double precision    Number of degrees of freedom
!  normal  double precision    External function to return the
!                              area under the standard normal curve
!  ier     integer             Error indicator = 0 for normal exit
!                                              = 1 if ndf < 1

!  ELF90-compatible version by Alan Miller
!  Latest revision - 7 August 1997

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), INTENT(IN) :: t, ndf
REAL (dp)             :: fn_val

INTERFACE
  FUNCTION normal(x) RESULT(fx)
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN) :: x
    REAL (dp)             :: fx
  END FUNCTION normal
END INTERFACE

!     Local variables

REAL (dp)            :: a, b, n, t2, y, z
REAL (dp), PARAMETER :: eps = 1.d-12, one = 1.d0, twoonpi = 0.63661977236758D0
INTEGER              :: j

IF (ndf < one) THEN
  WRITE(*, *) 'Error in student: Number of degrees of freedom < 1'
  RETURN
END IF

t2 = t*t
y = t2/ndf
b = one + y
z = one

IF ( (ndf - INT(ndf)) > eps .OR. (ndf > 20.d0 - eps .AND. ndf > t2)  &
     .OR.  ndf > 200.d0 ) THEN

!     Asymptotic series for large or non-integer ndf

  IF (y > 1.d-06) y = LOG(b)
  a = ndf - 0.5D0
  b = 48.d0 * a**2
  y = a * y
  y = (((((-0.4D0*y - 3.3D0)*y - 24.d0)*y - 85.5D0) /  &
      (0.8D0*y**2 + 100.d0 + b) + y +3.d0) / b + one) * SQRT(y)
  fn_val = 2.d0 * normal(-y)
  RETURN

ELSE IF ( ndf < 20.d0 .AND. t2 < 4.d0) THEN

!     Nested summation of cosine series

  y = SQRT(y)
  a = y
  IF (ndf == one) a = 0.d0
  n = ndf

!     Tail series expansion for large t-values

ELSE
  a = SQRT(b)
  y = a * ndf
  j = 0
  10   j = j + 2
  IF (ABS(a-z) > eps) THEN
    z = a
    y = y * (j - 1) / (b * j)
    a = a + y / (ndf + j)
    GO TO 10
  END IF
  n = ndf + 2.d0
  z = 0.d0
  y = 0.d0
  a = - a
END IF

!     This is the `loop' from the Algol code.
!     It required jumping between different parts of an IF () THEN
!     ELSE IF () .. block.

20 n = n - 2.d0
IF (n > 1.d0) THEN
  a = (n - 1.d0) * a / (b * n) + y
  GO TO 20
END IF

IF ( ABS(n) < eps ) THEN
  a = a / SQRT(b)
ELSE
  a = (ATAN(y) + a/b) * twoonpi
END IF
fn_val = z - a

RETURN
END FUNCTION student