module params
  implicit none

  !  Useful constants
  integer, parameter :: &
       fdp=8, variablelength=256, errorlength=256

  real(fdp), parameter :: pi = 3.141592653589793238d0, pi2 = pi/2.0d0, &
       pi4 = pi/4.0d0, eps = 1.0d-16, inf = 1.7976931348623157d308, &
       el=0.5772156649015329d0, sqrt2 = 1.414213562373095d0, zero=2.2250738585072014d-308

  character(len=*), parameter :: &
       operatorchars='+-/*^><=!%', numberchars='1234567890.', &
       exponentchars='ed', lowerchars='abcdefghijklmnopqrstuvwxyz', &
       upperchars='ABCDEFGHIJKLMNOPQRSTUVWXYZ', bracketchars='()[]{}', &
       specialchars=',_', funcvarchars=lowerchars//upperchars, &
       allowedchars=operatorchars//numberchars//funcvarchars//bracketchars//specialchars

  ! Controlling definitions
  integer, parameter :: &
       number_=10, bracket_=11, nop_=12, comma_=13, end_=14

  !  Bracket definitions
  integer, parameter :: &
       bracketstart=20, &
       roundbracket_=20, squarebracket_=21, squigbracket_=22, &
       bracketend=22

  !  Expression definitions
  integer, parameter :: &
       expressionlength=8, &
       expressionstart=100, &
       anint_=100, log10_=101, sqrt_=102, acos_=103, asin_=104, &
       atan_=105, cosh_=106, sinh_=107, tanh_=108, aint_=109, &
       cos_=110, sin_=111, tan_=112, exp_=113, log_=114, abs_=115, &
       delta_=116, step_=117, hat_=118, max_=119, min_=120, &
       besj0_=121, besj1_=122, besjn_=123, besy0_=124, besy1_=125, &
       besyn_=126, logn_=127, erf_=128, erfc_=129, lgamma_=130, &
       gamma_=131, csch_=132, sech_=133, coth_=134, if_=135, &
       gauss_=136, sinc_=137, besi0_=138, besi1_=139, besk0_=140, &
       besk1_=141, ierfc_=142, besin_=143, beskn_=144, cbrt_=145, &
       fresc_=146, fress_=147, expi_=148, sini_=149, cosi_=150, &
       logi_=151, ierf_=152, elle_=153, ellk_=154, ielle_=155, iellf_=156, &
       modulo_=157 , floor_=158, ceiling_=159, mod_=160, &
       expressionend=160

  character(len=expressionlength), dimension(expressionstart:expressionend), parameter :: &
       expressions=(/ 'anint(  ', 'log10(  ', 'sqrt(   ', 'acos(   ', &
       'asin(   ', 'atan(   ', 'cosh(   ', 'sinh(   ', 'tanh(   ', 'aint(   ', &
       'cos(    ', 'sin(    ', 'tan(    ', 'exp(    ', 'log(    ', 'abs(    ', &
       'delta(  ', 'step(   ', 'hat(    ', 'max(    ', 'min(    ', 'besj0(  ', &
       'besj1(  ', 'besjn(  ', 'besy0(  ', 'besy1(  ', 'besyn(  ', 'logn(   ', &
       'erf(    ', 'erfc(   ', 'lgamma( ', 'gamma(  ', 'csch(   ', 'sech(   ', &
       'coth(   ', 'if(     ', 'gauss(  ', 'sinc(   ', 'besi0(  ', 'besi1(  ', &
       'besk0(  ', 'besk1(  ', 'ierfc(  ', 'besin(  ', 'beskn(  ', 'cbrt(   ', &
       'fresc(  ', 'fress(  ', 'expi(   ', 'sini(   ', 'cosi(   ', 'logi(   ', &
       'ierf(   ', 'elle(   ', 'ellk(   ', 'ielle(  ', 'iellf(  ', 'modulo( ', &
       'floor(  ', 'ceiling(', 'mod(    '  &
       /)

  integer, dimension(expressionstart:expressionend), parameter :: &
       commandcomps=(/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
       1, 1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, &
       1, 3, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, &
       1, 1, 1, 2, 2, 2, 1, 1, 2 /)
  integer, parameter :: &
       maxcommandcomps=4
  integer, dimension(expressionstart:expressionend) :: expressionslen=len_trim(expressions)

  !  Operators definitions
  integer, parameter :: &
       operatorlength=2, &
       operatorstart=500, &
       conditionalstart=500, &
       neq_=500, eqeq_=501, gteq_=502, eqgt_=503, lteq_=504, eqlt_=505, eq_=506, gt_=507, lt_=508,&
       conditionalend=508, &
       opsstart=509, &
       pow_=509, caret_=510, mult_=511, idiv_=512, div_=513, perc_=514, &
       opsend=514, &
       pmstart=515, &
       plus_=515, minus_=516, &
       pmend=516, &
       operatorend=516

  character(len=operatorlength), dimension(operatorstart:operatorend), parameter :: &
       operators=(/ '!=', '==', '>=', '=>', '<=', '=<', '= ', &
       '> ', '< ', '**', '^ ', '* ', '//', '/ ', '% ', '+ ', '- ' /)

  integer, dimension(operatorstart:operatorend), parameter :: &
       operatorsorder=(/ 10, 10, 10, 10, 10, 10, 10, 10, 10, &
       10000, 10000, 1000, 1000, 1000, 1000, 100, 100 /)
  integer, dimension(operatorstart:operatorend) :: operatorslen=len_trim(operators)

  !  Variable definitions
  integer, parameter :: &
       variablestart=1000, &
       variableend=9999

  ! Separates logical blocks of code
  integer, dimension(10), parameter :: blockseparator = (/ comma_, neq_, eqeq_, gteq_, &
       eqgt_, lteq_, eqlt_, eq_, gt_, lt_ /)

end module params


!Precision
program Precison
    implicit none
    real :: pi = 22.0/7.0
    real(kind=8) :: pi8 = 22.0/7.0
    real(kind=16) :: pi16 = 22.0/7.0

    Print *, pi
    Print *, pi8
    Print *, pi16

end program Precison


*> \brief \b CLADIV2 performs complex division in real arithmetic, avoiding unnecessary overflow. Note that this version, created by Jack Poulson, avoids returning a complex value since this frequently causes problems when interfacing different Fortran libraries (e.g., it caused pzlahqr to return many of the eigenvalues shifted left by one due to zladiv returning 1 instead of 0 within zlanv2).
*
*  Definition:
*  ===========
*
*       SUBROUTINE CLADIV2( X, Y, Z )
*
*       .. Scalar Arguments ..
*       COMPLEX         X, Y, Z
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLADIV2 outputs Z = X / Y, where X and Y are complex.
*> The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is COMPLEX
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is COMPLEX
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is COMPLEX
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*> \author Jack Poulson
*
*> \date September 2015
*
*> \ingroup complex16OTHERauxiliary
*
*  =====================================================================
      SUBROUTINE CLADIV2( X, Y, Z )
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*  -- Modified by Jack Poulson on September 2015
*
*     .. Scalar Arguments ..
      COMPLEX         X, Y, Z
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL   ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL, CMPLX, AIMAG
*     ..
*     .. Executable Statements ..
*
      CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
     $             ZI )
      Z = CMPLX( ZR, ZI )
*
      RETURN
*
*     End of CLADIV2
*
      END


! { dg-options "-O2 -floop-nest-optimize" }

      subroutine linel(icmdl,stre,anisox)
      real*8 stre(6),tkl(3,3),ekl(3,3),anisox(3,3,3,3)
            do m1=1,3
               do m2=1,m1
                  do m3=1,3
                     do m4=1,3
                        tkl(m1,m2)=tkl(m1,m2)+
     &                       anisox(m1,m2,m3,m4)*ekl(m3,m4)
                     enddo
                  enddo
               enddo
            enddo
            stre(1)=tkl(1,1)
      end


module module_my_struct

  type my_struct
     real(8) :: x
     integer :: i
  end type my_struct

  integer, save :: my_type  ! MPI datatype for type(my_struct)
  external      :: my_fun   ! reduction operation for my_type
  integer, save :: my_op    ! MPI operator for my_fun
end

program main  ! user defined datatype and operator

  use module_my_struct
  implicit none
  include 'mpif.h'
  type(my_struct) :: s, res
  integer :: rank, len(2), type(2), ierror
  integer(MPI_ADDRESS_KIND) :: disp(2)

  call mpi_init(ierror)

  len(1) = 1
  len(2) = 1

  call mpi_get_address(s%x, disp(1), ierror)
  call mpi_get_address(s%i, disp(2), ierror)

  disp(2) = disp(2) - disp(1)
  disp(1) = disp(1) - disp(1)

  type(1) = MPI_REAL8
  type(2) = MPI_INTEGER

  call mpi_type_create_struct(2, len, disp, type, my_type, ierror)
  call mpi_type_commit(my_type, ierror)
  call mpi_op_create(my_fun, .true., my_op, ierror)
  call mpi_comm_rank(MPI_COMM_WORLD, rank, ierror)

  s%x = rank
  s%i = rank

  call mpi_reduce(s, res, 1, my_type, my_op, 0, MPI_COMM_WORLD, ierror)

  if (rank == 0) write(6,*) "result: ", res%x, res%i

  call mpi_type_free(my_type, ierror)
  call mpi_op_free(my_op, ierror)
  call mpi_finalize(ierror)
end

subroutine my_fun(in, inout, len, type)

  use module_my_struct, exclude => my_fun
  implicit none
  include 'mpif.h'
  type(my_struct), intent(in) :: in(*)
  type(my_struct), intent(inout) :: inout(*)
  integer, intent(in) :: len, type
  integer :: i, ierror

  if (type == my_type) then
     do i = 1, len
        inout(i)%x = inout(i)%x + in(i)%x
        inout(i)%i = inout(i)%i + in(i)%i
     enddo
  else
     write(0,*) "my_fun: unknown type"
     call mpi_abort(MPI_COMM_WORLD, 1, ierror)
  endif
end


! { dg-do  run }
! PR 66113 - this used to ICE with deeply nested BLOCKS.
program main
  integer :: n
  real :: s
  n = 3
  block
    block
      block
        block
          block
            real, dimension(n) :: a
            a = 3.
            s = sum(a)
          end block
        end block
      end block
    end block
  end block
  if (s /= 9) STOP 1
end program main


C ABSTRACT:
C   Simulated annealing is a global optimization method that distinguishes
C   between different local optima. Starting from an initial point, the
C   algorithm takes a step and the function is evaluated. When minimizing a
C   function, any downhill step is accepted and the process repeats from this
C   new point. An uphill step may be accepted. Thus, it can escape from local
C   optima. This uphill decision is made by the Metropolis criteria. As the
C   optimization process proceeds, the length of the steps decline and the
C   algorithm closes in on the global optimum. Since the algorithm makes very
C   few assumptions regarding the function to be optimized, it is quite
C   robust with respect to non-quadratic surfaces. The degree of robustness
C   can be adjusted by the user. In fact, simulated annealing can be used as
C   a local optimizer for difficult functions.
C
C   This implementation of simulated annealing was used in "Global Optimization
C   of Statistical Functions with Simulated Annealing," Goffe, Ferrier and
C   Rogers, Journal of Econometrics, vol. 60, no. 1/2, Jan./Feb. 1994, pp.
C   65-100. Briefly, we found it competitive, if not superior, to multiple
C   restarts of conventional optimization routines for difficult optimization
C   problems.
C
C   For more information on this routine, contact its author:
C   Bill Goffe, bgoffe@whale.st.usm.edu
C
      PROGRAM SIMANN
C  This file is an example of the Corana et al. simulated annealing
C  algorithm for multimodal and robust optimization as implemented
C  and modified by Goffe, Ferrier and Rogers. Counting the above line
C  ABSTRACT as 1, the routine itself (SA), with its supplementary
C  routines, is on lines 232-990. A multimodal example from Judge et al.
C  (FCN) is on lines 150-231. The rest of this file (lines 1-149) is a
C  driver routine with values appropriate for the Judge example. Thus, this
C  example is ready to run.
C
C  To understand the algorithm, the documentation for SA on lines 236-
C  484 should be read along with the parts of the paper that describe
C  simulated annealing. Then the following lines will then aid the user
C  in becomming proficient with this implementation of simulated
C  annealing.
C
C  Learning to use SA:
C      Use the sample function from Judge with the following suggestions
C  to get a feel for how SA works. When you've done this, you should be
C  ready to use it on most any function with a fair amount of expertise.
C    1. Run the program as is to make sure it runs okay. Take a look at
C       the intermediate output and see how it optimizes as temperature
C       (T) falls. Notice how the optimal point is reached and how
C       falling T reduces VM.
C    2. Look through the documentation to SA so the following makes a
C       bit of sense. In line with the paper, it shouldn't be that hard
C       to figure out. The core of the algorithm is described on pp. 68-70
C       and on pp. 94-95. Also see Corana et al. pp. 264-9.
C    3. To see how it selects points and makes decisions about uphill
C       and downhill moves, set IPRINT = 3 (very detailed intermediate
C       output) and MAXEVL = 100 (only 100 function evaluations to limit
C       output).
C    4. To see the importance of different temperatures, try starting
C       with a very low one (say T = 10E-5). You'll see (i) it never
C       escapes from the local optima (in annealing terminology, it
C       quenches) & (ii) the step length (VM) will be quite small. This
C       is a key part of the algorithm: as temperature (T) falls, step
C       length does too. In a minor point here, note how VM is quickly
C       reset from its initial value. Thus, the input VM is not very
C       important. This is all the more reason to examine VM once the
C       algorithm is underway.
C    5. To see the effect of different parameters and their effect on
C       the speed of the algorithm, try RT = .95 & RT = .1. Notice the
C       vastly different speed for optimization. Also try NT = 20. Note
C       that this sample function is quite easy to optimize, so it will
C       tolerate big changes in these parameters. RT and NT are the
C       parameters one should adjust to modify the runtime of the
C       algorithm and its robustness.
C    6. Try constraining the algorithm with either LB or UB.

      PARAMETER (N = 2, NEPS = 4)

      DOUBLE PRECISION  LB(N), UB(N), X(N), XOPT(N), C(N), VM(N),
     1                  FSTAR(NEPS), XP(N), T, EPS, RT, FOPT

      INTEGER  NACP(N), NS, NT, NFCNEV, IER, ISEED1, ISEED2,
     1         MAXEVL, IPRINT, NACC, NOBDS

      LOGICAL  MAX

      EXTERNAL FCN

C  Set underflows to zero on IBM mainframes.
C     CALL XUFLOW(0)

C  Set input parameters.
      MAX = .FALSE.
      EPS = 1.0D-6
      RT = .5
      ISEED1 = 1
      ISEED2 = 2
      NS = 20
      NT = 5
      MAXEVL = 100 000
      IPRINT = 1
      DO 10, I = 1, N
         LB(I) = -1.0D25
         UB(I) =  1.0D25
         C(I) = 2.0
10    CONTINUE

C  Note start at local, but not global, optima of the Judge function.
      X(1) =  2.354471
      X(2) = -0.319186

C  Set input values of the input/output parameters.
      T = 5.0
      DO 20, I = 1, N
         VM(I) = 1.0
 20   CONTINUE

      WRITE(*,1000) N, MAX, T, RT, EPS, NS, NT, NEPS, MAXEVL, IPRINT,
     1              ISEED1, ISEED2

      CALL PRTVEC(X,N,'STARTING VALUES')
      CALL PRTVEC(VM,N,'INITIAL STEP LENGTH')
      CALL PRTVEC(LB,N,'LOWER BOUND')
      CALL PRTVEC(UB,N,'UPPER BOUND')
      CALL PRTVEC(C,N,'C VECTOR')
      WRITE(*,'(/,''  ****   END OF DRIVER ROUTINE OUTPUT   ****''
     1          /,''  ****   BEFORE CALL TO SA.             ****'')')

      CALL SA(N,X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,C,IPRINT,ISEED1,
     1        ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER,
     2        FSTAR,XP,NACP)

      WRITE(*,'(/,''  ****   RESULTS AFTER SA   ****   '')')
      CALL PRTVEC(XOPT,N,'SOLUTION')
      CALL PRTVEC(VM,N,'FINAL STEP LENGTH')
      WRITE(*,1001) FOPT, NFCNEV, NACC, NOBDS, T, IER

1000  FORMAT(/,' SIMULATED ANNEALING EXAMPLE',/,
     1       /,' NUMBER OF PARAMETERS: ',I3,'   MAXIMAZATION: ',L5,
     2       /,' INITIAL TEMP: ', G8.2, '   RT: ',G8.2, '   EPS: ',G8.2,
     3       /,' NS: ',I3, '   NT: ',I2, '   NEPS: ',I2,
     4       /,' MAXEVL: ',I10, '   IPRINT: ',I1, '   ISEED1: ',I4,
     5       '   ISEED2: ',I4)
1001  FORMAT(/,' OPTIMAL FUNCTION VALUE: ',G20.13
     1       /,' NUMBER OF FUNCTION EVALUATIONS:     ',I10,
     2       /,' NUMBER OF ACCEPTED EVALUATIONS:     ',I10,
     3       /,' NUMBER OF OUT OF BOUND EVALUATIONS: ',I10,
     4       /,' FINAL TEMP: ', G20.13,'  IER: ', I3)

      STOP
      END

      SUBROUTINE FCN(N,THETA,H)
C  This subroutine is from the example in Judge et al., The Theory and
C  Practice of Econometrics, 2nd ed., pp. 956-7. There are two optima:
C  F(.864,1.23) = 16.0817 (the global minumum) and F(2.35,-.319) = 20.9805.

      DOUBLE PRECISION THETA(2), H

      DOUBLE PRECISION Y(20), X2(20), X3(20)

      Y(1) = 4.284
      Y(2) = 4.149
      Y(3) = 3.877
      Y(4) = 0.533
      Y(5) = 2.211
      Y(6) = 2.389
      Y(7) = 2.145
      Y(8) = 3.231
      Y(9) = 1.998
      Y(10) = 1.379
      Y(11) = 2.106
      Y(12) = 1.428
      Y(13) = 1.011
      Y(14) = 2.179
      Y(15) = 2.858
      Y(16) = 1.388
      Y(17) = 1.651
      Y(18) = 1.593
      Y(19) = 1.046
      Y(20) = 2.152

      X2(1) =  .286
      X2(2) =  .973
      X2(3) =  .384
      X2(4) =  .276
      X2(5) =  .973
      X2(6) =  .543
      X2(7) =  .957
      X2(8) =  .948
      X2(9) =  .543
      X2(10) =  .797
      X2(11) =  .936
      X2(12) =  .889
      X2(13) =  .006
      X2(14) =  .828
      X2(15) =  .399
      X2(16) =  .617
      X2(17) =  .939
      X2(18) =  .784
      X2(19) =  .072
      X2(20) =  .889

      X3(1) = .645
      X3(2) = .585
      X3(3) = .310
      X3(4) = .058
      X3(5) = .455
      X3(6) = .779
      X3(7) = .259
      X3(8) = .202
      X3(9) = .028
      X3(10) = .099
      X3(11) = .142
      X3(12) = .296
      X3(13) = .175
      X3(14) = .180
      X3(15) = .842
      X3(16) = .039
      X3(17) = .103
      X3(18) = .620
      X3(19) = .158
      X3(20) = .704

      H = 0.0
      DO 100, I = 1, 20
         H = (THETA(1) + THETA(2)*X2(I) + (THETA(2)**2)*X3(I) - Y(I))**2
     1       + H
100   CONTINUE

      RETURN
      END

      SUBROUTINE SA(N,X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,C,IPRINT,
     1              ISEED1,ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER,
     2              FSTAR,XP,NACP)

C  Version: 3.2
C  Date: 1/22/94.
C  Differences compared to Version 2.0:
C     1. If a trial is out of bounds, a point is randomly selected
C        from LB(i) to UB(i). Unlike in version 2.0, this trial is
C        evaluated and is counted in acceptances and rejections.
C        All corresponding documentation was changed as well.
C  Differences compared to Version 3.0:
C     1. If VM(i) > (UB(i) - LB(i)), VM is set to UB(i) - LB(i).
C        The idea is that if T is high relative to LB & UB, most
C        points will be accepted, causing VM to rise. But, in this
C        situation, VM has little meaning; particularly if VM is
C        larger than the acceptable region. Setting VM to this size
C        still allows all parts of the allowable region to be selected.
C  Differences compared to Version 3.1:
C     1. Test made to see if the initial temperature is positive.
C     2. WRITE statements prettied up.
C     3. References to paper updated.
C
C  Synopsis:
C  This routine implements the continuous simulated annealing global
C  optimization algorithm described in Corana et al.'s article
C  "Minimizing Multimodal Functions of Continuous Variables with the
C  "Simulated Annealing" Algorithm" in the September 1987 (vol. 13,
C  no. 3, pp. 262-280) issue of the ACM Transactions on Mathematical
C  Software.
C
C  A very quick (perhaps too quick) overview of SA:
C     SA tries to find the global optimum of an N dimensional function.
C  It moves both up and downhill and as the optimization process
C  proceeds, it focuses on the most promising area.
C     To start, it randomly chooses a trial point within the step length
C  VM (a vector of length N) of the user selected starting point. The
C  function is evaluated at this trial point and its value is compared
C  to its value at the initial point.
C     In a maximization problem, all uphill moves are accepted and the
C  algorithm continues from that trial point. Downhill moves may be
C  accepted; the decision is made by the Metropolis criteria. It uses T
C  (temperature) and the size of the downhill move in a probabilistic
C  manner. The smaller T and the size of the downhill move are, the more
C  likely that move will be accepted. If the trial is accepted, the
C  algorithm moves on from that point. If it is rejected, another point
C  is chosen instead for a trial evaluation.
C     Each element of VM periodically adjusted so that half of all
C  function evaluations in that direction are accepted.
C     A fall in T is imposed upon the system with the RT variable by
C  T(i+1) = RT*T(i) where i is the ith iteration. Thus, as T declines,
C  downhill moves are less likely to be accepted and the percentage of
C  rejections rise. Given the scheme for the selection for VM, VM falls.
C  Thus, as T declines, VM falls and SA focuses upon the most promising
C  area for optimization.
C
C  The importance of the parameter T:
C     The parameter T is crucial in using SA successfully. It influences
C  VM, the step length over which the algorithm searches for optima. For
C  a small intial T, the step length may be too small; thus not enough
C  of the function might be evaluated to find the global optima. The user
C  should carefully examine VM in the intermediate output (set IPRINT =
C  1) to make sure that VM is appropriate. The relationship between the
C  initial temperature and the resulting step length is function
C  dependent.
C     To determine the starting temperature that is consistent with
C  optimizing a function, it is worthwhile to run a trial run first. Set
C  RT = 1.5 and T = 1.0. With RT > 1.0, the temperature increases and VM
C  rises as well. Then select the T that produces a large enough VM.
C
C  For modifications to the algorithm and many details on its use,
C  (particularly for econometric applications) see Goffe, Ferrier
C  and Rogers, "Global Optimization of Statistical Functions with
C  Simulated Annealing," Journal of Econometrics, vol. 60, no. 1/2,
C  Jan./Feb. 1994, pp. 65-100.
C  For more information, contact
C              Bill Goffe
C              Department of Economics and International Business
C              University of Southern Mississippi
C              Hattiesburg, MS  39506-5072
C              (601) 266-4484 (office)
C              (601) 266-4920 (fax)
C              bgoffe@whale.st.usm.edu (Internet)
C
C  As far as possible, the parameters here have the same name as in
C  the description of the algorithm on pp. 266-8 of Corana et al.
C
C  In this description, SP is single precision, DP is double precision,
C  INT is integer, L is logical and (N) denotes an array of length n.
C  Thus, DP(N) denotes a double precision array of length n.
C
C  Input Parameters:
C    Note: The suggested values generally come from Corana et al. To
C          drastically reduce runtime, see Goffe et al., pp. 90-1 for
C          suggestions on choosing the appropriate RT and NT.
C    N - Number of variables in the function to be optimized. (INT)
C    X - The starting values for the variables of the function to be
C        optimized. (DP(N))
C    MAX - Denotes whether the function should be maximized or
C          minimized. A true value denotes maximization while a false
C          value denotes minimization. Intermediate output (see IPRINT)
C          takes this into account. (L)
C    RT - The temperature reduction factor. The value suggested by
C         Corana et al. is .85. See Goffe et al. for more advice. (DP)
C    EPS - Error tolerance for termination. If the final function
C          values from the last neps temperatures differ from the
C          corresponding value at the current temperature by less than
C          EPS and the final function value at the current temperature
C          differs from the current optimal function value by less than
C          EPS, execution terminates and IER = 0 is returned. (EP)
C    NS - Number of cycles. After NS*N function evaluations, each
C         element of VM is adjusted so that approximately half of
C         all function evaluations are accepted. The suggested value
C         is 20. (INT)
C    NT - Number of iterations before temperature reduction. After
C         NT*NS*N function evaluations, temperature (T) is changed
C         by the factor RT. Value suggested by Corana et al. is
C         MAX(100, 5*N). See Goffe et al. for further advice. (INT)
C    NEPS - Number of final function values used to decide upon termi-
C           nation. See EPS. Suggested value is 4. (INT)
C    MAXEVL - The maximum number of function evaluations. If it is
C             exceeded, IER = 1. (INT)
C    LB - The lower bound for the allowable solution variables. (DP(N))
C    UB - The upper bound for the allowable solution variables. (DP(N))
C         If the algorithm chooses X(I) .LT. LB(I) or X(I) .GT. UB(I),
C         I = 1, N, a point is from inside is randomly selected. This
C         This focuses the algorithm on the region inside UB and LB.
C         Unless the user wishes to concentrate the search to a par-
C         ticular region, UB and LB should be set to very large positive
C         and negative values, respectively. Note that the starting
C         vector X should be inside this region. Also note that LB and
C         UB are fixed in position, while VM is centered on the last
C         accepted trial set of variables that optimizes the function.
C    C - Vector that controls the step length adjustment. The suggested
C        value for all elements is 2.0. (DP(N))
C    IPRINT - controls printing inside SA. (INT)
C             Values: 0 - Nothing printed.
C                     1 - Function value for the starting value and
C                         summary results before each temperature
C                         reduction. This includes the optimal
C                         function value found so far, the total
C                         number of moves (broken up into uphill,
C                         downhill, accepted and rejected), the
C                         number of out of bounds trials, the
C                         number of new optima found at this
C                         temperature, the current optimal X and
C                         the step length VM. Note that there are
C                         N*NS*NT function evalutations before each
C                         temperature reduction. Finally, notice is
C                         is also given upon achieveing the termination
C                         criteria.
C                     2 - Each new step length (VM), the current optimal
C                         X (XOPT) and the current trial X (X). This
C                         gives the user some idea about how far X
C                         strays from XOPT as well as how VM is adapting
C                         to the function.
C                     3 - Each function evaluation, its acceptance or
C                         rejection and new optima. For many problems,
C                         this option will likely require a small tree
C                         if hard copy is used. This option is best
C                         used to learn about the algorithm. A small
C                         value for MAXEVL is thus recommended when
C                         using IPRINT = 3.
C             Suggested value: 1
C             Note: For a given value of IPRINT, the lower valued
C                   options (other than 0) are utilized.
C    ISEED1 - The first seed for the random number generator RANMAR.
C             0 .LE. ISEED1 .LE. 31328. (INT)
C    ISEED2 - The second seed for the random number generator RANMAR.
C             0 .LE. ISEED2 .LE. 30081. Different values for ISEED1
C             and ISEED2 will lead to an entirely different sequence
C             of trial points and decisions on downhill moves (when
C             maximizing). See Goffe et al. on how this can be used
C             to test the results of SA. (INT)
C
C  Input/Output Parameters:
C    T - On input, the initial temperature. See Goffe et al. for advice.
C        On output, the final temperature. (DP)
C    VM - The step length vector. On input it should encompass the
C         region of interest given the starting value X. For point
C         X(I), the next trial point is selected is from X(I) - VM(I)
C         to  X(I) + VM(I). Since VM is adjusted so that about half
C         of all points are accepted, the input value is not very
C         important (i.e. is the value is off, SA adjusts VM to the
C         correct value). (DP(N))
C
C  Output Parameters:
C    XOPT - The variables that optimize the function. (DP(N))
C    FOPT - The optimal value of the function. (DP)
C    NACC - The number of accepted function evaluations. (INT)
C    NFCNEV - The total number of function evaluations. In a minor
C             point, note that the first evaluation is not used in the
C             core of the algorithm; it simply initializes the
C             algorithm. (INT).
C    NOBDS - The total number of trial function evaluations that
C            would have been out of bounds of LB and UB. Note that
C            a trial point is randomly selected between LB and UB.
C            (INT)
C    IER - The error return number. (INT)
C          Values: 0 - Normal return; termination criteria achieved.
C                  1 - Number of function evaluations (NFCNEV) is
C                      greater than the maximum number (MAXEVL).
C                  2 - The starting value (X) is not inside the
C                      bounds (LB and UB).
C                  3 - The initial temperature is not positive.
C                  99 - Should not be seen; only used internally.
C
C  Work arrays that must be dimensioned in the calling routine:
C       RWK1 (DP(NEPS))  (FSTAR in SA)
C       RWK2 (DP(N))     (XP    "  " )
C       IWK  (INT(N))    (NACP  "  " )
C
C  Required Functions (included):
C    EXPREP - Replaces the function EXP to avoid under- and overflows.
C             It may have to be modified for non IBM-type main-
C             frames. (DP)
C    RMARIN - Initializes the random number generator RANMAR.
C    RANMAR - The actual random number generator. Note that
C             RMARIN must run first (SA does this). It produces uniform
C             random numbers on [0,1]. These routines are from
C             Usenet's comp.lang.fortran. For a reference, see
C             "Toward a Universal Random Number Generator"
C             by George Marsaglia and Arif Zaman, Florida State
C             University Report: FSU-SCRI-87-50 (1987).
C             It was later modified by F. James and published in
C             "A Review of Pseudo-random Number Generators." For
C             further information, contact stuart@ads.com. These
C             routines are designed to be portable on any machine
C             with a 24-bit or more mantissa. I have found it produces
C             identical results on a IBM 3081 and a Cray Y-MP.
C
C  Required Subroutines (included):
C    PRTVEC - Prints vectors.
C    PRT1 ... PRT10 - Prints intermediate output.
C    FCN - Function to be optimized. The form is
C            SUBROUTINE FCN(N,X,F)
C            INTEGER N
C            DOUBLE PRECISION  X(N), F
C            ...
C            function code with F = F(X)
C            ...
C            RETURN
C            END
C          Note: This is the same form used in the multivariable
C          minimization algorithms in the IMSL edition 10 library.
C
C  Machine Specific Features:
C    1. EXPREP may have to be modified if used on non-IBM type main-
C       frames. Watch for under- and overflows in EXPREP.
C    2. Some FORMAT statements use G25.18; this may be excessive for
C       some machines.
C    3. RMARIN and RANMAR are designed to be protable; they should not
C       cause any problems.

C  Type all external variables.
      DOUBLE PRECISION  X(*), LB(*), UB(*), C(*), VM(*), FSTAR(*),
     1                  XOPT(*), XP(*), T, EPS, RT, FOPT
      INTEGER  NACP(*), N, NS, NT, NEPS, NACC, MAXEVL, IPRINT,
     1         NOBDS, IER, NFCNEV, ISEED1, ISEED2
      LOGICAL  MAX

C  Type all internal variables.
      DOUBLE PRECISION  F, FP, P, PP, RATIO
      INTEGER  NUP, NDOWN, NREJ, NNEW, LNOBDS, H, I, J, M
      LOGICAL  QUIT

C  Type all functions.
      DOUBLE PRECISION  EXPREP
      REAL  RANMAR

C  Initialize the random number generator RANMAR.
      CALL RMARIN(ISEED1,ISEED2)

C  Set initial values.
      NACC = 0
      NOBDS = 0
      NFCNEV = 0
      IER = 99

      DO 10, I = 1, N
         XOPT(I) = X(I)
         NACP(I) = 0
10    CONTINUE

      DO 20, I = 1, NEPS
         FSTAR(I) = 1.0D+20
20    CONTINUE

C  If the initial temperature is not positive, notify the user and
C  return to the calling routine.
      IF (T .LE. 0.0) THEN
         WRITE(*,'(/,''  THE INITIAL TEMPERATURE IS NOT POSITIVE. ''
     1             /,''  RESET THE VARIABLE T. ''/)')
         IER = 3
         RETURN
      END IF

C  If the initial value is out of bounds, notify the user and return
C  to the calling routine.
      DO 30, I = 1, N
         IF ((X(I) .GT. UB(I)) .OR. (X(I) .LT. LB(I))) THEN
            CALL PRT1
            IER = 2
            RETURN
         END IF
30    CONTINUE

C  Evaluate the function with input X and return value as F.
      CALL FCN(N,X,F)

C  If the function is to be minimized, switch the sign of the function.
C  Note that all intermediate and final output switches the sign back
C  to eliminate any possible confusion for the user.
      IF(.NOT. MAX) F = -F
      NFCNEV = NFCNEV + 1
      FOPT = F
      FSTAR(1) = F
      IF(IPRINT .GE. 1) CALL PRT2(MAX,N,X,F)

C  Start the main loop. Note that it terminates if (i) the algorithm
C  succesfully optimizes the function or (ii) there are too many
C  function evaluations (more than MAXEVL).
100   NUP = 0
      NREJ = 0
      NNEW = 0
      NDOWN = 0
      LNOBDS = 0

      DO 400, M = 1, NT
         DO 300, J = 1, NS
            DO 200, H = 1, N

C  Generate XP, the trial value of X. Note use of VM to choose XP.
               DO 110, I = 1, N
                  IF (I .EQ. H) THEN
                     XP(I) = X(I) + (RANMAR()*2.- 1.) * VM(I)
                  ELSE
                     XP(I) = X(I)
                  END IF

C  If XP is out of bounds, select a point in bounds for the trial.
                  IF((XP(I) .LT. LB(I)) .OR. (XP(I) .GT. UB(I))) THEN
                    XP(I) = LB(I) + (UB(I) - LB(I))*RANMAR()
                    LNOBDS = LNOBDS + 1
                    NOBDS = NOBDS + 1
                    IF(IPRINT .GE. 3) CALL PRT3(MAX,N,XP,X,FP,F)
                  END IF
110            CONTINUE

C  Evaluate the function with the trial point XP and return as FP.
               CALL FCN(N,XP,FP)
               IF(.NOT. MAX) FP = -FP
               NFCNEV = NFCNEV + 1
               IF(IPRINT .GE. 3) CALL PRT4(MAX,N,XP,X,FP,F)

C  If too many function evaluations occur, terminate the algorithm.
               IF(NFCNEV .GE. MAXEVL) THEN
                  CALL PRT5
                  IF (.NOT. MAX) FOPT = -FOPT
                  IER = 1
                  RETURN
               END IF

C  Accept the new point if the function value increases.
               IF(FP .GE. F) THEN
                  IF(IPRINT .GE. 3) THEN
                     WRITE(*,'(''  POINT ACCEPTED'')')
                  END IF
                  DO 120, I = 1, N
                     X(I) = XP(I)
120               CONTINUE
                  F = FP
                  NACC = NACC + 1
                  NACP(H) = NACP(H) + 1
                  NUP = NUP + 1

C  If greater than any other point, record as new optimum.
                  IF (FP .GT. FOPT) THEN
                  IF(IPRINT .GE. 3) THEN
                     WRITE(*,'(''  NEW OPTIMUM'')')
                  END IF
                     DO 130, I = 1, N
                        XOPT(I) = XP(I)
130                  CONTINUE
                     FOPT = FP
                     NNEW = NNEW + 1
                  END IF

C  If the point is lower, use the Metropolis criteria to decide on
C  acceptance or rejection.
               ELSE
                  P = EXPREP((FP - F)/T)
                  PP = RANMAR()
                  IF (PP .LT. P) THEN
                     IF(IPRINT .GE. 3) CALL PRT6(MAX)
                     DO 140, I = 1, N
                        X(I) = XP(I)
140                  CONTINUE
                     F = FP
                     NACC = NACC + 1
                     NACP(H) = NACP(H) + 1
                     NDOWN = NDOWN + 1
                  ELSE
                     NREJ = NREJ + 1
                     IF(IPRINT .GE. 3) CALL PRT7(MAX)
                  END IF
               END IF

200         CONTINUE
300      CONTINUE

C  Adjust VM so that approximately half of all evaluations are accepted.
         DO 310, I = 1, N
            RATIO = DFLOAT(NACP(I)) /DFLOAT(NS)
            IF (RATIO .GT. .6) THEN
               VM(I) = VM(I)*(1. + C(I)*(RATIO - .6)/.4)
            ELSE IF (RATIO .LT. .4) THEN
               VM(I) = VM(I)/(1. + C(I)*((.4 - RATIO)/.4))
            END IF
            IF (VM(I) .GT. (UB(I)-LB(I))) THEN
               VM(I) = UB(I) - LB(I)
            END IF
310      CONTINUE

         IF(IPRINT .GE. 2) THEN
            CALL PRT8(N,VM,XOPT,X)
         END IF

         DO 320, I = 1, N
            NACP(I) = 0
320      CONTINUE

400   CONTINUE

      IF(IPRINT .GE. 1) THEN
         CALL PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW)
      END IF

C  Check termination criteria.
      QUIT = .FALSE.
      FSTAR(1) = F
      IF ((FOPT - FSTAR(1)) .LE. EPS) QUIT = .TRUE.
      DO 410, I = 1, NEPS
         IF (ABS(F - FSTAR(I)) .GT. EPS) QUIT = .FALSE.
410   CONTINUE

C  Terminate SA if appropriate.
      IF (QUIT) THEN
         DO 420, I = 1, N
            X(I) = XOPT(I)
420      CONTINUE
         IER = 0
         IF (.NOT. MAX) FOPT = -FOPT
         IF(IPRINT .GE. 1) CALL PRT10
         RETURN
      END IF

C  If termination criteria is not met, prepare for another loop.
      T = RT*T
      DO 430, I = NEPS, 2, -1
         FSTAR(I) = FSTAR(I-1)
430   CONTINUE
      F = FOPT
      DO 440, I = 1, N
         X(I) = XOPT(I)
440   CONTINUE

C  Loop again.
      GO TO 100

      END

      FUNCTION  EXPREP(RDUM)
C  This function replaces exp to avoid under- and overflows and is
C  designed for IBM 370 type machines. It may be necessary to modify
C  it for other machines. Note that the maximum and minimum values of
C  EXPREP are such that they has no effect on the algorithm.

      DOUBLE PRECISION  RDUM, EXPREP

      IF (RDUM .GT. 174.) THEN
         EXPREP = 3.69D+75
      ELSE IF (RDUM .LT. -180.) THEN
         EXPREP = 0.0
      ELSE
         EXPREP = EXP(RDUM)
      END IF

      RETURN
      END

      subroutine RMARIN(IJ,KL)
C  This subroutine and the next function generate random numbers. See
C  the comments for SA for more information. The only changes from the
C  orginal code is that (1) the test to make sure that RMARIN runs first
C  was taken out since SA assures that this is done (this test didn't
C  compile under IBM's VS Fortran) and (2) typing ivec as integer was
C  taken out since ivec isn't used. With these exceptions, all following
C  lines are original.

C This is the initialization routine for the random number generator
C     RANMAR()
C NOTE: The seed variables can have values between:    0 <= IJ <= 31328
C                                                      0 <= KL <= 30081
      real U(97), C, CD, CM
      integer I97, J97
      common /raset1/ U, C, CD, CM, I97, J97
      if( IJ .lt. 0  .or.  IJ .gt. 31328  .or.
     *    KL .lt. 0  .or.  KL .gt. 30081 ) then
          print '(A)', ' The first random number seed must have a value
     *between 0 and 31328'
          print '(A)',' The second seed must have a value between 0 and
     *30081'
            stop
      endif
      i = mod(IJ/177, 177) + 2
      j = mod(IJ    , 177) + 2
      k = mod(KL/169, 178) + 1
      l = mod(KL,     169)
      do 2 ii = 1, 97
         s = 0.0
         t = 0.5
         do 3 jj = 1, 24
            m = mod(mod(i*j, 179)*k, 179)
            i = j
            j = k
            k = m
            l = mod(53*l+1, 169)
            if (mod(l*m, 64) .ge. 32) then
               s = s + t
            endif
            t = 0.5 * t
3        continue
         U(ii) = s
2     continue
      C = 362436.0 / 16777216.0
      CD = 7654321.0 / 16777216.0
      CM = 16777213.0 /16777216.0
      I97 = 97
      J97 = 33
      return
      end

      function ranmar()
      real U(97), C, CD, CM
      integer I97, J97
      common /raset1/ U, C, CD, CM, I97, J97
         uni = U(I97) - U(J97)
         if( uni .lt. 0.0 ) uni = uni + 1.0
         U(I97) = uni
         I97 = I97 - 1
         if(I97 .eq. 0) I97 = 97
         J97 = J97 - 1
         if(J97 .eq. 0) J97 = 97
         C = C - CD
         if( C .lt. 0.0 ) C = C + CM
         uni = uni - C
         if( uni .lt. 0.0 ) uni = uni + 1.0
         RANMAR = uni
      return
      END

      SUBROUTINE PRT1
C  This subroutine prints intermediate output, as does PRT2 through
C  PRT10. Note that if SA is minimizing the function, the sign of the
C  function value and the directions (up/down) are reversed in all
C  output to correspond with the actual function optimization. This
C  correction is because SA was written to maximize functions and
C  it minimizes by maximizing the negative a function.

      WRITE(*,'(/,''  THE STARTING VALUE (X) IS OUTSIDE THE BOUNDS ''
     1          /,''  (LB AND UB). EXECUTION TERMINATED WITHOUT ANY''
     2          /,''  OPTIMIZATION. RESPECIFY X, UB OR LB SO THAT  ''
     3          /,''  LB(I) .LT. X(I) .LT. UB(I), I = 1, N. ''/)')

      RETURN
      END

      SUBROUTINE PRT2(MAX,N,X,F)

      DOUBLE PRECISION  X(*), F
      INTEGER  N
      LOGICAL  MAX

      WRITE(*,'(''  '')')
      CALL PRTVEC(X,N,'INITIAL X')
      IF (MAX) THEN
         WRITE(*,'(''  INITIAL F: '',/, G25.18)') F
      ELSE
         WRITE(*,'(''  INITIAL F: '',/, G25.18)') -F
      END IF

      RETURN
      END

      SUBROUTINE PRT3(MAX,N,XP,X,FP,F)

      DOUBLE PRECISION  XP(*), X(*), FP, F
      INTEGER  N
      LOGICAL  MAX

      WRITE(*,'(''  '')')
      CALL PRTVEC(X,N,'CURRENT X')
      IF (MAX) THEN
         WRITE(*,'(''  CURRENT F: '',G25.18)') F
      ELSE
         WRITE(*,'(''  CURRENT F: '',G25.18)') -F
      END IF
      CALL PRTVEC(XP,N,'TRIAL X')
      WRITE(*,'(''  POINT REJECTED SINCE OUT OF BOUNDS'')')

      RETURN
      END

      SUBROUTINE PRT4(MAX,N,XP,X,FP,F)

      DOUBLE PRECISION  XP(*), X(*), FP, F
      INTEGER  N
      LOGICAL  MAX

      WRITE(*,'(''  '')')
      CALL PRTVEC(X,N,'CURRENT X')
      IF (MAX) THEN
         WRITE(*,'(''  CURRENT F: '',G25.18)') F
         CALL PRTVEC(XP,N,'TRIAL X')
         WRITE(*,'(''  RESULTING F: '',G25.18)') FP
      ELSE
         WRITE(*,'(''  CURRENT F: '',G25.18)') -F
         CALL PRTVEC(XP,N,'TRIAL X')
         WRITE(*,'(''  RESULTING F: '',G25.18)') -FP
      END IF

      RETURN
      END

      SUBROUTINE PRT5

      WRITE(*,'(/,''  TOO MANY FUNCTION EVALUATIONS; CONSIDER ''
     1          /,''  INCREASING MAXEVL OR EPS, OR DECREASING ''
     2          /,''  NT OR RT. THESE RESULTS ARE LIKELY TO BE ''
     3          /,''  POOR.'',/)')

      RETURN
      END

      SUBROUTINE PRT6(MAX)

      LOGICAL  MAX

      IF (MAX) THEN
         WRITE(*,'(''  THOUGH LOWER, POINT ACCEPTED'')')
      ELSE
         WRITE(*,'(''  THOUGH HIGHER, POINT ACCEPTED'')')
      END IF

      RETURN
      END

      SUBROUTINE PRT7(MAX)

      LOGICAL  MAX

      IF (MAX) THEN
         WRITE(*,'(''  LOWER POINT REJECTED'')')
      ELSE
         WRITE(*,'(''  HIGHER POINT REJECTED'')')
      END IF

      RETURN
      END

      SUBROUTINE PRT8(N,VM,XOPT,X)

      DOUBLE PRECISION  VM(*), XOPT(*), X(*)
      INTEGER  N

      WRITE(*,'(/,
     1  '' INTERMEDIATE RESULTS AFTER STEP LENGTH ADJUSTMENT'',/)')
      CALL PRTVEC(VM,N,'NEW STEP LENGTH (VM)')
      CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X')
      CALL PRTVEC(X,N,'CURRENT X')
      WRITE(*,'('' '')')

      RETURN
      END

      SUBROUTINE PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW)

      DOUBLE PRECISION  XOPT(*), VM(*), T, FOPT
      INTEGER  N, NUP, NDOWN, NREJ, LNOBDS, NNEW, TOTMOV
      LOGICAL  MAX

      TOTMOV = NUP + NDOWN + NREJ

      WRITE(*,'(/,
     1  '' INTERMEDIATE RESULTS BEFORE NEXT TEMPERATURE REDUCTION'',/)')
      WRITE(*,'(''  CURRENT TEMPERATURE:            '',G12.5)') T
      IF (MAX) THEN
         WRITE(*,'(''  MAX FUNCTION VALUE SO FAR:  '',G25.18)') FOPT
         WRITE(*,'(''  TOTAL MOVES:                '',I8)') TOTMOV
         WRITE(*,'(''     UPHILL:                  '',I8)') NUP
         WRITE(*,'(''     ACCEPTED DOWNHILL:       '',I8)') NDOWN
         WRITE(*,'(''     REJECTED DOWNHILL:       '',I8)') NREJ
         WRITE(*,'(''  OUT OF BOUNDS TRIALS:       '',I8)') LNOBDS
         WRITE(*,'(''  NEW MAXIMA THIS TEMPERATURE:'',I8)') NNEW
      ELSE
         WRITE(*,'(''  MIN FUNCTION VALUE SO FAR:  '',G25.18)') -FOPT
         WRITE(*,'(''  TOTAL MOVES:                '',I8)') TOTMOV
         WRITE(*,'(''     DOWNHILL:                '',I8)')  NUP
         WRITE(*,'(''     ACCEPTED UPHILL:         '',I8)')  NDOWN
         WRITE(*,'(''     REJECTED UPHILL:         '',I8)')  NREJ
         WRITE(*,'(''  TRIALS OUT OF BOUNDS:       '',I8)')  LNOBDS
         WRITE(*,'(''  NEW MINIMA THIS TEMPERATURE:'',I8)')  NNEW
      END IF
      CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X')
      CALL PRTVEC(VM,N,'STEP LENGTH (VM)')
      WRITE(*,'('' '')')

      RETURN
      END

      SUBROUTINE PRT10

      WRITE(*,'(/,''  SA ACHIEVED TERMINATION CRITERIA. IER = 0. '',/)')

      RETURN
      END

      SUBROUTINE PRTVEC(VECTOR,NCOLS,NAME)
C  This subroutine prints the double precision vector named VECTOR.
C  Elements 1 thru NCOLS will be printed. NAME is a character variable
C  that describes VECTOR. Note that if NAME is given in the call to
C  PRTVEC, it must be enclosed in quotes. If there are more than 10
C  elements in VECTOR, 10 elements will be printed on each line.

      INTEGER NCOLS
      DOUBLE PRECISION VECTOR(NCOLS)
      CHARACTER *(*) NAME

      WRITE(*,1001) NAME

      IF (NCOLS .GT. 10) THEN
         LINES = INT(NCOLS/10.)

         DO 100, I = 1, LINES
            LL = 10*(I - 1)
            WRITE(*,1000) (VECTOR(J),J = 1+LL, 10+LL)
  100    CONTINUE

         WRITE(*,1000) (VECTOR(J),J = 11+LL, NCOLS)
      ELSE
         WRITE(*,1000) (VECTOR(J),J = 1, NCOLS)
      END IF

 1000 FORMAT( 10(G12.5,1X))
 1001 FORMAT(/,25X,A)

      RETURN
      END


module quaff_utilities_m
    use erloff, only: message_type_t
    use parff, only: parser_output_t, state_t, parse_char

    implicit none
    private
    public :: &
            effectively_zero, &
            equal_within_absolute, &
            equal_within_relative, &
            operator(.safeEq.), &
            parse_space, &
            PARSE_ERROR, &
            UNKNOWN_UNIT

    interface operator(.safeEq.)
        module procedure safe_eq
    end interface

    double precision, parameter :: MACHINE_EPSILON = epsilon(1.0d0)

    type(message_type_t), parameter :: PARSE_ERROR = &
            message_type_t("Parse Error")
    type(message_type_t), parameter :: UNKNOWN_UNIT = &
            message_type_t("Unknown Unit")
contains
    elemental function effectively_zero(a)
        double precision, intent(in) :: a
        logical :: effectively_zero

        effectively_zero = abs(a) < MACHINE_EPSILON
    end function

    pure function equal_within_absolute(a, b, tolerance)
        double precision, intent(in) :: a
        double precision, intent(in) :: b
        double precision, intent(in) :: tolerance
        logical :: equal_within_absolute

        equal_within_absolute = abs(a - b) < tolerance
    end function

    pure function equal_within_relative(a, b, tolerance)
        double precision, intent(in) :: a
        double precision, intent(in) :: b
        double precision, intent(in) :: tolerance
        logical :: equal_within_relative

        if (effectively_zero(a) .and. effectively_zero(b)) then
            equal_within_relative = .true.
        else
            equal_within_relative = &
                    (abs(a - b) / max(abs(a), abs(b))) < tolerance
        end if
    end function

    function parse_space(state_) result(result_)
        type(state_t), intent(in) :: state_
        type(parser_output_t) :: result_

        result_ = parse_char(" ", state_)
    end function

    elemental function safe_eq(a, b)
        double precision, intent(in) :: a
        double precision, intent(in) :: b
        logical :: safe_eq

        safe_eq = equal_within_relative(a, b, MACHINE_EPSILON)
    end function
end module


include "mkl_rci.f90"
include "mkl_service.f90"
include "mkl_vsl.f90"
module MKL_wrappers
	use omp_lib
	use mkl_rci
	use mkl_service		! timing
	use mkl_vsl_type	! random numbers
	use mkl_vsl			! random numbers
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! nonlinear solver

	! abstract interfaces to objective functions of nonlinear solver
	abstract interface
		subroutine fsolve_objective_fun(dim_f,dim_X,X,f)
        	integer,      intent(in)                          :: dim_f, dim_X
        	real(kind=8), intent(in),  dimension(dim_X )      :: X
        	real(kind=8), intent(out), dimension(dim_f)       :: f
		end subroutine fsolve_objective_fun
		subroutine fsolve_objective_Jac(dim_f,dim_X,X,J)
			integer,      intent(in)                          :: dim_f, dim_X
			real(kind=8), intent(in),  dimension(dim_X)       :: X
			real(kind=8), intent(out), dimension(dim_f,dim_X) :: J
		end subroutine fsolve_objective_Jac
	end interface

	type fsolve_info
		integer      :: iter           = -1
		integer      :: st_cr          = -1
		real(kind=8) :: init_residual  = -1.d0
		real(kind=8) :: final_residual = -1.d0
	end type fsolve_info

	type fsolve_options
		integer(kind=4)                 :: MaxIter      = 5000
		integer(kind=4)                 :: MaxIterTrial = 100
		   real(kind=8), dimension(6)   :: eps = (/ 1.d-6, 1.d-6, 1.d-6, 1.d-6, 1.d-6, 1.d-6 /)
		   real(kind=8)                 :: rs  = 1.d0
	end type fsolve_options

	type(fsolve_options) :: default_fsolve_options

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! optimization routines

	! abstract interfaces to objective functions of optimization routine
	abstract interface
		function fminunc_objective_fun(dim_X,X) result(f)
        	integer,      intent(in)                   :: dim_X
        	real(kind=8), intent(in), dimension(dim_X) :: X
        	real(kind=8)                               :: f
		end function fminunc_objective_fun
		function fminunc_objective_grad(dim_X,X) result(g)
			integer,      intent(in)                   :: dim_X
			real(kind=8), intent(in), dimension(dim_X) :: X
			real(kind=8),             dimension(dim_X) :: g
		end function fminunc_objective_grad
	end interface

	type fminunc_info
		integer      :: iter           = -1
		integer      :: st_cr          = -1
		real(kind=8) :: init_residual  = -1.d0
		real(kind=8) :: final_residual = -1.d0
	end type fminunc_info

	type fminunc_options
		integer(kind=4)                 :: MaxIter      = 1000 !5000
		integer(kind=4)                 :: MaxIterTrial = 100
		   real(kind=8), dimension(6)   :: eps = (/ 1.d-6, 1.d-6, 1.d-6, 1.d-6, 1.d-6, 1.d-6 /)
		   real(kind=8)                 :: rs  = 1.d0
	end type fminunc_options

	type(fminunc_options) :: default_fminunc_options

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! random number generator

	integer :: num_rnd_streams = 0
    type (vsl_stream_state), dimension(:), allocatable :: stream

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

contains
	include "MKL_fsolve.f90"
	include "MKL_poissrnd.f90"
	!include "fsolve.f90"
	include "linspace.f90"
! 	include "praxis.f90"
! 	include "toms611.f90"
	include "fminunc.f90"
	include "fmincon.f90"
	include "gradsearch.f90"
	include "inverse.f90"
	include "linsolve.f90"
	include "kron.f90"

end module MKL_wrappers


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program dyson_sc

      ! Solve Dyson equation with self-energy Sigma = c^2*G both in
      ! imaginary time and Matsubara frequency
      !
      ! Since we know the solution has a semi-circular spectral
      ! function, we can begin with the correct self-energy, and make
      ! sure we recover the correct Green's function
      !
      ! The self-energy and correct reference Green's function are
      ! computed from the Lehmann representation in imaginary time using
      ! high-order numerical integration

      implicit none
      integer ntst,nmax
      real *8 lambda,eps,beta,c

      ! Input parameters

      lambda = 200.0d0  ! DLR high energy cutoff
      eps = 1.0d-14     ! DLR error tolerance
      nmax = 200.0d0    ! DLR Matsubara frequency cutoff

      beta = 20.0d0     ! Inverse temperature
      c = 1.0d0/2       ! Self-energy strength

      ntst = 1000       ! # output points

      ! Main test subroutine

      call dyson_sc_main(lambda,eps,nmax,ntst,beta,c)

      end program dyson_sc

      subroutine dyson_sc_main(lambda,eps,nmax,ntst,beta,c)

      ! Main driver routine for Dyson solver test

      implicit none
      integer ntst,nmax
      real *8 lambda,eps,beta,c

      integer i,r,npg,pg
      integer, allocatable :: dlrmf(:),it2cfp(:),mf2cfp(:)
      real *8 err1,err2
      real *8, allocatable :: it2cf(:,:),dlrit(:),dlrrf(:),g1(:)
      real *8, allocatable :: phi(:,:),g0it(:),g1c(:),g2c(:)
      real *8, allocatable :: xgl(:),wgl(:),xgj(:),wgj(:),pbpg(:)
      real *8, allocatable :: sig(:),sigc(:),g0mat(:,:)
      real *8, allocatable :: it_tst(:),g1tst(:),g2tst(:),gtrue(:)
      complex *16, allocatable :: mf2cf(:,:),cf2mf(:,:),g0mf(:),sigmf(:)
      complex *16, allocatable :: gmf(:)
      real *8, external :: kfunf_rel

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Get Matsubara frequency grid

      allocate(dlrmf(r))

      call dlr_mf(nmax,r,dlrrf,-1,dlrmf)

      ! Get Matsubara frequency values -> DLR coefficients matrix (LU
      ! form)

      allocate(mf2cf(r,r),mf2cfp(r),cf2mf(r,r))

      call dlr_mf2cf_init(nmax,r,dlrrf,dlrmf,-1,mf2cf,mf2cfp)

      ! Get DLR coefficients -> Matsubara frequency values matrix

      call dlr_cf2mf_init(r,dlrrf,dlrmf,-1,cf2mf)

      ! Get convolution tensor

      allocate(phi(r*r,r))

      call dlr_convtens(beta,-1,r,dlrrf,dlrit,it2cf,it2cfp,phi)

      ! Get free particle Green's function on imaginary time grid

      allocate(g0it(r))

      call getg0_it(beta,r,dlrit,0.0d0,g0it)

      ! Get free particle Green's function on Matsubara frequency grid

      allocate(g0mf(r))

      call getg0_mf(beta,r,dlrmf,0.0d0,g0mf)

      ! Get matrix of convolution by free particle Green's function

      allocate(g0mat(r,r))

      call dlr_convmat(r,1,it2cf,it2cfp,phi,g0it,g0mat)

      ! Initialize evaluator for Green's function with semi-circular
      ! spectral density

      pg = 24
      npg = max(ceiling(log(lambda)/log(2.0d0)),1)

      allocate(xgl(pg),wgl(pg),xgj(pg),wgj(pg),pbpg(2*npg+1))

      call gfun_init(pg,npg,pbpg,xgl,wgl,xgj,wgj)

      ! Get self-energy at imaginary time nodes

      allocate(sig(r))

      do i=1,r

        call gfun_it(pg,npg,pbpg,xgl,wgl,xgj,wgj,beta,dlrit(i),&
          sig(i))

        sig(i) = c*c*sig(i)

      enddo

      ! Solve Dyson equation in imaginary time

      allocate(g1(r),g1c(r))

      call dyson_it(r,1,it2cf,it2cfp,phi,g0it,g0mat,sig,g1)

      ! Get DLR coefficients of solution

      call dlr_it2cf(r,1,it2cf,it2cfp,g1,g1c)

      ! Transform self-energy to Matsubara frequency and solve Dyson
      ! equation

      allocate(sigc(r),sigmf(r),gmf(r),g2c(r))

      ! Get DLR coefficients of self-energy

      call dlr_it2cf(r,1,it2cf,it2cfp,sig,sigc)

      ! Get self-energy on Matsubara frequency grid

      call dlr_cf2mf(r,1,cf2mf,sigc,sigmf)

      ! Solve Dyson equation by diagonal inversion

      call dyson_mf(beta,r,1,g0mf,sigmf,gmf)

      ! Get DLR coefficients of solution

      call dlr_mf2cf(r,1,mf2cf,mf2cfp,gmf,g2c)

      ! Get test points in relative format

      allocate(it_tst(ntst))

      call eqpts_rel(ntst,it_tst)

      ! Evaluate solutions on test grid

      allocate(g1tst(ntst),g2tst(ntst),gtrue(ntst))

      do i=1,ntst

        call dlr_it_eval(r,1,dlrrf,g1c,it_tst(i),g1tst(i))

        call dlr_it_eval(r,1,dlrrf,g2c,it_tst(i),g2tst(i))

        call gfun_it(pg,npg,pbpg,xgl,wgl,xgj,wgj,beta,it_tst(i),&
          gtrue(i))

      enddo

      ! Compute L^inf errors

      err1 = maxval(abs(g1tst-gtrue))
      err2 = maxval(abs(g2tst-gtrue))

      write(6,*) ''
      write(6,*) '-------------------- DLR error --------------------'
      write(6,*) ''
      write(6,*) 'Imag time L^inf err = ',err1
      write(6,*) 'Mats freq L^inf err = ',err2
      write(6,*) ''

      ! Return failed status if error is not sufficiently small

      if (err1.gt.1.0d-12.or.err2.gt.1.0d-12) then
        call exit(1)
      endif

      end subroutine dyson_sc_main

      subroutine getg0_it(beta,r,dlrit,mu,g0)

      ! Evaluate free particle Green's function in imaginary time

      implicit none
      integer r
      real *8 beta,dlrit(r),mu,g0(r)

      integer i
      real *8, external :: kfunf_rel

      do i=1,r
        g0(i) = -kfunf_rel(dlrit(i),beta*mu)
      enddo

      end subroutine getg0_it

      subroutine getg0_mf(beta,r,dlrmf,mu,g0)

      ! Evaluate free particle Green's function in Matsubara frequency

      implicit none
      integer r,dlrmf(r)
      real *8 beta,mu
      complex *16 g0(r)

      integer i
      complex *16, external :: kfunmf

      do i=1,r
        g0(i) = -kfunmf(2*dlrmf(i)+1,beta*mu)
      enddo

      end subroutine getg0_mf

      subroutine gfun_init(n,np,pbp,xgl,wgl,xgj,wgj)

      ! Initialize subroutine gfun_it, which evaluates Green's function
      ! with semi-circular density at an imaginary time point

      implicit none
      integer n,np
      real *8 pbp(2*np+1),xgl(n),wgl(n),xgj(n),wgj(n)

      integer i
      real *8 one

      one = 1.0d0

      ! Gauss-Legendre and Gauss-Jacobi quadrature

      call cdgqf(n,1,0.0d0,0.0d0,xgl,wgl)
      call cdgqf(n,4,0.5d0,0.0d0,xgj,wgj)

      ! Panels endpoints for composite quadrature rule

      pbp(np+1) = 0*one
      do i=1,np
        pbp(np+i+1) = one/2**(np-i)
      enddo
      pbp(1:np) = -pbp(2*np+1:np+2:-1)

      end subroutine gfun_init

      subroutine gfun_it(n,np,pbp,xgl,wgl,xgj,wgj,beta,t,val)

      ! Evaluate Green's function with semi-circular density
      !
      ! Uses composite Gauss-Legendre quadrature with dyadically-refined
      ! panels, Gauss-Jacobi quadrature at endpoints

      implicit none
      integer n,np
      real *8 pbp(2*np+1),xgl(n),wgl(n),xgj(n),wgj(n),beta,t,val

      integer ii,jj
      real *8 one,pi,a,b,x,tt
      real *8, external :: kfunf

      one = 1.0d0
      pi = 4*atan(1.0d0)

      ! Treat 0.5<tau<1, stored in relative format, by symmetry

      tt = abs(t)

      ! Composite Gauss quadrature

      val = 0.0d0
      do ii=2,2*np-1
        a = pbp(ii)
        b = pbp(ii+1)
        do jj=1,n
          x = a+(b-a)*(xgl(jj)+one)/2
          val = val + (b-a)/2*wgl(jj)*kfunf(tt,beta*x)*&
            sqrt(one-x**2)
        enddo
      enddo

      a = one/2
      b = one
      do jj=1,n
        x = a+(b-a)*(xgj(jj)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(jj)*&
          kfunf(tt,beta*x)*sqrt(one+x)
      enddo

      a = -one
      b = -one/2
      do jj=1,n
        x = a+(b-a)*(-xgj(n-jj+1)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(n-jj+1)*&
          kfunf(tt,beta*x)*sqrt(one-x)
      enddo

      val = -2/pi*val

      end subroutine gfun_it


*DECK DQAGPE
      SUBROUTINE DQAGPE (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, LIMIT,
     +   RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, PTS,
     +   IORD, LEVEL, NDIN, LAST)
C***BEGIN PROLOGUE  DQAGPE
C***PURPOSE  Approximate a given definite integral I = Integral of F
C            over (A,B), hopefully satisfying the accuracy claim:
C                 ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C            Break points of the integration interval, where local
C            difficulties of the integrand may occur (e.g. singularities
C            or discontinuities) are provided by the user.
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1
C***TYPE      DOUBLE PRECISION (QAGPE-S, DQAGPE-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE,
C             GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE,
C             SINGULARITIES AT USER SPECIFIED POINTS
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a definite integral
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Lower limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            NPTS2  - Integer
C                     Number equal to two more than the number of
C                     user-supplied break points within the integration
C                     range, NPTS2.GE.2.
C                     If NPTS2.LT.2, the routine will end with IER = 6.
C
C            POINTS - Double precision
C                     Vector of dimension NPTS2, the first (NPTS2-2)
C                     elements of which are the user provided break
C                     POINTS. If these POINTS do not constitute an
C                     ascending sequence there will be an automatic
C                     sorting.
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C            LIMIT  - Integer
C                     Gives an upper bound on the number of subintervals
C                     in the partition of (A,B), LIMIT.GE.NPTS2
C                     If LIMIT.LT.NPTS2, the routine will end with
C                     IER = 6.
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine.
C                             The estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties. If
C                             the position of a local difficulty can be
C                             determined (i.e. SINGULARITY,
C                             DISCONTINUITY within the interval), it
C                             should be supplied to the routine as an
C                             element of the vector points. If necessary
C                             an appropriate special-purpose integrator
C                             must be used, which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour occurs
C                             At some points of the integration
C                             interval.
C                         = 4 The algorithm does not converge.
C                             Roundoff error is detected in the
C                             extrapolation table. It is presumed that
C                             the requested tolerance cannot be
C                             achieved, and that the returned result is
C                             the best which can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. It must be noted that
C                             divergence can occur with any other value
C                             of IER.GT.0.
C                         = 6 The input is invalid because
C                             NPTS2.LT.2 or
C                             Break points are specified outside
C                             the integration range or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             or LIMIT.LT.NPTS2.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             and ELIST(1) are set to zero. ALIST(1) and
C                             BLIST(1) are set to A and B respectively.
C
C            ALIST  - Double precision
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the left end points
C                     of the subintervals in the partition of the given
C                     integration range (A,B)
C
C            BLIST  - Double precision
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the right end points
C                     of the subintervals in the partition of the given
C                     integration range (A,B)
C
C            RLIST  - Double precision
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the integral
C                     approximations on the subintervals
C
C            ELIST  - Double precision
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the moduli of the
C                     absolute error estimates on the subintervals
C
C            PTS    - Double precision
C                     Vector of dimension at least NPTS2, containing the
C                     integration limits and the break points of the
C                     interval in ascending sequence.
C
C            LEVEL  - Integer
C                     Vector of dimension at least LIMIT, containing the
C                     subdivision levels of the subinterval, i.e. if
C                     (AA,BB) is a subinterval of (P1,P2) where P1 as
C                     well as P2 is a user-provided break point or
C                     integration limit, then (AA,BB) has level L if
C                     ABS(BB-AA) = ABS(P2-P1)*2**(-L).
C
C            NDIN   - Integer
C                     Vector of dimension at least NPTS2, after first
C                     integration over the intervals (PTS(I)),PTS(I+1),
C                     I = 0,1, ..., NPTS2-2, the error estimates over
C                     some of the intervals may have been increased
C                     artificially, in order to put their subdivision
C                     forward. If this happens for the subinterval
C                     numbered K, NDIN(K) is put to 1, otherwise
C                     NDIN(K) = 0.
C
C            IORD   - Integer
C                     Vector of dimension at least LIMIT, the first K
C                     elements of which are pointers to the
C                     error estimates over the subintervals,
C                     such that ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     form a decreasing sequence, with K = LAST
C                     If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST
C                     otherwise
C
C            LAST   - Integer
C                     Number of subintervals actually produced in the
C                     subdivisions process
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DQELG, DQK21, DQPSRT
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DQAGPE
      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     1  A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,
     2  DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
     3  ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS,
     4  RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW
      INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J,
     1  JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR,
     2  NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
C
      DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*),
     1  LEVEL(*),NDIN(*),POINTS(*),PTS(*),RES3LA(3),
     2  RLIST(*),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION
C            (LIMEXP+2) AT LEAST).
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2
C                       CONTAINING THE PART OF THE EPSILON TABLE WHICH
C                       IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE
C                       APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS
C                       BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER
C                       NUMRL2 HAS BEEN INCREASED BY ONE.
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS
C                       NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAGPE
      EPMACH = D1MACH(4)
C
C            TEST ON VALIDITY OF PARAMETERS
C            -----------------------------
C
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      LEVEL(1) = 0
      NPTS = NPTS2-2
      IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND.
     1  EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28))) IER = 6
      IF(IER.EQ.6) GO TO 999
C
C            IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN
C            ASCENDING SEQUENCE.
C
      SIGN = 1.0D+00
      IF(A.GT.B) SIGN = -1.0D+00
      PTS(1) = MIN(A,B)
      IF(NPTS.EQ.0) GO TO 15
      DO 10 I = 1,NPTS
        PTS(I+1) = POINTS(I)
   10 CONTINUE
   15 PTS(NPTS+2) = MAX(A,B)
      NINT = NPTS+1
      A1 = PTS(1)
      IF(NPTS.EQ.0) GO TO 40
      NINTP1 = NINT+1
      DO 20 I = 1,NINT
        IP1 = I+1
        DO 20 J = IP1,NINTP1
          IF(PTS(I).LE.PTS(J)) GO TO 20
          TEMP = PTS(I)
          PTS(I) = PTS(J)
          PTS(J) = TEMP
   20 CONTINUE
      IF(PTS(1).NE.MIN(A,B).OR.PTS(NINTP1).NE.MAX(A,B)) IER = 6
      IF(IER.EQ.6) GO TO 999
C
C            COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS.
C            ------------------------------------------------
C
   40 RESABS = 0.0D+00
      DO 50 I = 1,NINT
        B1 = PTS(I+1)
        CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA)
        ABSERR = ABSERR+ERROR1
        RESULT = RESULT+AREA1
        NDIN(I) = 0
        IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1
        RESABS = RESABS+DEFABS
        LEVEL(I) = 0
        ELIST(I) = ERROR1
        ALIST(I) = A1
        BLIST(I) = B1
        RLIST(I) = AREA1
        IORD(I) = I
        A1 = B1
   50 CONTINUE
      ERRSUM = 0.0D+00
      DO 55 I = 1,NINT
        IF(NDIN(I).EQ.1) ELIST(I) = ABSERR
        ERRSUM = ERRSUM+ELIST(I)
   55 CONTINUE
C
C           TEST ON ACCURACY.
C
      LAST = NINT
      NEVAL = 21*NINT
      DRES = ABS(RESULT)
      ERRBND = MAX(EPSABS,EPSREL*DRES)
      IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(NINT.EQ.1) GO TO 80
      DO 70 I = 1,NPTS
        JLOW = I+1
        IND1 = IORD(I)
        DO 60 J = JLOW,NINT
          IND2 = IORD(J)
          IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60
          IND1 = IND2
          K = J
   60   CONTINUE
        IF(IND1.EQ.IORD(I)) GO TO 70
        IORD(K) = IORD(I)
        IORD(I) = IND1
   70 CONTINUE
      IF(LIMIT.LT.NPTS2) IER = 1
   80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      MAXERR = IORD(1)
      ERRMAX = ELIST(MAXERR)
      AREA = RESULT
      NRMAX = 1
      NRES = 0
      NUMRL2 = 1
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      ERLARG = ERRSUM
      ERTEST = ERRBND
      LEVMAX = 1
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      IERRO = 0
      UFLOW = D1MACH(1)
      OFLOW = D1MACH(2)
      ABSERR = OFLOW
      KSGN = -1
      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 160 LAST = NPTS2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        LEVCUR = LEVEL(MAXERR)+1
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1)
        CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        NEVAL = NEVAL+42
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95
        IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*ABS(AREA12)
     1  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   90   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   95   LEVEL(MAXERR) = LEVCUR
        LEVEL(LAST) = LEVCUR
        RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = MAX(EPSABS,EPSREL*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE
C
        IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     1  (ABS(A2)+0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 100
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 110
  100   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
  110   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM.LE.ERRBND) GO TO 190
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0) GO TO 170
        IF(NOEXT) GO TO 160
        ERLARG = ERLARG-ERLAST
        IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 120
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
        EXTRAP = .TRUE.
        NRMAX = 2
  120   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER
C           THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 130 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
          NRMAX = NRMAX+1
  130   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
  140   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        IF(NUMRL2.LE.2) GO TO 155
        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 150
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF(ABSERR.LT.ERTEST) GO TO 170
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
  150   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.GE.5) GO TO 170
  155   MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        LEVMAX = LEVMAX+1
        ERLARG = ERRSUM
  160 CONTINUE
C
C           SET THE FINAL RESULT.
C           ---------------------
C
C
  170 IF(ABSERR.EQ.OFLOW) GO TO 190
      IF((IER+IERRO).EQ.0) GO TO 180
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175
      IF(ABSERR.GT.ERRSUM)GO TO 190
      IF(AREA.EQ.0.0D+00) GO TO 210
      GO TO 180
  175 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 190
C
C           TEST ON DIVERGENCE.
C
  180 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE.
     1  DEFABS*0.1D-01) GO TO 210
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR.
     1  ERRSUM.GT.ABS(AREA)) IER = 6
      GO TO 210
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  190 RESULT = 0.0D+00
      DO 200 K = 1,LAST
        RESULT = RESULT+RLIST(K)
  200 CONTINUE
      ABSERR = ERRSUM
  210 IF(IER.GT.2) IER = IER-1
      RESULT = RESULT*SIGN
  999 RETURN
      END


! returns the given entire of pi
function getheppower( power )

    use constants ! the module contains several constants definition, including pi.

    integer, intent(in) :: power
    real :: getheppower

    getheppower = pi ** power

end function


!##############################################################################
!# Tutorial 006k: Create a RHS vector
!##############################################################################

module tutorial006k

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use cubature
  use element
  use derivatives
  use spatialdiscretisation
  use linearsystemscalar

  use scalarpde
  use linearformevaluation
  use domainintegration

  use vectorio
  use collection

  implicit none
  private

  public :: start_tutorial006k

contains

  ! ***************************************************************************

!<subroutine>

  subroutine fcoeff_RHS (rdiscretisation, rform, &
                nelements, npointsPerElement, Dpoints, &
                IdofsTest, rdomainIntSubset, &
                Dcoefficients, rcollection)

  use basicgeometry
  use collection
  use domainintegration
  use fsystem
  use scalarpde
  use spatialdiscretisation
  use triangulation

!<description>
  ! This subroutine is called during the vector assembly. It returns
  ! the values of a RHS function f in a set of (cubature) points
  ! on a set of elements.
!</description>

!<input>
  ! Underlying discretisation structure.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! The linear form which is currently to be evaluated:
  type(t_linearForm), intent(in) :: rform

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! Array of all points (x/y coords) on all elements where the values are needed.
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! Array with degrees of freedom of the test function.
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! A t_domainIntSubset structure specifying more detailed assembly information.
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset
!</input>

!<inputoutput>
  ! Optional: A collection structure to provide additional information.
  type(t_collection), intent(inout), optional :: rcollection
!</inputoutput>

!<output>
  ! A list of all coefficients in front of all terms in the linear form -
  ! for all given points on all given elements.
  !   DIMENSION(itermCount,npointsPerElement,nelements)
  ! with itermCount the number of terms in the linear form.
  real(DP), dimension(:,:,:), intent(out) :: Dcoefficients
!</output>

!</subroutine>

    integer :: ielement, ipoint
    real(DP) :: dx, dy, dmult

    ! Get the multiplier from the collection -- will be 4.0 by default (see below).
    dmult = rcollection%DquickAccess(1)

    do ielement = 1,nelements
      do ipoint = 1,npointsPerElement

        ! x/y coordinate
        dx = Dpoints(1,ipoint,ielement)
        dy = Dpoints(2,ipoint,ielement)

        ! Write f(x,y)=d*16*x*(1-x)*y*(1-y) into Dcoefficients(1,:,:)
        Dcoefficients(1,ipoint,ielement) = &
            dmult * 16.0_DP * dx * (1.0_DP - dx) * dy * (1.0_DP - dy)

      end do
    end do

  end subroutine

  ! ***************************************************************************

  subroutine start_tutorial006k

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation

    type(t_linearForm) :: rlinform
    type(t_collection) :: rcollection
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G3
    type(t_vectorScalar) :: rrhs
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006k")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Use a 3-point Gauss Formula for the RHS
    ! =================================

    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G3,CUB_GEN_AUTO_G3)

    ! =================================
    ! Create a RHS vector.
    ! =================================

    ! Create a vector.
    call lsyssc_createVector (rdiscretisation,rrhs)

    ! Prepare a linear form structure for one term in the RHS: (f, phi).
    ! The test function is just phi without derivative.
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC2D

    ! Build the RHS using fcoeff_RHS above. Pass a multiplier via a collection structure.
    ! rcollection%DquickAccess/IquickAccess/... can arbitrarily be used to pass values.
    rcollection%DquickAccess(1) = 4.0_DP

    call linf_buildVectorScalar (&
        rlinform,.true.,rrhs,rcubatureInfo_G3,fcoeff_RHS,rcollection)

    ! =================================
    ! Output to files.
    ! =================================
    call output_line ("Writing RHS vector to text file...")

    ! Write the vector to a text file.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call vecio_writeVectorHR (rrhs, "vector", .true., 0, &
          trim(spostdir)//"/tutorial006k_rhs.txt", "(E20.10)")
    else
      call vecio_writeVectorHR (rrhs, "vector", .true., 0, &
          "./post/tutorial006k_rhs.txt", "(E20.10)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsyssc_releaseVector (rrhs)

    ! Release the cubature formula
    call spdiscr_releaseCubStructure (rcubatureInfo_G3)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


program qpso

implicit none
include "mpif.h"

integer maxiter, maxpop, maxparms
parameter (maxiter = 10000)
parameter (maxpop = 2048)
parameter (maxparms = 512)

integer i, j,k, npop, nparms, niter, gInx, nfunc(maxpop)
integer nfuncall(maxpop)
integer np, myid, ierr, start_iter
integer pft(maxparms)
double precision gbest(maxparms)
double precision mbest(maxparms)
double precision feval, beta_l, beta_u, beta
double precision betapro(maxparms), pupdate(maxparms)
double precision pbest(maxpop, maxparms)
double precision pbestall(maxpop, maxparms)
double precision f_x(maxpop), x(maxpop, maxparms)
double precision xall(maxpop, maxparms)
double precision f_pbest(maxpop), f_pbestall(maxpop), f_gbest
double precision gpar(maxiter,maxparms)
double precision gobj(maxiter)
double precision pmin(maxparms), pmax(maxparms)
double precision fi(maxparms), u(maxparms), v(maxparms)
logical isvalid, restart
character(len=4) popst
character(len=100) mymachine, dummy, parm_name(maxparms), case_name, thisfmt

!------- user-tunable QPSO algorithm parameters ----------------

npop = 64         !number of particles
niter = 200       !number of iterations
beta_l = 0.4d0
beta_u = 0.7d0
restart = .false.
!mymachine = 'oic'   !Fill in correct machine and uncomment this line

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

call mpi_init(ierr)
call mpi_comm_size(mpi_comm_world, np, ierr)
call mpi_comm_rank(mpi_comm_world, myid, ierr)

!get parameter information from the parm_list file
if (myid .eq. 0) then
  open(unit = 8, status='old', file = './parm_list')
  read(8,*) case_name
  nparms=0
  do i=1,maxparms
     read(8,*, end=10) parm_name(i), pft(i), pmin(i), pmax(i)
     nparms = nparms+1
  end do
end if

10 continue
if (myid .eq. 0) then
  close(8)
  print*, nparms, ' Parameters optimized'
end if

!broadcast parameter info to other procs
call mpi_bcast(nparms, 1, mpi_integer, 0, mpi_comm_world, ierr)
call mpi_bcast(pmin, maxparms, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(pmax, maxparms, mpi_double, 0, mpi_comm_world, ierr)

nfunc(:) = 0   !keep track of total function evaluations

x(:,:) = 0d0
f_x(:) = 0d0
f_pbest(:) = 0d0

if (restart .eqv. .false.) then
   do i=myid+1,npop,np
      !randomize starting locations
      call init_random_seed
      call random_number(u)
      x(i,:) = pmin + (pmax-pmin) * u
      f_x(i) = feval(x(i,:), nparms, i, mymachine)
      nfunc(i) = nfunc(i)+1
      f_pbest(i) = f_x(i)
   end do

   call mpi_allreduce(x, xall, maxparms*maxpop, mpi_double, mpi_sum, &
        mpi_comm_world, ierr)
   call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
        mpi_comm_world, ierr)
   pbestall = xall

   !initialize pbest and gbest
   if (myid .eq. 0) then
      gInx = 1
      do i=2,npop
         if (f_pbestall(i) .lt. f_pbestall(gInx)) gInx = i
      end do
      gbest = pbestall(gInx,:)
      f_gbest = f_pbestall(gInx)
   end if
   call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
   call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
   start_iter = 1
else
   !load restart information
   if (myid .eq. 0) then
      open(unit=8, file='./qpso_restart.txt')
      read(8,*) start_iter
      do j=1,npop
         read(8,*) xall(j,1:nparms)
         read(8,*) pbestall(j,1:nparms)
         read(8,*) f_pbestall(j)
      end do
      read(8,*) gbest(1:nparms)
      read(8,*) f_gbest
   end if
   xall=pbestall
   call mpi_bcast(xall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
   call mpi_bcast(pbestall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
   call mpi_bcast(f_pbestall, maxpop, mpi_double, 0, mpi_comm_world, ierr)
   call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
   call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
end if

!QPSO algorithm
do i=start_iter,niter
   if (myid .eq. 0) print*, 'Iteration', i
   beta = beta_u - (beta_u-beta_l)*i/niter
   !compute mean of best parameters (all procs)
   do k=1, nparms
      mbest(k) = sum(pbestall(1:npop,k))/npop
   end do
   !print*, mbest(1:nparms)
   !MPI over population
   x(:,:) = 0d0
   pbest(:,:) = 0d0
   f_pbest(:) = 0d0
   do j = myid+1,npop,np
      isvalid = .false.
      do while (isvalid .eqv. .false.)   !Force a set of parameters within the bounds
         call random_number(fi)
         call random_number(u)
         call random_number(v)

         isvalid=.true.
         do k=1,nparms
            pupdate = fi(k)*pbestall(j,k) + (1-fi(k))*gbest(k)
            betapro = beta * abs(mbest(k)-xall(j,k))

            x(j,k) = pupdate(k)+((-1d0)**ceiling(0.5+v(k)))*betapro(k)*(-log(u(k)))

            if (x(j,k) .lt. pmin(k) .or. x(j,k) .gt. pmax(k)) isvalid=.false.
            !DMR for better load balancing, instead of not running, run at the boundary.  Testing only.
            !if (x(j,k) .lt. pmin(k)) x(j,k) = pmin(k)
            !if (x(j,k) .gt. pmax(k)) x(j,k) = pmax(k)
         end do
      end do

      !run the model to get the cost function
      f_x(j) = feval(x(j,:),nparms, j, mymachine)
      nfunc(j) = nfunc(j)+1

20 continue
      if (f_x(j) .lt. f_pbestall(j)) then
         pbest(j,:) = x(j,:)
         f_pbest(j) = f_x(j)
      else
         pbest(j,:) = pbestall(j,:)
         f_pbest(j) = f_pbestall(j)
      end if
   end do

   call mpi_allreduce(pbest, pbestall, maxparms*maxpop, mpi_double, mpi_sum, &
        mpi_comm_world, ierr)
   call mpi_allreduce(x, xall, maxpop, mpi_double, mpi_sum, &
        mpi_comm_world, ierr)
   call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
        mpi_comm_world, ierr)

   !update overall best (all procs)
   do j=1,npop
      if (f_pbestall(j) .lt. f_gbest) then
         gbest = pbestall(j,:)
         f_gbest = f_pbestall(j)
      end if
   end do

   !save info from this iteration
   gpar(i,:) = gbest
   gobj(i) = f_gbest
   call mpi_allreduce(nfunc,nfuncall, maxpop, mpi_integer, mpi_sum, &
        mpi_comm_world, ierr)
   if (myid .eq. 0) then
     open(unit=8, file='qpso_best.txt')
     write(8,*), 'Iteration', i
     write(8,*), 'Objective function:', gobj(i)
     do k=1,nparms
        write(8,'(A,1x,I2,1x,g13.6)') trim(parm_name(k)), pft(k), gpar(i,k)
     end do
     close(8)
     if (i .eq. 1) then
        open(unit=10, file='qpso_costfunc.txt')
     else
        open(unit=10, file='qpso_costfunc.txt', status='old', position='append', action='write')
     end if
     write(10,*) i, sum(nfuncall) , gobj(i)
     close(10)

     !write the restart file
     write(popst, '(I4)') nparms
     thisfmt = '(' // trim(popst) // '(g13.6,1x))'
     open(unit=11, file = 'qpso_restart.txt')
     write(11,'(I4)') i        !current iteration number
     do j=1,npop
        write(11,fmt=trim(thisfmt)) xall(j,1:nparms)      !current parameters for each population
        write(11,fmt=trim(thisfmt)) pbestall(j,1:nparms)  !best parameters for each population
        write(11,'(g13.6)') f_pbestall(j)                 !best objective function for each population
     end do
     write(11,fmt=trim(thisfmt)) gbest(1:nparms)          !overall best parameters
     write(11,'(g13.6)') f_gbest                          !overall best objectivefunction
     close(11)
  end if
end do
call mpi_finalize(ierr)

end program qpso

!Function to evaluate the CLM/ALM model
double precision function feval(parms, nparms, thispop, mymachine)

integer nparms, i, thispop
double precision parms(500), trueparms(4)
double precision mydata(1000), model(1000), sse(1000)
double precision temp(1000), par(1000)
character(len=6) thispopst
character(len=100) mymachine

write(thispopst, '(I6)') 100000+thispop

!write the parameters to file
open(unit=9, file='./parm_data_files/parm_data_' // thispopst(2:6))
do i=1,nparms
   write(9,*) parms(i)
end do
close(9)

!Call python workflow to set up and launch model simulation
call system('python UQ_runens.py --ens_num ' // thispopst(2:6) // &
     ' --parm_list ' // 'parm_list --parm_data ./parm_data_files/' // &
     'parm_data_' // thispopst(2:6) // ' --constraints constraints' // &
     ' --machine ' // trim(mymachine))

!get the sum of squared errors
open(unit=9, file='./ssedata/mysse_' // thispopst(2:6) // '.txt')
read(9,*) feval
close(9)

return

end function feval