	SUBROUTINE VC_BLDZ  ( t, p, q, nxy, update, tl, pl, zl, z,
     +			      iret )
C************************************************************************
C* VC_BLDZ								*
C*									*
C* This subroutine builds height hydrostatically.			*
C*									*
C* VC_BLDZ ( T, P, Q, NXY, UPDATE, TL, PL, ZL, Z, IRET )		*
C*									*
C* Input parameters:							*
C*	T   (NXY)	REAL		Temperature			*
C*	P   (NXY)	REAL		LN (pressure)			*
C*	Q   (NXY)	REAL		Specific humidity		*
C*	NXY		INTEGER		Number of points		*
C*	UPDATE		LOGICAL		Flag to update lower level	*
C*									*
C* Input and output parameters:						*
C*	TL  (NXY)	REAL		Lower level virtual temperature *
C*	PL  (NXY)	REAL		Lower level LN (pressure)	*
C*	ZL  (NXY)	REAL		Lower level z			*
C*									*
C* Output parameters:							*
C*	Z   (NXY)	REAL		Height				*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      05/92						*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
	REAL		tl (*), pl (*), zl (*), t (*), p (*), z (*), q(*)
	LOGICAL		update
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C*
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( tl (i) ) .or. ERMISS ( t (i) ) .or.
     +		 ERMISS ( pl (i) ) .or. ERMISS ( p (i) ) .or.
     +		 ERMISS ( zl (i) ) ) THEN
		z (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		IF ( .not. ERMISS ( q (i) ) ) THEN
		    tv = t (i) * ( 1 + .608 * q (i) )
		ELSE
		    tv = t (i)
		END IF
		tbar = .5 * ( tl (i) + tv )
		dlnp = p (i) - pl (i)
		dz   = RKAP * tbar * dlnp
	   	z (i) = zl (i) - dz
		IF ( update ) THEN
		    tl (i) = tv
		    pl (i) = p (i)
		    zl (i) = z (i)
		END IF
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


!==========================================================================
elemental function gsw_enthalpy (sa, ct, p)
!==========================================================================
!
!  Calculates specific enthalpy of seawater using the computationally-
!  efficient expression for specific volume in terms of SA, CT and p
!  (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  enthalpy  =  specific enthalpy                                  [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_dynamic_enthalpy

use gsw_mod_teos10_constants, only : gsw_cp0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_enthalpy

gsw_enthalpy = gsw_cp0*ct + gsw_dynamic_enthalpy(sa,ct,p)

return
end function

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


!This code can be used to calculate the temperature dependence of magnetic
!susceptibility (Chi*T vs T plot).
!Only the dependence of Chi on the strength of exchange coupling between
!metal centres, and the Zeeman splitting are taken into account in this
!code.

Program suscep
 Use Iso_Fortran_Env
 Implicit None
 Integer, parameter :: int_kind = INT32
 !Integer, parameter :: int_kind = INT64
 !Integer, parameter :: int_kind = INT128
 !Integer, parameter :: real_kind = REAL32 !Single Precision
 Integer, parameter :: real_kind = REAL64 !Double precision
 Integer, parameter :: comp_kind = REAL64 !Double precision
 Real(kind = real_kind) :: pi
 Integer(kind = int_kind) :: i, j, dmension, no_of_j_val, totalspin, spin_mat_col, j_mat_col
 ! dmension is the number of magnetic centres
 ! no_of_j_val stores the total number of unique J-values defined for the Hamiltonian
 ! totalspin stores the row (or column) size of the spin hamiltonian matrix
 ! spin_mat_col stores the column size of the spin matrix
 ! j_mat_col stores the column size of the J value matrix
 Integer(kind = int_kind) :: ios
 Real(kind = real_kind), Dimension(:), Allocatable :: spin, jval, posval
 ! spin stores the S value (i.e. total number of unpaired electrons/2) for each
 !metal centre
 ! jval stores the different J-values in use
 ! posval description given in the subroutine FormBasis
 Integer(kind = int_kind), Dimension(:), Allocatable :: pseudospin
 ! pseudospin is simply a pointer pointing to the position of each metal centre
 Integer(kind = int_kind), Dimension(:,:), Allocatable :: jmat
 ! jmat is the J-value matrix storing information about which J-values
 !are associated with different spin pairs
 Real (kind = real_kind), Dimension(:,:), Allocatable :: hamil
 ! hamil is the spin hamiltonian matrix
 Real(kind = real_kind) :: g
 ! g is the 'g' value/tensor (isotropic behaviour has been assumed here)
 Real(kind = real_kind) :: B, vac_perm, field_str
 ! B = magnetic induction(Wb m-2)
 ! field_str stores the strength of the applied field, B = magnetic induction(Wb m-2)
 ! vac_perm = permeability of free space in vacuum(Wb A-1 m-1) = (4*pi)*(10^-7)
 Real(kind = real_kind), Dimension(:,:), Allocatable :: spinmat, basis
 ! spinmat stores all possible Ms values for each metal centre
 ! basis stores all possible combinations of Ms values of all metal centres
 Character (Len = 100) :: FileName, read_line, Outfile
 ! FileName stores the name of the input file
 ! Outfile stores the name of the output file
 Logical :: EndOfFile
 Call Get_Command_Argument(1, FileName)
 Outfile = trim(Filename) // '.txt'
 Open (Unit = 11, file = FileName, action = 'read', position = 'rewind', iostat = ios)
 Open (Unit = 12, file = Outfile, status = 'unknown', action = 'readwrite')
 totalspin = 1
 Rewind(11)
 EndOfFile = .False.
 Write(12,*) 'Please cite: Altering the nature of coupling by changing the oxidation state in a {Mn6} cage, DOI: 10.1039/D0DT01404D.'
 Write(12,*)
 Call Init()
 Call printer()
 Call SpinMatForm()
 Call FormBasis()
 Call HamilForm(totalspin)
 Deallocate (spin, basis, pseudospin, hamil)
 Deallocate (spinmat, posval, jval, jmat)
 Close(11)
 Close(12)

 Contains

 Subroutine Init()
   !!!!! Declaration and initailisation of variables !!!!!
        Character (Len = 1) :: buff
        Logical :: check, check1
        Integer(kind = int_kind) :: i1, j1
        check = .False.
        check1 = .False.
        168 Format(i2)
        189 Format(F4.1)
        193 Format(F6.3)
        245 Format(F22.17)
        pi = 4.0_real_kind*DAtan(1.0_real_kind) !4.0*Atan(1.0) is the value of pi
        i1 = 0
        j1 = 0
        j_mat_col = 1
        vac_perm = 4.0_real_kind*pi/10000000.0_real_kind
   !!!!! Declaration and initailisation ends !!!!!

   !!!!! Determining number of magnetic centres (i.e. metal atoms) !!!!!
   !!!!! Initialisation of spin for each metal centre !!!!!
        Read(11, '(a)', iostat = ios) read_line
        If(trim(read_line) == 'magnetic centres') Then
                Read(11, 168) dmension
        Else
                Write(*,*) ' Erroneous number of magnetic centres in the input file'
                Call Abort
        End If
        Write(12,*) "Number of Magnetic centers:", dmension
        Allocate(spin(dmension))
        Allocate(pseudospin(dmension))
        Do i = 1, dmension
                spin(i) = 0
        End Do
   !!!!! Determination of magnetic centres and their initialization ends !!!!!

   !!!!! Reading in the actual values of spin for each centre !!!!!
        Read(11, '(a)', iostat = ios) read_line
        If(trim(read_line) == 'spin') Then
                Do i = 1, dmension
                        Read(11, 189) spin(i)
                        pseudospin(i) = i
                        totalspin = totalspin * (2*spin(i) + 1)
                End Do
        End If
        Do i = 1, dmension
                If(spin(i) == 0) Then
                        Write(*,*) "Erroneous spin values"
                        Call Abort
                End If
        End Do
   !!!!! Reading of spins ends !!!!!

   !!!!! Determining the number of J values, reading them and printing them!!!!!
        Read(11, '(a)', iostat = ios) read_line
        If(trim(read_line) == 'No. of J values') then
                Read(11, 168) no_of_j_val
        Else
                Write(*,*) ' Erroneous No. of J values'
                Call Abort
        End If
        Allocate(jval(no_of_j_val))
        Read(11, '(a)', iostat = ios) read_line
        If(trim(read_line) == 'J values') then
                Write(12,'(a)', advance = 'no') ' The J values(cm-1) given are:'
                Do i = 1, no_of_j_val
                        Read(11, 245) jval(i)
                        Write(12, 245, advance = 'no') jval(i)
                        Write(12,'(a)', advance = 'no') "  "
                End Do
        Else
                Write(*,*) ' Erroneous J values'
                Call Abort
        End If
        Write(12,*)
   !!!!! J value determination ends !!!!!

   !!!!! Determining the g value!!!!!
        Read(11, '(a)', iostat = ios) read_line
        If (trim(read_line) == 'g value') Then
                Read(11, 193) g
                Write(12,*) 'g value:', g
        Else
                Write(12,*) 'Erroneous g value'
                Call Abort
        End If
   !!!!! G value determination ends!!!!!

   !!!!! Reading in and printing the Spin Hamiltonian !!!!!
        Read(11, '(a)', iostat = ios) read_line
        If(trim(read_line) == 'Hamiltonian') Then
                Read(11, '(a)', iostat = ios) read_line
        Else
                Write(*,*) 'No Hamiltonian'
                Call Abort
        End If

   !!!!! Determining the number of variables in the Hamiltonian !!!!!
        Do i = 1, len_trim(read_line)
                If(read_line(i:i) == '(') Then
                        check = .Not.check
                End If
                If (check .eqv. .True.) Then
                        if (read_line(i:i) == '+') Then
                                i1 = i1 + 1
                        End If
                End If
                If (read_line(i:i) == ')') Then
                        check = .Not.check
                        If (i1 > j1) Then
                                j1 = i1
                                i1 = 0
                        End If
                End If
        End Do
        j_mat_col = j1 + 1
        Allocate(jmat(no_of_j_val, j_mat_col))
        Do i = 1, no_of_j_val
                Do j = 1, j_mat_col
                        jmat(i, j) = 0
                End Do
        End Do
        i1 = 1
        j1 = 1

   !!!!! Reading in each interaction of the spin Hamiltonian !!!!!
        Do i = 1, len_trim(read_line)
                If (read_line(i:i) == '(') Then
                        Read(read_line(i + 1:i + 2), 168) jmat(i1, j1)
                        j1 = j1 + 1
                        If (j1 > j_mat_col) Then
                                i1 = i1 + 1
                                j1 = 1
                        End If
                        check = .Not.check
                End If
                If (read_line(i:i) == '+' .AND. check .eqv. .True.) Then
                        Read(read_line(i + 2:i + 3), 168) jmat(i1, j1)
                        j1 = j1 + 1
                        If (j1 > j_mat_col) Then
                                i1 = i1 + 1
                                j1 = 1
                        End If
                End If
                If (read_line(i:i) == ')') Then
                        if (j1 > 1) Then
                                i1 = i1 + 1
                                j1 = 1
                        End If
                        check = .Not.check
                End If
        End Do
   !!!!! Reading and printing of the Spin Hamiltonian ends !!!!!

   !!!!! Reading in the field strength !!!!!
        166 Format(F10.3)
        Read(11,'(a)', iostat = ios) read_line
        If(trim(read_line) == 'Field Strength') Then
                Read(11,166) field_str !Field strength needs to be in oersted
                field_str = field_str * 1000.0_real_kind/(4.0_real_kind*pi) !A/m
        End If
        !Write(12,*) ' Vac', vac_perm
        B = vac_perm * field_str !Wb m-2 or T
        !Write(12,*) 'Field Strength(A m-1) :', field_str
        !Write(12,*) 'Magnetic Induction(Wb m-2 or T) :',  B
        B = B / 2.350517550e5_real_kind !atomic units
   !!!!! Reading in the field strength ends !!!!!

 End Subroutine Init

 Subroutine printer()
         Write(*,*)'Report available in the file', Outfile
         Write(12,*) "Dimension of hamiltonian matrix", totalspin
         Write(12, '(a)', advance='no') " Rows X Columns in Hamiltonian matrix:"
         Write(12, 220, advance='no') totalspin
         220 Format(i5)
         Write(12,'(a)', advance='no') ' X'
         Write(12,220) totalspin
         Write(12,*) "Metal Number:"
         Write(12,*) pseudospin
         Write(12,*) "Spin on the Metal:"
         189 Format(9x, F4.1)
         Do i = 1, dmension
                 Write(12, 189, advance = 'no') spin(i)
         End Do
         Write(12,*)
         Write(12,*) 'J value (cm-1) with the pairs on which they act'
         249 Format(1x, F19.4)
         168 Format(i2)
         Do i = 1, no_of_j_val
                 Write (12, 249, advance = 'no') jval(i)
                 Write (12, '(a)', advance = 'no') '  '
                 Do j = 1, j_mat_col
                         If (jmat(i, j) == 0) Then
                                 Write (12, '(a)', advance = 'no') 'xx  '
                         Else
                                 Write (12, 168, advance = 'no') jmat(i, j)
                                 Write (12, '(a)', advance = 'no') '  '
                         End If
                 End Do
                 Write(12,*)
         End Do
 End Subroutine printer

 Subroutine SpinMatForm()
   !!!!! Determination of the Ms values for each spin centres!!!!!

   !!!!! Declaration and allocation of variables !!!!!
        Integer(kind = int_kind) :: y, a, b, i1, j1, k, l, row, column, t, spinmatdim
        Real(kind = real_kind) :: maxspin, x
        maxspin = spin(1)
        k = 1
        !Determining what is the highest number of unpaired electrons associated
        !with the metal centres under consideration
        Do i1 = 2, dmension
                x = spin(i1)
                If (x > maxspin) Then
                        maxspin = x
                End If
        End Do
        !Determination ends
        spinmatdim  = 2.0 * maxspin + 1
        spin_mat_col = spinmatdim
        Allocate (spinmat(dmension, spinmatdim))
   !!!!! Declaration and allocation ends !!!!!

   !!!!! Initialising all the Ms values !!!!!
        Do i1 = 1, Size(spin)
                Do j1 = 1, spinmatdim
                        spinmat(i1, j1) = -50
                End Do
        End Do
   !!!!! End of initialisation !!!!!

   !!!!! Storing the actual Ms values !!!!!
        Do i1 = 1, Size(spin)
                x = spin(k)
                Do j1 = 1, spinmatdim
                        If (x >= -1 * spin(k)) Then
                                spinmat(i1,j1) = x
                        End if
                        x = x - 1
                End Do
                k = k + 1
        End Do
   !!!!! Storing ends !!!!!

   !!!!! Write up !!!!!
        168 Format(i3)
        Write (12,'(a)', advance = 'no') "size of spin matrix:"
        Write (12, 168, advance = 'no') Size(spin)
        Write (12,'(a)', advance = 'no') ' X '
        Write (12, 168, advance = 'no') spinmatdim
        Write (12,'(a)', advance = 'no') " = "
        Write (12, 168, advance = 'no')  Size(spinmat)
        Write (12,*)

        Write(12,*) "Magnetic Spin Quantum no. Ms matrix:"
        Do i1 = 1, Size(spin)
                Do j1 = 1, spinmatdim
                        If (spinmat(i1,j1) == -50) Then
                                Write(12,'(a)',advance = 'no') "   xx"
                        Else
                                Write(12,145, advance = 'no') spinmat(i1,j1)
                                145 Format(1x, F5.1)
                        End If
                End Do
                Write(12, *)
        End Do
   !!!!! Write up ends !!!!!

 End Subroutine SpinMatForm

 Subroutine FormBasis()
   !!!!! Forming the basis which would span the spin hamiltonian !!!!!

   !!!!! Declaration and Initialization !!!!!
        Integer(kind = int_kind) :: k, counter, counter1, t
        Integer(kind = int_kind), Dimension(:), Allocatable :: pos
        !pos acts as a pointer for the values of spinmat
        !posval stores the Ms value corresponding to the pointers provided by pos
        Allocate(pos(dmension))
        Allocate(posval(dmension))
        Allocate(basis(totalspin, dmension))
        168 Format(i2)
        189 Format(F4.1)
        counter = 1
   !!!!! Declaration and Initialization ends !!!!!

   !!!!! Determining the values of the actual basis and the pseudo analogues !!!!!
        Do k = 1, Size(pos)
                pos(k) = 1
                basis(1,k) = spinmat(k,pos(k))
                posval(k) = spinmat(k,pos(k))
        End Do
        Do k = 1, totalspin
                Do counter = 1, Size(pos)
                        basis(k,counter) = posval(counter)
                End Do
                If (k < totalspin) Then
                        Call UpdatePos(pos)
                End If
        End Do
   !!!!! End of Determination of basis !!!!!

        Deallocate(pos)
 End Subroutine FormBasis

 Subroutine CheckPos(posit) !Helper routine for UpdatePos()
        Integer(kind = int_kind), Dimension(:), Allocatable :: posit
        Integer(kind = int_kind) :: k, matsiz, t
        matsiz = Size(posit)
        Do k = Size(posit), 2, -1
                If (posit(k) > spin_mat_col) then
                        posit(k) = 1
                        posit(k - 1) = posit(k - 1) + 1
                End If
                If (spinmat(k,posit(k)) == -50.0) Then
                        posit(k) = 1
                        posit(k - 1) = posit(k - 1) + 1
                End If
        End Do
 End Subroutine CheckPos

 Subroutine UpdatePos(posit1) !Helper for FormBasis()
        Integer(kind = int_kind), Dimension(:), Allocatable :: posit1
        Integer(kind = int_kind) :: k, matsiz, t
        matsiz = Size(posit1)
        posit1(matsiz) = posit1(matsiz) + 1
        Call CheckPos(posit1)
        168 Format(i2)
        189 Format(F4.1)
        Do k = 1, Size(posit1)
                posval(k) = spinmat(k, posit1(k))
        End Do
 End Subroutine UpdatePos

Subroutine HamilForm(matdimen)
   !!!!! Defining the Spin Hamiltonian(SH) !!!!!
        Integer(kind = int_kind) :: matdimen, x, y, a, b, i1, j1, k, l, row, column, m
        Real(kind = real_kind) :: t, t1, low, rais, dot
        t = 1.0_real_kind
        Allocate (hamil(totalspin,totalspin))
        jval = jval * 4.55633538e-6_real_kind !converting to Hartrees
        Do i = 1, totalspin !Initialisation of SH
                Do j = 1, totalspin
                        hamil(i,j) = 0.0
                End Do
        End Do !Initialization ends
        Do i = 1, totalspin
            Do j = 1, totalspin !i,j used for running through each value of SH
                Do k = 1, no_of_j_val !for using all J values
                    Do l = 1, j_mat_col !for each S1S2 term defined under a given J value
                        If (jmat(k,l) .ne. 0) Then
                            x = jmat(k,l)/10
                            y = Mod(jmat(k,l), 10)
                            Do m = 1, dmension
                                If (basis(i,m) .ne. -50 .AND. basis(j,m) .ne. -50) Then
                                    If (m .ne. x .AND. m .ne. y) Then
                                        !Write(12,*) 't init if', t
                                        If (basis(i,m) == basis(j,m)) Then
                                            t = t * kron_del(basis(i,m),basis(j,m))
                                        Else
                                            t = 0.0_real_kind
                                        End If
                                    End If
                                End If
                            End Do
                            rais = 0.5_real_kind*Dsqrt(spin(x)*(spin(x)+1)-basis(j,x)*(basis(j,x)+1))&
                            &*Dsqrt(spin(y)*(spin(y)+1)-basis(j,y)*(basis(j,y)-1))&
                            &*kron_del(basis(i,x),basis(j,x)+1)*kron_del(basis(i,y),basis(j,y)-1)

                            low = 0.5_real_kind*Dsqrt(spin(x)*(spin(x)+1)-basis(j,x)*(basis(j,x)-1))&
                            &*Dsqrt(spin(y)*(spin(y)+1)-basis(j,y)*(basis(j,y)+1))&
                            &*kron_del(basis(i,x),basis(j,x)-1)*kron_del(basis(i,y),basis(j,y)+1)

                            dot = basis(j,x)*basis(j,y)&
                            &*kron_del(basis(i,x),basis(j,x))*kron_del(basis(i,y),basis(j,y))

                            t1 = rais + low + dot
                            t = t * t1 *-2.0_real_kind * jval(k)
                        hamil(i,j) = hamil(i,j) + t
                        t = 1.0_real_kind
                        End If
                    End Do
                End Do
            End Do
        End Do
        168 Format(i2)
        Write (12,*)
        189 Format(1x, F19.2)
   !!!!! Definition Ends !!!!!

        Call Zeeman()
End Subroutine HamilForm

Integer Function kron_del(a, b)
        Real(kind = real_kind) :: a, b
        If (a == b) Then
                kron_del = 1.0_real_kind
        Else
                kron_del = 0.0_real_kind
        End If
End Function kron_del

Subroutine Diag(mtd, w) !Diagonalization routine
        Integer(kind = int_kind) :: n, sdim, lwork, info, lda, lrwork, liwork, abstol
        Character (Len = 1) :: Jobvs, Sort
        Real(kind = real_kind), Allocatable, Dimension (:) :: w, rwork, d, e
        Complex(kind = comp_kind), Allocatable, Dimension (:) :: work, tau
        Complex(kind = comp_kind), Allocatable, Dimension (:,:) :: mtd !matrix to be diagonalized
        !It ia known that all the matrix that require diagonlization here have the dimension (totalspin, totalspin).
        Integer, Allocatable :: iwork(:)
        n = totalspin
        lda = n
        lwork = 2*n
        lrwork = 24*n
        liwork = 10*n
        Allocate(work(lwork), rwork(lrwork), d(n), e(n-1), tau(n-1), iwork(liwork))
        sdim = 0
        Jobvs = 'N'
        Sort = 'N'
        Call ZHEEV('N',     'U' , n ,mtd,   n , w , work , lwork , rwork , info)
        !call zheev(jobz , uplo , n , a , lda , w , work , lwork , rwork , info)
        !LAPACK routine for matrix diagonalisation
End Subroutine Diag

Subroutine Zeeman()
   !!!!! Allocation !!!!!
        Integer(kind = int_kind) :: k, l, N
        Real(kind = real_kind) :: tempre, tempcm, temp1, raisre, lowre, dot, raiscm, lowcm, del, loc_B, bm
        Real(kind = real_kind), Allocatable, Dimension(:) :: eigena1, eigena2, eigena3
        Complex(kind = comp_kind), Allocatable, Dimension(:,:) :: hamil1, hamil2, hamil3
        loc_B = B/Dsqrt(3.0_real_kind)
        !loc_B is the effective value of B along x, y and z-axis assuming that B
        !is the same along each direction
        del = loc_B/(10.0_real_kind) !i.e. B/(10*dsqrt(3.D0)
        !del gives the increment in B along different directions because of which
        !the increment here is different when compared to the increment in the
        !suscep_calc subroutine where delt = B/10
        bm = 0.5 !Bohr Magneton in atomic units =  9.27400968e-24 J T-1
        N = -1
        !Write(12,*)'BM', bm
        Allocate(hamil1(totalspin, totalspin))
        Allocate(hamil2(totalspin, totalspin))
        Allocate(hamil3(totalspin, totalspin))
        Allocate(eigena1(totalspin))
        Allocate(eigena2(totalspin))
        Allocate(eigena3(totalspin))
   !!!!! Allocations end !!!!!

   !!!!!Introduction of Zeeman factor in the Hamiltonians!!!!!
        Do i = 1, totalspin
                Do j = 1, totalspin
                        tempre = 0
                        tempcm = 0
                        Do l = 1, dmension
                                temp1 = 1
                                Do k = 1, dmension
                                        If ( k == l) Then
                                                dot = bm * g * basis(j,k) *&
                                                & kron_del(basis(i,k), basis(j,k))
                                                raisre = 0.5_real_kind * bm * g * &
                                                & Dsqrt((spin(l) - basis(j,k) + 1)*(spin(l) + basis(j,k)))&
                                                & * kron_del(basis(i,k), basis(j,k)-1)
                                                raiscm = raisre
                                                lowre = 0.5_real_kind * bm * g * &
                                                & Dsqrt((spin(l) + basis(j,k) + 1)*(spin(l) - basis(j,k)))&
                                                & * kron_del(basis(i,k), basis(j,k)+1)
                                                lowcm = lowre
                                        Else
                                                temp1 = temp1 * kron_del(basis(i,k), basis(j,k))
                                        End If
                                End Do
                                tempre = tempre + temp1*(raisre + lowre + dot)
                                tempcm = tempcm + temp1*(raiscm - lowcm)
                        End Do
                hamil1(i,j) = DCmplx(hamil(i,j) + tempre*(loc_B+N*del), tempcm*(loc_B+N*del))
                N = N + 1
                hamil2(i,j) = DCmplx(hamil(i,j) + tempre*(loc_B+N*del), tempcm*(loc_B+N*del))
                N = N + 1
                hamil3(i,j) = DCmplx(hamil(i,j) + tempre*(loc_B+N*del), tempcm*(loc_B+N*del))
                N = -1
                End Do
        End Do
   !!!!!Zeeman Factor has been introduced!!!!!

   !!!!!Call for Eigen Value determination!!!!!
        call Diag(hamil1, eigena1)
        call Diag(hamil2, eigena2)
        call Diag(hamil3, eigena3)
        eigena1 = (eigena1)* 219474.625_real_kind !cm-1
        eigena2 = (eigena2)* 219474.625_real_kind
        eigena3 = (eigena3)* 219474.625_real_kind
   !!!!!Call ends!!!!!

        call suscep_calc(eigena1, eigena2, eigena3)
End Subroutine Zeeman

Subroutine suscep_calc(eigenb1, eigenb2, eigenb3)
   !!!!! Declaration and allocation of variables and arrays !!!!!
        Real(kind = real_kind), Allocatable, Dimension (:) :: eigenb1, eigenb2, eigenb3
        Real(kind = real_kind), Allocatable, Dimension (:,:) :: c
        Real(kind = real_kind), Allocatable, Dimension (:,:) :: eigen1
        Real(kind = real_kind), Allocatable, Dimension (:,:) :: work
        Real(kind = real_kind),  Allocatable, Dimension (:,:) :: B_mat
        Real(kind = real_kind),  Allocatable, Dimension (:) :: ipiv
        Real(kind = real_kind) :: N, Avo_num, beta, g, k, T, del, conv
        Integer(kind = int_kind) :: m, m1, m2, info
        Integer(kind = int_kind),  Allocatable, Dimension (:,:) :: x
        Logical :: check
        Real(kind = real_kind) :: chi, temp, temp1, delt, bltz_cnst, chi_T
        Allocate(c(totalspin, 3))
        Allocate(eigen1(totalspin, 3))
        Allocate(B_mat(3,3), x(3,3))
        Avo_num = 6.022140857e23_real_kind !mol-1
        B = B * 2.350517550e5_real_kind
        !Write(12,*) 'Magnetic Induction(Wb m-2 or T):', B
        check = .True.
        N = -1
        m = 3
        m1 = 4
        m2 = 5
        delt = B/10.0_real_kind
        Allocate(work(m,m))
        Allocate(ipiv(m))
        T = 1 !Temperature in Kelvin
        bltz_cnst = 0.695039_real_kind !cm-1 K-1
        beta = 1 / (T * bltz_cnst)
   !!!!! Declaration and allocation part ends !!!!!

   !!!!! Assignment of values to the B matrices and the eigen value matrices !!!!!
        Do i = 1, 3
                Do j = 1, 3
                        If (i == 1) Then
                                If (check  == .True.) Then
                                        Do k = 1, totalspin
                                                eigen1(k,i) = eigenb1(k)
                                         End Do
                                         check = .False.
                                End If
                                If (j <= 3) Then
                                        B_mat(i,j) = 1.0_real_kind
                                End If
                        Else
                                If (check  == .True.) Then
                                        if (i == 2) then
                                        Do k = 1, totalspin
                                                eigen1(k,i) = eigenb2(k)
                                        End Do
                                        Else
                                        Do k = 1, totalspin
                                                eigen1(k,i) = eigenb3(k)
                                        End Do
                                        End If
                                        check = .False.
                                End If
                                If (j <= 3) Then
                                        B_mat(i, j) = (0 + (N * delt)) ** (i - 1)
                                End If
                        End If
                        N = N + 1
                        check = .True.
                End Do
                N = -1
        End Do
   !!!!! Assignment of values finished !!!!!

   !!!!! Determination of the coefficent matrices !!!!!
        !call dgetrf(m, n, a,   lda, ipiv, info)
        call dgetrf(m, m, B_mat, m, ipiv, info)
        !call dgetri ( n, a, lda, ipiv, work, lwork, info )
        call dgetri (m, B_mat, m, ipiv, work, m, info)
        c = Matmul(eigen1, B_mat)
   !!!!! Determination of the coefficent matrices ends !!!!!

   !!!!!Determination of Chi!!!!!
        Write(12,*) "Temperature           Chi                  Chi*Temp"
        178 Format(F25.9)
        193 Format(F12.4)
        conv = 1.98644746e-23_real_kind
        Do T = 1, 300 !temperature
                temp  = 0
                temp1 = 0
                Do j = 1, totalspin !equal to Size(eigenb1)
                        temp = temp + DExp(-c(j,1)/(bltz_cnst*T)) * (((c(j, 2) * c(j, 2))/(bltz_cnst*T)) - 2.0_real_kind*c(j,3))
                        temp1 = temp1 + DExp(-c(j,1)/(bltz_cnst*T))
                End Do
                chi = conv * Avo_num * (temp / temp1) * vac_perm  / (4.0_real_kind * pi * 1.0e-6_real_kind) !cm3/mol
                chi_T = chi * T !cm3K/mol
                Write(12, 193, advance = 'no') T
                Write(12, 178, advance = 'no') chi
                Write(12, 178) chi_T
        End Do
   !!!!!Determination ends!!!!!

End Subroutine suscep_calc

End Program suscep


PROGRAM EigensystemTest

  USE KindModule, ONLY: &
    DP, One
  USE UtilitiesModule, ONLY: &
    WriteVector, &
    WriteRank3Tensor
  USE UnitsModule, ONLY: &
    Centimeter, Gram, &
    Kelvin, Erg, &
    AtomicMassUnit
  USE PhysicalConstantsModule, ONLY: &
    SpeedOfLightCGS
  USE EquationOfStateModule_TABLE, ONLY: &
    Min_D, Min_T, Min_Y, &
    Max_D, Max_T, Max_Y, &
    InitializeEquationOfState_TABLE, &
    FinalizeEquationOfState_TABLE, &
    ApplyEquationOfState_TABLE, &
    ComputePressure_TABLE, &
    ComputeSpecificInternalEnergy_TABLE, &
    ComputeAuxiliary_Fluid_Table
  USE Euler_CharacteristicDecompositionModule_NonRelativistic_TABLE, ONLY: &
    ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE
  USE GeometryFieldsModule, ONLY: &
      nGF
  USE FluidFieldsModule, ONLY: &
      nCF, iCF_D, iCF_S1, iCF_S2, iCF_S3, &
      iCF_E, iCF_Ne

  IMPLICIT NONE

  INTEGER :: &
    n_rndm, &
    iPoint, iV
  INTEGER, PARAMETER :: &
    iD = 1, iT = 2, iY = 3, &
    nPoints = 2**8, &
    nVariables = 15

  ! --- Set custom table bounds here. ---

  !REAL(DP), PARAMETER :: &
    !Min_D = 0.15d14 * Gram / Centimeter**3, &
    !Max_D = 0.35d14 * Gram / Centimeter**3, &
    !Min_T = 0.70d11 * Kelvin, &
    !Max_T = 0.85d11 * Kelvin, &
    !Min_Y = 0.15, &
    !Max_Y = 0.15

  REAL(DP), DIMENSION(nPoints) :: &
    D, T, Y, Ne, P, E,            &
    S, Me, Mp, Mn,            &
    Xp, Xn, Xa, Xh,           &
    Gm_A, Gm_T,               &
    dPdD, dPdT, dPdY, dPdDe,  &
    dEdD, dEdT, dEdY,         &
    alpha, beta, cs_T,        &
    rndm_D,      &
    rndm_T,      &
    rndm_Y

  REAL(DP), DIMENSION(nGF) :: G
  REAL(DP), DIMENSION(nCF) :: U
  REAL(DP), DIMENSION(nCF,nCF,nPoints) :: R_1_a, invR_1_a, dFdU_1_a
  REAL(DP), DIMENSION(nCF,nCF,nPoints) :: R_1_n, invR_1_n, dFdU_1_n

  CALL InitializeEquationOfState_TABLE &
         ("wl-EOS-SFHo-25-50-100.h5")

  WRITE(*,*)
  WRITE(*,'(A4,A10,I10.10)') '', 'nPoints = ', nPoints
  WRITE(*,*)

  n_rndm = nPoints

  ! --- Initialize Density Points ---

  CALL RANDOM_SEED( SIZE = n_rndm )
  CALL RANDOM_NUMBER( rndm_D )

  D(:) = 10**( LOG10(minD) + ( LOG10(maxD) - LOG10(minD) ) * rndm_D )

  CALL WriteVector(nPoints, D / Gram * Centimeter**3, 'D.dat')

  ! --- Initialize Temperature Points ---

  CALL RANDOM_SEED( SIZE = n_rndm )
  CALL RANDOM_NUMBER( rndm_T )

  T(:) = 10**( LOG10(minT) + ( LOG10(maxT) - LOG10(minT) ) * rndm_T )

  CALL WriteVector(nPoints, T / Kelvin, 'T.dat')

  ! --- Initialize Electron Fraction Points ---

  CALL RANDOM_SEED( SIZE = n_rndm )
  CALL RANDOM_NUMBER( rndm_Y )

  Y(:) = minY + ( maxY - minY ) * rndm_Y

  CALL WriteVector(nPoints, Y, 'Y.dat')

  ! --- Get derivatives with respect to D, T, and Y. ---

  CALL ApplyEquationOfState_TABLE &
         ( D, T, Y, P, S, E, Me, Mp, Mn, Xp, Xn, Xa, Xh, Gm_T )
  CALL ComputePressure_TABLE &
         ( D, T, Y, P, dPdD, dPdT, dPdY )
  CALL ComputeSpecificInternalEnergy_TABLE &
         ( D, T, Y, E, dEdD, dEdT, dEdY )

  ! --- Get sound speed from characteristic decomposition module. ---

  G(:) = 1.0_DP

  DO iPoint = 1, nPoints

    U(iCF_D) = D(iPoint)
    U(iCF_S1) = 0.0_DP
    U(iCF_S2) = 0.0_DP
    U(iCF_S3) = 0.0_DP
    U(iCF_E)  = D(iPoint) * E(iPoint)
    U(iCF_Ne) = D(iPoint) * Y(iPoint) / AtomicMassUnit

    E(iPoint)  = D(iPoint) * E(iPoint)
    Ne(iPoint) = D(iPoint) * Y(iPoint) / AtomicMassUnit

    CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE &
           ( 1, G, U, R_1_n(:,:,iPoint), invR_1_n(:,:,iPoint), dFdU_1_n(:,:,iPoint), cs_T(iPoint), UseAnalytic_Option = .FALSE. )

    CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE &
           ( 1, G, U, R_1_a(:,:,iPoint), invR_1_a(:,:,iPoint), dFdU_1_a(:,:,iPoint), cs_T(iPoint), UseAnalytic_Option = .TRUE. )

  END DO

  alpha(1:nPoints) = dPdT / ( dEdT * D )
  dPdDe(1:nPoints) = dPdY / D - dEdY * alpha
  beta(1:nPoints)  = dPdDe * Y + dEdD * alpha * D - dPdD
  Gm_A(1:nPoints)  = ( dPdDe * Y - beta ) * D / P  + alpha

  CALL WriteVector(nPoints, P / Erg * Centimeter**3, 'P.dat')
  CALL WriteVector(nPoints, E / Erg * Gram, 'E.dat')
  CALL WriteVector(nPoints, cs_T * SpeedOfLightCGS, 'cs_T.dat')

  CALL WriteVector(nPoints, alpha, 'alpha.dat')
  CALL WriteVector(nPoints, beta *  ( Gram / Erg ), 'beta.dat')
  CALL WriteVector(nPoints, dPdDe * ( Gram / Erg ), 'dPdDe.dat')
  CALL WriteVector(nPoints, Gm_A, 'Gm_A.dat')
  CALL WriteVector(nPoints, Gm_T, 'Gm_T.dat')

  CALL WriteRank3Tensor(6,6,nPoints, R_1_n, 'R_1_n.dat')
  CALL WriteRank3Tensor(6,6,nPoints, invR_1_n, 'invR_1_n.dat')
  CALL WriteRank3Tensor(6,6,nPoints, dFdU_1_n, 'dFdU_1_n.dat')

  CALL WriteRank3Tensor(6,6,nPoints, R_1_a, 'R_1_a.dat')
  CALL WriteRank3Tensor(6,6,nPoints, invR_1_a, 'invR_1_a.dat')
  CALL WriteRank3Tensor(6,6,nPoints, dFdU_1_a, 'dFdU_1_a.dat')

END PROGRAM EigensystemTest


MODULE MOD_BOXES
    IMPLICIT NONE
    INTEGER, PARAMETER :: nbox = 3
END MODULE MOD_BOXES

MODULE MOD_DIMENSIONS
USE MOD_PRECISION
USE MOD_BOXES

IMPLICIT NONE

! geometry
REAL(KIND=wp), DIMENSION(nbox)      :: dx, dy, dz, lat
REAL(KIND=wp), DIMENSION(nbox)      :: area, vol, invol, depth, pressure
REAL(KIND=wp), DIMENSION(nbox,nbox) :: K, R

CONTAINS
! Routines below are specifically put here because they require hard coding
!   using information specifically for each set up:
!
! ESTABLISH_DIMENSIONS makes dimensional info (dx, dy, dz, areas, vols, etc)
!                      available to the main model.
! TRANSPORT calculates advective and diffusive fluxes between boxes.
! CALC_PSTAR calculates efficiency of the biological pump associated with
!                      fluxes going into and out of the Southern Ocean box.

!=======================================================================
SUBROUTINE ESTABLISH_DIMENSIONS(dx,dy,dz,lat,area,vol,invol,           &
                                              depth,pressure,K,R)
USE MOD_BOXES
IMPLICIT NONE
REAL(KIND=wp), DIMENSION(nbox),      intent(out) :: dx, dy, dz,        &
                                                 lat, area, vol, invol,&
                                                 depth, pressure
REAL(KIND=wp), DIMENSION(nbox,nbox), intent(out) :: K, R
REAL(KIND=wp)                                    :: m2deg

dx   = (/ 17.0e6_wp, 17.0e6_wp, 17.0e6_wp /)
dy   = (/  4.0e6_wp, 12.0e6_wp, 16.0e6_wp /)
dz   = (/ 50.0_wp,   50.0_wp, 5050.0_wp   /)

! depth in m or decibars
depth = (/ 25.0_wp,   25.0_wp, 2575.0_wp /)
! applied pressure in bars for carbon system coefficients
pressure = (depth/10._wp) - 1._wp

m2deg = 180._wp/(dy(1)+dy(2))
lat = (/ -90._wp+(dy(1)       /2._wp) *m2deg,                          &
         -90._wp+(dy(1)+(dy(2)/2._wp))*m2deg,                          &
         -90._wp+(dy(3)       /2._wp) *m2deg                           &
       /)

area     = dx * dy
vol      = area * dz
invol    = 1._wp / vol

! define array of mixing rates
K = RESHAPE( (/ 0._wp, 1._wp, 1._wp,                                   &
                1._wp, 0._wp, 1._wp,                                   &
                1._wp, 1._wp, 0._wp /),                                &
                (/ nbox, nbox /) )
K = K * 1.e6_wp

! define array of remineralization coefficients (Columnwise)
! -1 indicates all of export is lost from cell, while
! +1 indicates all of export is remineralized (gained) by cell
! Thus (/-1.0, 0.0, 1.0,                                   &
!         0.0,-1.0, 1.0,                                   &
!         0.0, 0.0, 0.0 /),
! indicates the first box (column one) loses export from box 1,
!           the second box (col two) loses export from box 2,
!       and the third box (col three) gains export from boxes 1 and 2
R = RESHAPE((/-1._wp, 0._wp, 1._wp,                                    &
               0._wp,-1._wp, 1._wp,                                    &
               0._wp, 0._wp, 0._wp /),                                 &
               (/ nbox, nbox /) )
RETURN
END SUBROUTINE ESTABLISH_DIMENSIONS
!=======================================================================

!=======================================================================
FUNCTION TRANSPORT(x, kappa, psi, invol)
! atmosphere-3-box-ocean carbon cycle model
! evaluate rates of change due to transport
! mick follows, march 2015/ june 2016
USE MOD_BOXES
IMPLICIT NONE
REAL(KIND=wp), DIMENSION(nbox)                  :: TRANSPORT
REAL(KIND=wp), intent(in), DIMENSION(nbox)      :: x
REAL(KIND=wp), intent(in), DIMENSION(nbox,nbox) :: kappa
REAL(KIND=wp), intent(in)                       :: psi
REAL(KIND=wp), intent(in), DIMENSION(nbox)      :: invol
!
TRANSPORT(1) = invol(1) * (                                            &
            psi*(x(3)-x(1))                                            &
          + kappa(3,1)*(x(3)-x(1))                                     &
          + kappa(2,1)*(x(2)-x(1))                                     &
            )
TRANSPORT(2) = invol(2) * (                                            &
            psi*(x(1)-x(2))                                            &
          + kappa(1,2)*(x(1)-x(2))                                     &
          + kappa(3,2)*(x(3)-x(2))                                     &
            )
TRANSPORT(3) = invol(3) * (                                            &
            psi*(x(2)-x(3))                                            &
          + kappa(2,3)*(x(2)-x(3))                                     &
          + kappa(1,3)*(x(1)-x(3))                                     &
            )

       RETURN
       END FUNCTION TRANSPORT
!=======================================================================

!=======================================================================
FUNCTION CALC_PSTAR(nutrient)
! atmosphere-3-box-ocean carbon cycle model
! evaluate rates of change due to transport
! mick follows, march 2015/ june 2016
USE MOD_BOXES
IMPLICIT NONE
REAL(KIND=wp) :: CALC_PSTAR

REAL(KIND=wp), DIMENSION(nbox), intent(in) :: nutrient

CALC_PSTAR = (nutrient(3) - nutrient(1)) / nutrient(3)

RETURN
END FUNCTION CALC_PSTAR
!=======================================================================

END MODULE MOD_DIMENSIONS


! @@name:	SIMD.2f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	yes
! @@expect:	success
program main
   implicit none
   integer, parameter :: N=32
   integer :: i
   double precision   :: a(N), b(N)
   do i = 1,N
      a(i) = i-1
      b(i) = N-(i-1)
   end do
   call work(a, b, N )
   do i = 1,N
      print*, i,a(i)
   end do
end program

function add1(a,b,fact) result(c)
!$omp declare simd(add1) uniform(fact)
   implicit none
   double precision :: a,b,fact, c
   c = a + b + fact
end function

function add2(a,b,i, fact) result(c)
!$omp declare simd(add2) uniform(a,b,fact) linear(i:1)
   implicit none
   integer          :: i
   double precision :: a(*),b(*),fact, c
   c = a(i) + b(i) + fact
end function

subroutine work(a, b, n )
   implicit none
   double precision           :: a(n),b(n), tmp
   integer                    :: n, i
   double precision, external :: add1, add2

   !$omp simd private(tmp)
   do i = 1,n
      tmp  = add1(a(i), b(i), 1.0d0)
      a(i) = add2(a,    b, i, 1.0d0) + tmp
      a(i) = a(i) + b(i) + 1.0d0
   end do
end subroutine


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! RUN: %flang --target=aarch64-unknown-linux-gnu -Kieee -S -emit-llvm %s -o - | FileCheck %s
! RUN: %flang --target=aarch64-unknown-linux-gnu -Kieee -r8 -S -emit-llvm %s -o - | FileCheck %s
! REQUIRES: aarch64

subroutine testA(r1,r2,r3,r4,r5,r6)
! CHECK-LABEL: @testa
! CHECK: call float @__ps_sin_1(float
! CHECK: call double @__pd_sin_1(double
  real(kind=4) :: r1
  real(kind=4) :: r2
  real(kind=8) :: r3
  real(kind=8) :: r4

  r2 = sin(r1)*cos(r1)
  r4 = sin(r3)*cos(r3)

  r2 = sin(r1)
  r4 = sin(r3)
end subroutine

subroutine testB(r1,r2,r3,r4,r5,r6)
! CHECK-LABEL: @testb
! CHECK: call float @__ps_cos_1(float
! CHECK: call double @__pd_cos_1(double
  real(kind=4) :: r1
  real(kind=4) :: r2
  real(kind=8) :: r3
  real(kind=8) :: r4

  r2 = sin(r1)*cos(r1)
  r4 = sin(r3)*cos(r3)

  r2 = cos(r1)
  r4 = cos(r3)
end subroutine

! Ensure the math routines are declared like pure functions.

! CHECK: declare double @__pd_sin_1(double) #[[ATTR_ID:[0-9]+]]
! CHECK: declare double @__pd_cos_1(double) #[[ATTR_ID]]

! CHECK: declare float @__ps_sin_1(float) #[[ATTR_ID]]
! CHECK: declare float @__ps_cos_1(float) #[[ATTR_ID]]

! CHECK: attributes #[[ATTR_ID]] = { nounwind readnone willreturn


MODULE GLOBAL
use assert, only: wp

IMPLICIT NONE

CHARACTER(*), PARAMETER :: VERSION = '1.1.7'

INTEGER :: STACK_SIZE                                         ! stack size
INTEGER, PARAMETER :: REG_SIZE = 10                                           ! number of storage registers
real(wp), allocatable :: STACK(:)                           ! real stack
real(wp), DIMENSION (0:REG_SIZE-1) :: REG                             ! real storage registers
COMPLEX(wp), allocatable :: CSTACK(:)                           ! complex stack
COMPLEX(wp), DIMENSION (0:REG_SIZE-1) :: CREG                             ! complex storage registers
INTEGER, allocatable :: RNSTACK(:), RDSTACK(:)                      ! rational stack
INTEGER, DIMENSION (0:REG_SIZE-1) :: RNREG, RDREG                             ! rational storage registers
real(wp) :: LASTX                                                     ! real LAST X register
COMPLEX(wp) :: CLASTX                                                     ! complex LAST X register
INTEGER :: RNLASTX, RDLASTX                                                   ! rational LAST X register
real(wp) :: NN, SUMX, SUMX2, SUMY, SUMY2, SUMXY                       ! real summation registers
COMPLEX(wp) :: CNN, CSUMX, CSUMX2, CSUMY, CSUMY2, CSUMXY                  ! complex summation registers
INTEGER :: RNNN, RNSUMX, RNSUMX2, RNSUMY, RNSUMY2, RNSUMXY                    ! rational summation registers (num.)
INTEGER :: RDNN, RDSUMX, RDSUMX2, RDSUMY, RDSUMY2, RDSUMXY                    ! rational summation registers (den.)
real(wp) :: ANGLE_FACTOR, FRACTOL
INTEGER :: ANGLE_MODE, DISP_MODE, DISP_DIGITS, BASE_MODE, DOMAIN_MODE, &
   FRACTION_MODE

INTEGER, PARAMETER :: INITIAL_ANGLE_MODE = 1                                  ! 1=deg 2=rad 3=grad 4=rev
INTEGER, PARAMETER :: INITIAL_DISP_MODE = 4                                   ! 1=fix, 2=sci, 3=eng, 4=all
INTEGER, PARAMETER :: INITIAL_DISP_DIGITS = 4
INTEGER, PARAMETER :: INITIAL_DOMAIN_MODE = 1                                 ! 1=real, 2=complex, 3=rational
INTEGER, PARAMETER :: INITIAL_BASE_MODE = 10                                  ! 2=bin, 8=oct, 10=dec, 16=hex
INTEGER, PARAMETER :: INITIAL_FRACTION_MODE = 1                               ! 1=improper, 2=mixed
real(wp), PARAMETER :: INITIAL_FRACTOL = 1.0D-4                       ! tolerance for decimal to fraction conversion

contains

subroutine init_stack()

integer :: i
character(16) :: argv

stack_size = 4  ! default
call get_command_argument(1, argv, status=i)
if (i==0) read(argv,'(I2)') stack_size

if (stack_size < 2) stack_size=2  ! doesn't make sense to have only 1 level

allocate(stack(stack_size), cstack(stack_size), rdstack(stack_size), rnstack(stack_size))

end subroutine init_stack

END MODULE GLOBAL


program stack_overflow
    use, intrinsic :: iso_fortran_env, only : i64 => INT64
    implicit none
    integer(kind=i64) :: n
    character(len=80) :: buffer

    if (command_argument_count() > 0) then
        call get_command_argument(1, buffer)
        read (buffer, '(I20)') n
    else
        n = 5_i64
    end if
    print '(I5, A, I20)', n, ' = ', fib(n)

contains

    recursive function fib(n) result(r)
        use, intrinsic :: iso_fortran_env, only : i64 => INT64
        implicit none
        integer(kind=i64), intent(in) :: n
        integer(kind=i64) :: r
        r = fib(n-1) + fib(n-2)
    end function fib

end program stack_overflow


MODULE mo_nelmin

  ! This module provides NELMIN, which minimizes a function using the Nelder-Mead algorithm
  ! with the Applied Statistics algorithms No. 047.

  ! Written  Matthias Cuntz, Jul 2012 - extended asa047 of John Burkardt

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

  USE mo_kind,  ONLY: i4, sp, dp
  USE mo_utils, ONLY: ne

  IMPLICIT NONE

  PUBLIC :: nelmin          ! minimizes a function using the Nelder-Mead algorithm
  PUBLIC :: nelminxy        ! same as nelmin but pass x and y to function
  PUBLIC :: nelminrange     ! same as nelmin but with given range of parameter

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

  !     NAME
  !         nelmin
  !         nelminxy
  !         nelminrange

  !     PURPOSE
  !         Minimizes a user-specified function using the Nelder-Mead algorithm.
  !
  !         Simplex function minimisation procedure due to Nelder and Mead (1965),
  !         as implemented by O'Neill(1971, Appl.Statist. 20, 338-45), with
  !         subsequent comments by Chambers+Ertel(1974, 23, 250-1), Benyon(1976,
  !         25, 97) and Hill(1978, 27, 380-2)
  !
  !         The function to be minimized is the first argument of nelmin and
  !         must be defined as
  !           FUNCTION func(p)
  !             USE mo_kind, ONLY: dp
  !             IMPLICIT NONE
  !             REAL(dp), DIMENSION(:),           INTENT(IN) :: p
  !             REAL(dp) :: func
  !           END FUNCTION func
  !
  !         and for nelminxy
  !           FUNCTION func(p,x,y)
  !             USE mo_kind, ONLY: dp
  !             IMPLICIT NONE
  !             REAL(dp), DIMENSION(:), INTENT(IN) :: p
  !             REAL(dp), DIMENSION(:), INTENT(IN) :: x
  !             REAL(dp), DIMENSION(:), INTENT(IN) :: y
  !             REAL(dp) :: func
  !           END FUNCTION func
  !
  !         This routine does not include a termination test using the
  !         fitting of a quadratic surface.

  !     CALLING SEQUENCE
  !         pmin = nelmin(func, pstart, funcmin, varmin, step, konvge, maxeval, &
  !                       neval, numrestart, ierror)
  !         pmin = nelminxy(func, pstart, xx, yy, funcmin, varmin, step, konvge, maxeval, &
  !                         neval, numrestart, ierror)
  !         pmin = nelmin(func, pstart, prange, funcmin, varmin, step, konvge, maxeval, &
  !                       neval, numrestart, ierror)

  !     INTENT(IN)
  !         real(dp) :: func(p,xx,yy)    Function on which to search the minimum
  !         real(dp) :: pstart(:)        Starting point for the iteration.
  !         real(dp) :: xx               First values to pass as function arguments
  !         real(dp) :: yy               Second values to pass as function arguments
  !         real(dp) :: prange(:,2)      Range of parameters (upper and lower bound).

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(dp) :: nelmin(size(start))    the coordinates of the point which is estimated to minimize the function.

  !     INTENT(IN), OPTIONAL
  !         real(dp) :: varmin           the terminating limit for the variance
  !                                      of the function values. varmin>0 is required.
  !         real(dp) :: step(:)          determines the size and shape of the initial simplex.
  !                                      The relative magnitudes of its elements should reflect
  !                                      the units of the variables. size(step)=size(start)
  !         integer(i4) :: konvge        the convergence check is carried out every konvge iterations.
  !                                      konvge>0 is required.
  !         integer(i4) :: maxeval       the maximum number of function evaluations.
  !                                      default: 1000

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         real(dp)    :: funcmin             the minimum value of the function.
  !         integer(i4) :: neval               the number of function evaluations used.
  !         integer(i4) :: numrestart          the number of restarts.
  !         integer(i4) :: ierror              error indicator.
  !                                            0: no errors detected.
  !                                            1: varmin or konvge have an illegal value.
  !                                            2: iteration terminated because maxeval was exceeded without convergence.
  !         real(dp), allocatable
  !                     :: history(:)          the history of best function values, history(neval)=funcmin

  !     RESTRICTIONS
  !         None.

  !     EXAMPLE
  !         pstart(1:n) = (/ -1.2_dp, 1.0_dp /)
  !         step(1:n) = (/ 1.0_dp, 1.0_dp /)
  !         pmin = nelmin(rosenbrock, pstart, step=step, ierror=ierror)
  !         -> see also example in test directory

  !     LITERATURE
  !         Simplex function minimisation procedure due to Nelder and Mead (1965),
  !         as implemented by O'Neill(1971, Appl.Statist. 20, 338-45), with
  !         subsequent comments by Chambers+Ertel(1974, 23, 250-1), Benyon(1976,
  !         25, 97) and Hill(1978, 27, 380-2)

  !         John Nelder, Roger Mead, A simplex method for function minimization,
  !         Computer Journal, Volume 7, 1965, pages 308-313.

  !         R ONeill, Algorithm AS 47: Function Minimization Using a Simplex Procedure,
  !         Applied Statistics, Volume 20, Number 3, 1971, pages 338-345.

  !     HISTORY
  !         Original FORTRAN77 version by R ONeill.
  !         FORTRAN90 version by John Burkardt.
  !         Modified,  Matthias Cuntz, Jul 2012 - i4, dp, intent
  !                                             - function, optional
  !                                             - nelminxy
  !                    Juliane Mai,    Aug 2012 - nelminrange
  !                    Juliane Mai,    Dec 2012 - history output

  INTERFACE nelminrange
     MODULE PROCEDURE nelminrange_dp, nelminrange_sp
  END INTERFACE nelminrange

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

  PRIVATE

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

CONTAINS

  function nelmin(func, pstart, varmin, step, konvge, maxeval, &
       funcmin, neval, numrestart, ierror, history)

    implicit none

    INTERFACE
       FUNCTION func(pp)
         USE mo_kind, ONLY: dp
         IMPLICIT NONE
         REAL(dp), DIMENSION(:), INTENT(IN) :: pp
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    real(dp),              intent(IN)  :: pstart(:)
    real(dp),    optional, intent(IN)  :: varmin
    real(dp),    optional, intent(IN)  :: step(:)
    integer(i4), optional, intent(IN)  :: konvge
    integer(i4), optional, intent(IN)  :: maxeval
    real(dp),    optional, intent(OUT) :: funcmin
    integer(i4), optional, intent(OUT) :: neval
    integer(i4), optional, intent(OUT) :: numrestart
    integer(i4), optional, intent(OUT) :: ierror
    real(dp),    optional, intent(OUT), allocatable :: history(:)  ! History of objective function values
    real(dp) :: nelmin(size(pstart))

    real(dp), parameter :: ccoeff = 0.5_dp
    real(dp), parameter :: ecoeff = 2.0_dp
    real(dp), parameter :: rcoeff = 1.0_dp
    real(dp), parameter :: eps    = 0.001_dp
    real(dp) :: ipstart(size(pstart))
    real(dp) :: ifuncmin
    real(dp) :: ivarmin
    real(dp) :: istep(size(pstart))
    integer(i4) :: ikonvge
    integer(i4) :: imaxeval
    integer(i4) :: ineval
    integer(i4) :: inumrestart
    integer(i4) :: iierror
    integer(i4) :: n, nn
    integer(i4) :: i
    integer(i4) :: ihi
    integer(i4) :: ilo
    integer(i4) :: j
    integer(i4) :: jcount
    integer(i4) :: l
    real(dp) :: del
    real(dp) :: p(size(pstart),size(pstart)+1)
    real(dp) :: p2star(size(pstart))
    real(dp) :: pbar(size(pstart))
    real(dp) :: pstar(size(pstart))
    real(dp) :: rq
    real(dp) :: x
    real(dp) :: y(size(pstart)+1)
    real(dp) :: y2star
    real(dp) :: ylo
    real(dp) :: ystar
    real(dp) :: z
    real(dp) :: dn, dnn
    real(dp) :: p0(size(pstart)), y0
    real(dp), allocatable :: history_tmp(:)
    !
    ! Defaults
    !
    nelmin(:) = 0.
    if (present(varmin)) then
       if (varmin <= 0.0_dp) stop 'Error nelmin: varmin<0'
       ivarmin = varmin
    else
       ivarmin = 1.0e-9_dp
    endif
    ! maximal number of function evaluations
    if (present(maxeval)) then
       if (maxeval <= 1) stop 'Error nelmin: maxeval<=1'
       imaxeval = maxeval
    else
       imaxeval = 1000
    endif
    ! history output
    if (present(history)) then
       ! worst case length
       allocate(history_tmp(imaxeval+3*size(ipstart)+1))
    end if
    if (present(konvge)) then
       ikonvge = konvge
    else
       ikonvge = imaxeval / 10
    endif
    if (ikonvge < 1) stop 'Error nelmin: konvg<1'
    !
    if (present(step)) then
       istep = step
    else ! if not given, deviate initial by 1%
       y0 = func(pstart)
       do i=1, size(pstart)
          p0 = pstart
          if (ne(p0(i),0.0_dp)) then
             p0(i) = 1.01_dp*p0(i)
          else
             p0(i) = 0.01_dp
          endif
          istep(i) = abs(func(p0) - y0)
       enddo
    endif
    !
    !  Check the input parameters.
    !
    !
    !  Initialization.
    !
    ipstart = pstart
    n       = size(ipstart)
    ineval  = 0_i4
    inumrestart = 0_i4
    jcount = ikonvge
    dn     = real(n, dp)
    nn     = n + 1
    dnn    = real(nn, dp)
    del    = 1.0_dp
    rq     = ivarmin * dn
    !
    !  Initial or restarted loop.
    !
    do
       p(1:n,nn) = ipstart(1:n)
       y(nn)     = func(ipstart)
       ineval     = ineval + 1
       if (present(history)) history_tmp(ineval) = y(nn)
       !
       !  Define the initial simplex.
       !
       do j = 1, n
          x          = ipstart(j)
          ipstart(j) = ipstart(j) + istep(j) * del
          p(1:n,j)   = ipstart(1:n)
          y(j)       = func(ipstart)
          ineval     = ineval + 1
          ipstart(j) = x
          if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
       end do
       !
       !  Find highest and lowest Y values.  FUNCMIN = Y(IHI) indicates
       !  the vertex of the simplex to be replaced.
       !
       ilo = minloc(y(1:n+1), 1)
       ylo = y(ilo)
       !
       !  Inner loop.
       !
       do while ( ineval < imaxeval )
          !
          !  FUNCMIN is, of course, the HIGHEST value???
          !
          ihi     = maxloc(y(1:n+1), 1)
          ifuncmin = y(ihi)
          !
          !  Calculate PBAR, the centroid of the simplex vertices
          !  excepting the vertex with Y value FUNCMIN.
          !
          do i = 1, n
             pbar(i) = ( sum(p(i,1:n+1)) - p(i,ihi) ) / dn
          end do
          !
          !  Reflection through the centroid.
          !
          pstar(1:n) = pbar(1:n) + rcoeff * ( pbar(1:n) - p(1:n,ihi) )
          ystar      = func(pstar)
          ineval      = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( ystar, history_tmp(ineval-1) )
          !
          !  Successful reflection, so extension.
          !
          if ( ystar < ylo ) then

             p2star(1:n) = pbar(1:n) + ecoeff * ( pstar(1:n) - pbar(1:n) )
             y2star      = func(p2star)
             ineval       = ineval + 1
             if (present(history)) history_tmp(ineval) = Min( y2star, history_tmp(ineval-1) )
             !
             !  Retain extension or contraction.
             !
             if ( ystar < y2star ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
             else
                p(1:n,ihi) = p2star(1:n)
                y(ihi)     = y2star
             end if
             !
             !  No extension.
             !
          else
             l = 0
             do i = 1, nn
                if ( ystar < y(i) ) l = l + 1
             end do

             if ( 1 < l ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
                !
                !  Contraction on the Y(IHI) side of the centroid.
                !
             else if ( l == 0 ) then
                p2star(1:n) = pbar(1:n) + ccoeff * ( p(1:n,ihi) - pbar(1:n) )
                y2star      = func(p2star)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star, history_tmp(ineval-1) )
                !
                !  Contract the whole simplex.
                !
                if ( y(ihi) < y2star ) then
                   do j = 1, n + 1
                      p(1:n,j)  = ( p(1:n,j) + p(1:n,ilo) ) * 0.5_dp
                      nelmin(1:n) = p(1:n,j)
                      y(j)      = func(nelmin)
                      ineval     = ineval + 1
                      if (present(history)) history_tmp(ineval) = Min( y(j), history_tmp(ineval-1) )
                   end do
                   ilo = minloc(y(1:n+1), 1)
                   ylo = y(ilo)

                   cycle
                   !
                   !  Retain contraction.
                   !
                else
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                end if
                !
                !  Contraction on the reflection side of the centroid.
                !
             else if ( l == 1 ) then

                p2star(1:n) = pbar(1:n) + ccoeff * ( pstar(1:n) - pbar(1:n) )
                y2star      = func(p2star)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star, history_tmp(ineval-1) )
                !
                !  Retain reflection?
                !
                if ( y2star <= ystar ) then
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                else
                   p(1:n,ihi) = pstar(1:n)
                   y(ihi)     = ystar
                end if

             end if

          end if
          !
          !  Check if YLO improved.
          !
          if ( y(ihi) < ylo ) then
             ylo = y(ihi)
             ilo = ihi
          end if

          jcount = jcount - 1

          if ( 0 < jcount ) cycle
          !
          !  Check to see if minimum reached.
          !
          if ( ineval <= imaxeval ) then
             jcount = ikonvge
             x = sum ( y(1:n+1) ) / dnn
             z = sum ( ( y(1:n+1) - x )**2 )
             if ( z <= rq ) exit
          end if

       end do
       !
       !  Factorial tests to check that FUNCMIN is a local minimum.
       !
       nelmin(1:n) = p(1:n,ilo)
       ifuncmin   = y(ilo)

       if ( imaxeval < ineval ) then
          iierror = 2
          exit
       end if

       iierror = 0

       do i = 1, n
          del     = istep(i) * eps
          nelmin(i) = nelmin(i) + del
          z       = func(nelmin)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z, history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          nelmin(i) = nelmin(i) - del - del
          z       = func(nelmin)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z, history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          nelmin(i) = nelmin(i) + del
       end do

       if ( iierror == 0 ) exit
       !
       !  Restart the procedure.
       !
       ipstart(1:n) = nelmin(1:n)
       del          = eps
       inumrestart  = inumrestart + 1

    end do

    if (present(funcmin)) then
       funcmin = ifuncmin
    endif
    if (present(neval)) then
       neval = ineval
    endif
    if (present(numrestart)) then
       numrestart = inumrestart
    endif
    if (present(ierror)) then
       ierror = iierror
    endif
    if (present(history)) then
       allocate(history(ineval))
       history(:) = history_tmp(1:ineval)
    end if

  end function nelmin

  function nelminxy(func, pstart, xx, yy, varmin, step, konvge, maxeval, &
       funcmin, neval, numrestart, ierror, history)

    implicit none

    INTERFACE
       FUNCTION func(pp, xxx, yyy)
         USE mo_kind, ONLY: dp
         IMPLICIT NONE
         REAL(dp), DIMENSION(:), INTENT(IN) :: pp
         REAL(dp), DIMENSION(:), INTENT(IN) :: xxx
         REAL(dp), DIMENSION(:), INTENT(IN) :: yyy
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    real(dp),              intent(IN)  :: pstart(:)
    real(dp),              intent(IN)  :: xx(:)
    real(dp),              intent(IN)  :: yy(:)
    real(dp),    optional, intent(OUT) :: funcmin
    real(dp),    optional, intent(IN)  :: varmin
    real(dp),    optional, intent(IN)  :: step(:)
    integer(i4), optional, intent(IN)  :: konvge
    integer(i4), optional, intent(IN)  :: maxeval
    integer(i4), optional, intent(OUT) :: neval
    integer(i4), optional, intent(OUT) :: numrestart
    integer(i4), optional, intent(OUT) :: ierror
    real(dp),    optional, intent(OUT), allocatable :: history(:)  ! History of objective function values
    real(dp) :: nelminxy(size(pstart))

    real(dp), parameter :: ccoeff = 0.5_dp
    real(dp), parameter :: ecoeff = 2.0_dp
    real(dp), parameter :: rcoeff = 1.0_dp
    real(dp), parameter :: eps    = 0.001_dp
    real(dp) :: ipstart(size(pstart))
    real(dp) :: ifuncmin
    real(dp) :: ivarmin
    real(dp) :: istep(size(pstart))
    integer(i4) :: ikonvge
    integer(i4) :: imaxeval
    integer(i4) :: ineval
    integer(i4) :: inumrestart
    integer(i4) :: iierror
    integer(i4) :: n, nn
    integer(i4) :: i
    integer(i4) :: ihi
    integer(i4) :: ilo
    integer(i4) :: j
    integer(i4) :: jcount
    integer(i4) :: l
    real(dp) :: del
    real(dp) :: p(size(pstart),size(pstart)+1)
    real(dp) :: p2star(size(pstart))
    real(dp) :: pbar(size(pstart))
    real(dp) :: pstar(size(pstart))
    real(dp) :: rq
    real(dp) :: x
    real(dp) :: y(size(pstart)+1)
    real(dp) :: y2star
    real(dp) :: ylo
    real(dp) :: ystar
    real(dp) :: z
    real(dp) :: dn, dnn
    real(dp) :: p0(size(pstart)), y0
    real(dp), allocatable :: history_tmp(:)
    !
    ! Defaults
    !
    nelminxy(:) = 0.
    if (present(varmin)) then
       if (varmin <= 0.0_dp) stop 'Error nelminxy: varmin<0'
       ivarmin = varmin
    else
       ivarmin = 1.0e-9_dp
    endif
    ! maximal number of function evaluations
    if (present(maxeval)) then
       if (maxeval <= 1) stop 'Error nelminxy: maxeval<=1'
       imaxeval = maxeval
    else
       imaxeval = 1000
    endif
    ! history output
    if (present(history)) then
       ! worst case length
       allocate(history_tmp(imaxeval+3*size(ipstart)+1))
    end if
    if (present(konvge)) then
       ikonvge = konvge
    else
       ikonvge = imaxeval / 10
    endif
    if (ikonvge < 1) stop 'Error nelminxy: konvg<1'
    if (size(xx) /= size(yy)) stop 'Error nelminxy: size(xx) /= size(yy)'
    !
    if (present(step)) then
       istep = step
    else ! if not given, deviate initial by 1%
       y0 = func(pstart, xx, yy)
       do i=1, size(pstart)
          p0 = pstart
          if (ne(p0(i),0.0_dp)) then
             p0(i) = 1.01_dp*p0(i)
          else
             p0(i) = 0.01_dp
          endif
          istep(i) = abs(func(p0, xx, yy) - y0)
       enddo
    endif
    !
    !  Check the input parameters.
    !
    !
    !  Initialization.
    !
    ipstart = pstart
    n       = size(ipstart)
    ineval  = 0_i4
    inumrestart = 0_i4
    jcount = ikonvge
    dn     = real(n, dp)
    nn     = n + 1
    dnn    = real(nn, dp)
    del    = 1.0_dp
    rq     = ivarmin * dn
    !
    !  Initial or restarted loop.
    !
    do
       p(1:n,nn) = ipstart(1:n)
       y(nn)     = func(ipstart, xx, yy)
       ineval     = ineval + 1
       if (present(history)) history_tmp(ineval) = y(nn)
       !
       !  Define the initial simplex.
       !
       do j = 1, n
          x        = ipstart(j)
          ipstart(j) = ipstart(j) + istep(j) * del
          p(1:n,j) = ipstart(1:n)
          y(j)     = func(ipstart, xx, yy)
          ineval    = ineval + 1
          ipstart(j) = x
          if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
       end do
       !
       !  Find highest and lowest Y values.  FUNCMIN = Y(IHI) indicates
       !  the vertex of the simplex to be replaced.
       !
       ilo = minloc(y(1:n+1), 1)
       ylo = y(ilo)
       !
       !  Inner loop.
       !
       do while ( ineval < imaxeval )
          !
          !  FUNCMIN is, of course, the HIGHEST value???
          !
          ihi     = maxloc(y(1:n+1), 1)
          ifuncmin = y(ihi)
          !
          !  Calculate PBAR, the centroid of the simplex vertices
          !  excepting the vertex with Y value FUNCMIN.
          !
          do i = 1, n
             pbar(i) = ( sum(p(i,1:n+1)) - p(i,ihi) ) / dn
          end do
          !
          !  Reflection through the centroid.
          !
          pstar(1:n) = pbar(1:n) + rcoeff * ( pbar(1:n) - p(1:n,ihi) )
          ystar      = func(pstar, xx, yy)
          ineval      = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( ystar,  history_tmp(ineval-1) )
          !
          !  Successful reflection, so extension.
          !
          if ( ystar < ylo ) then

             p2star(1:n) = pbar(1:n) + ecoeff * ( pstar(1:n) - pbar(1:n) )
             y2star      = func(p2star, xx, yy)
             ineval       = ineval + 1
             if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
             !
             !  Retain extension or contraction.
             !
             if ( ystar < y2star ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
             else
                p(1:n,ihi) = p2star(1:n)
                y(ihi)     = y2star
             end if
             !
             !  No extension.
             !
          else
             l = 0
             do i = 1, nn
                if ( ystar < y(i) ) l = l + 1
             end do

             if ( 1 < l ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
                !
                !  Contraction on the Y(IHI) side of the centroid.
                !
             else if ( l == 0 ) then
                p2star(1:n) = pbar(1:n) + ccoeff * ( p(1:n,ihi) - pbar(1:n) )
                y2star      = func(p2star, xx, yy)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Contract the whole simplex.
                !
                if ( y(ihi) < y2star ) then
                   do j = 1, n + 1
                      p(1:n,j)  = ( p(1:n,j) + p(1:n,ilo) ) * 0.5_dp
                      nelminxy(1:n) = p(1:n,j)
                      y(j)      = func(nelminxy, xx, yy)
                      ineval     = ineval + 1
                      if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
                   end do
                   ilo = minloc(y(1:n+1), 1)
                   ylo = y(ilo)

                   cycle
                   !
                   !  Retain contraction.
                   !
                else
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                end if
                !
                !  Contraction on the reflection side of the centroid.
                !
             else if ( l == 1 ) then

                p2star(1:n) = pbar(1:n) + ccoeff * ( pstar(1:n) - pbar(1:n) )
                y2star      = func(p2star, xx, yy)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Retain reflection?
                !
                if ( y2star <= ystar ) then
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                else
                   p(1:n,ihi) = pstar(1:n)
                   y(ihi)     = ystar
                end if

             end if

          end if
          !
          !  Check if YLO improved.
          !
          if ( y(ihi) < ylo ) then
             ylo = y(ihi)
             ilo = ihi
          end if

          jcount = jcount - 1

          if ( 0 < jcount ) cycle
          !
          !  Check to see if minimum reached.
          !
          if ( ineval <= imaxeval ) then
             jcount = ikonvge
             x = sum ( y(1:n+1) ) / dnn
             z = sum ( ( y(1:n+1) - x )**2 )
             if ( z <= rq ) exit
          end if

       end do
       !
       !  Factorial tests to check that FUNCMIN is a local minimum.
       !
       nelminxy(1:n) = p(1:n,ilo)
       ifuncmin   = y(ilo)

       if ( imaxeval < ineval ) then
          iierror = 2
          exit
       end if

       iierror = 0

       do i = 1, n
          del     = istep(i) * eps
          nelminxy(i) = nelminxy(i) + del
          z       = func(nelminxy, xx, yy)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          nelminxy(i) = nelminxy(i) - del - del
          z       = func(nelminxy, xx, yy)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          nelminxy(i) = nelminxy(i) + del
       end do

       if ( iierror == 0 ) exit
       !
       !  Restart the procedure.
       !
       ipstart(1:n) = nelminxy(1:n)
       del          = eps
       inumrestart  = inumrestart + 1

    end do

    if (present(funcmin)) then
       funcmin = ifuncmin
    endif
    if (present(neval)) then
       neval = ineval
    endif
    if (present(numrestart)) then
       numrestart = inumrestart
    endif
    if (present(ierror)) then
       ierror = iierror
    endif
    if (present(history)) then
       allocate(history(ineval))
       history(:) = history_tmp(1:ineval)
    end if

  end function nelminxy

  function nelminrange_dp(func, pstart, prange, varmin, step, konvge, maxeval, &
       funcmin, neval, numrestart, ierror, history)

    implicit none

    INTERFACE
       FUNCTION func(pp)
         USE mo_kind, ONLY: dp
         IMPLICIT NONE
         REAL(dp), DIMENSION(:), INTENT(IN) :: pp
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    real(dp),              intent(IN)  :: pstart(:)
    real(dp),              intent(IN)  :: prange(:,:)
    real(dp),    optional, intent(IN)  :: varmin
    real(dp),    optional, intent(IN)  :: step(:)
    integer(i4), optional, intent(IN)  :: konvge
    integer(i4), optional, intent(IN)  :: maxeval
    real(dp),    optional, intent(OUT) :: funcmin
    integer(i4), optional, intent(OUT) :: neval
    integer(i4), optional, intent(OUT) :: numrestart
    integer(i4), optional, intent(OUT) :: ierror
    real(dp),    optional, intent(OUT), allocatable :: history(:)  ! History of objective function values
    real(dp)                           :: nelminrange_dp(size(pstart))

    real(dp), parameter :: ccoeff = 0.5_dp
    real(dp), parameter :: ecoeff = 2.0_dp
    real(dp), parameter :: rcoeff = 1.0_dp
    real(dp), parameter :: eps    = 0.001_dp
    real(dp) :: ipstart(size(pstart))
    real(dp) :: ifuncmin
    real(dp) :: ivarmin
    real(dp) :: istep(size(pstart))
    integer(i4) :: ikonvge
    integer(i4) :: imaxeval
    integer(i4) :: ineval
    integer(i4) :: inumrestart
    integer(i4) :: iierror
    integer(i4) :: n, nn
    integer(i4) :: i
    integer(i4) :: ihi
    integer(i4) :: ilo
    integer(i4) :: j
    integer(i4) :: jcount
    integer(i4) :: l
    real(dp) :: del
    real(dp) :: p(size(pstart),size(pstart)+1)
    real(dp) :: p2star(size(pstart))
    real(dp) :: pbar(size(pstart))
    real(dp) :: pstar(size(pstart))
    real(dp) :: rq
    real(dp) :: x
    real(dp) :: y(size(pstart)+1)
    real(dp) :: y2star
    real(dp) :: ylo
    real(dp) :: ystar
    real(dp) :: z
    real(dp) :: dn, dnn
    real(dp) :: p0(size(pstart)), y0
    real(dp), allocatable :: history_tmp(:)
    !
    ! Defaults
    !
    nelminrange_dp(:) = 0.5_dp * ( prange(:,1) + prange(:,2) )

    if (present(varmin)) then
       if (varmin <= 0.0_dp) stop 'Error nelmin: varmin<0'
       ivarmin = varmin
    else
       ivarmin = 1.0e-9_dp
    endif
    ! maximal number of function evaluations
    if (present(maxeval)) then
       if (maxeval <= 1) stop 'Error nelmin: maxeval<=1'
       imaxeval = maxeval
    else
       imaxeval = 1000
    endif
    ! history output
    if (present(history)) then
       ! worst case length
       allocate(history_tmp(imaxeval+3*size(ipstart)+1))
    end if
    if (present(konvge)) then
       ikonvge = konvge
    else
       ikonvge = imaxeval / 10
    endif
    if (ikonvge < 1) stop 'Error nelmin: konvg<1'
    !
    if (present(step)) then
       istep = step
    else ! if not given, deviate initial by 1%
       y0 = func(pstart)
       do i=1, size(pstart)
          p0 = pstart
          if (ne(p0(i),0.0_dp)) then
             ! bound to range
             p0(i) = min( prange(i,2) , max( prange(i,1) , 1.01_dp*p0(i) ) )
          else
             ! bound to range
             p0(i) = min( prange(i,2) , max( prange(i,1) , 0.01_dp ) )
          endif
          istep(i) = abs(func(p0) - y0)
       enddo
    endif
    !
    !  Check the input parameters.
    !
    if (size(prange,2) .ne. 2_i4)           stop 'nelminrange_dp: range has to be array of size (:,2)'
    if (size(prange,1) .ne.  size(ipstart)) stop 'nelminrange_dp: range has to be given for each dimension'
    if (.not. (all(prange(:,1) .le. pstart(:)) .and. all(prange(:,2) .ge. pstart(:)) )) then
       stop 'nelminrange_dp: starting point is not in range'
    end if
    !
    !  Initialization.
    !
    ipstart = pstart
    n       = size(ipstart)
    ineval  = 0_i4
    inumrestart = 0_i4
    jcount = ikonvge
    dn     = real(n, dp)
    nn     = n + 1
    dnn    = real(nn, dp)
    del    = 1.0_dp
    rq     = ivarmin * dn
    !
    !  Initial or restarted loop.
    !
    do
       p(1:n,nn) = ipstart(1:n)
       y(nn)     = func(ipstart)
       ineval     = ineval + 1
       if (present(history)) history_tmp(ineval) = y(nn)
       !
       !  Define the initial simplex.
       !
       do j = 1, n
          x          = ipstart(j)
          ! bound to range
          ipstart(j) =  min( prange(j,2) , max( prange(j,1) , ipstart(j) + istep(j) * del ) )
          p(1:n,j)   = ipstart(1:n)
          y(j)       = func(ipstart)
          ineval     = ineval + 1
          ipstart(j) = x
          if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
       end do
       !
       !  Find highest and lowest Y values.  FUNCMIN = Y(IHI) indicates
       !  the vertex of the simplex to be replaced.
       !
       ilo = minloc(y(1:n+1), 1)
       ylo = y(ilo)
       !
       !  Inner loop.
       !
       do while ( ineval < imaxeval )
          !
          !  FUNCMIN is, of course, the HIGHEST value???
          !
          ihi     = maxloc(y(1:n+1), 1)
          ifuncmin = y(ihi)
          !
          !  Calculate PBAR, the centroid of the simplex vertices
          !  excepting the vertex with Y value FUNCMIN.
          !
          do i = 1, n
             pbar(i) = ( sum(p(i,1:n+1)) - p(i,ihi) ) / dn
          end do
          !
          !  Reflection through the centroid.
          !
          ! bound to range
          pstar(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + rcoeff * ( pbar(1:n) - p(1:n,ihi) ) ) )
          ystar      = func(pstar)
          ineval      = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( ystar,  history_tmp(ineval-1) )
          !
          !  Successful reflection, so extension.
          !
          if ( ystar < ylo ) then

             ! bound to range
             p2star(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ecoeff * ( pstar(1:n) - pbar(1:n) ) ) )
             y2star      = func(p2star)
             ineval       = ineval + 1
             if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
             !
             !  Retain extension or contraction.
             !
             if ( ystar < y2star ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
             else
                p(1:n,ihi) = p2star(1:n)
                y(ihi)     = y2star
             end if
             !
             !  No extension.
             !
          else
             l = 0
             do i = 1, nn
                if ( ystar < y(i) ) l = l + 1
             end do

             if ( 1 < l ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
                !
                !  Contraction on the Y(IHI) side of the centroid.
                !
             else if ( l == 0 ) then
                ! bound to range
                p2star(1:n)  = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ccoeff * ( p(1:n,ihi) - pbar(1:n) ) ) )
                y2star       = func(p2star)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Contract the whole simplex.
                !
                if ( y(ihi) < y2star ) then
                   do j = 1, n + 1
                      ! bound to range
                      p(1:n,j)  = min( prange(1:n,2) , max( prange(1:n,1) , ( p(1:n,j) + p(1:n,ilo) ) * 0.5_dp ) )
                      nelminrange_dp(1:n) = p(1:n,j)
                      y(j)      = func(nelminrange_dp)
                      ineval     = ineval + 1
                      if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
                   end do
                   ilo = minloc(y(1:n+1), 1)
                   ylo = y(ilo)

                   cycle
                   !
                   !  Retain contraction.
                   !
                else
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                end if
                !
                !  Contraction on the reflection side of the centroid.
                !
             else if ( l == 1 ) then

                ! bound to range
                p2star(1:n) =  min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ccoeff * ( pstar(1:n) - pbar(1:n) ) ) )
                y2star      = func(p2star)
                ineval      = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Retain reflection?
                !
                if ( y2star <= ystar ) then
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                else
                   p(1:n,ihi) = pstar(1:n)
                   y(ihi)     = ystar
                end if

             end if

          end if
          !
          !  Check if YLO improved.
          !
          if ( y(ihi) < ylo ) then
             ylo = y(ihi)
             ilo = ihi
          end if

          jcount = jcount - 1

          if ( 0 < jcount ) cycle
          !
          !  Check to see if minimum reached.
          !
          if ( ineval <= imaxeval ) then
             jcount = ikonvge
             x = sum ( y(1:n+1) ) / dnn
             z = sum ( ( y(1:n+1) - x )**2 )
             if ( z <= rq ) exit
          end if

       end do
       !
       !  Factorial tests to check that FUNCMIN is a local minimum.
       !
       ! bound to range
       nelminrange_dp(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , p(1:n,ilo) ) )
       ifuncmin   = y(ilo)

       if ( imaxeval < ineval ) then
          iierror = 2
          exit
       end if

       iierror = 0

       do i = 1, n
          del     = istep(i) * eps
          ! bound to range: probably not necessary
          nelminrange_dp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_dp(i) + del ) )
          z       = func(nelminrange_dp)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          ! bound to range: probably not necessary
          nelminrange_dp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_dp(i) - del - del ) )
          z       = func(nelminrange_dp)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          ! bound to range: probably not necessary
          nelminrange_dp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_dp(i) + del ) )
       end do

       if ( iierror == 0 ) exit
       !
       !  Restart the procedure.
       !
       ! bound to range: probably not necessary
       ipstart(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , nelminrange_dp(1:n) ) )
       del          = eps
       inumrestart  = inumrestart + 1

    end do

    if (present(funcmin)) then
       funcmin = ifuncmin
    endif
    if (present(neval)) then
       neval = ineval
    endif
    if (present(numrestart)) then
       numrestart = inumrestart
    endif
    if (present(ierror)) then
       ierror = iierror
    endif
    if (present(history)) then
       allocate(history(ineval))
       history(:) = history_tmp(1:ineval)
    end if

  end function nelminrange_dp

  function nelminrange_sp(func, pstart, prange, varmin, step, konvge, maxeval, &
       funcmin, neval, numrestart, ierror, history)

    implicit none

    INTERFACE
       FUNCTION func(pp)
         USE mo_kind, ONLY: sp
         IMPLICIT NONE
         REAL(sp), DIMENSION(:), INTENT(IN) :: pp
         REAL(sp) :: func
       END FUNCTION func
    END INTERFACE
    real(sp),              intent(IN)  :: pstart(:)
    real(sp),              intent(IN)  :: prange(:,:)
    real(sp),    optional, intent(IN)  :: varmin
    real(sp),    optional, intent(IN)  :: step(:)
    integer(i4), optional, intent(IN)  :: konvge
    integer(i4), optional, intent(IN)  :: maxeval
    real(sp),    optional, intent(OUT) :: funcmin
    integer(i4), optional, intent(OUT) :: neval
    integer(i4), optional, intent(OUT) :: numrestart
    integer(i4), optional, intent(OUT) :: ierror
    real(sp),    optional, intent(OUT), allocatable :: history(:)  ! History of objective function values
    real(sp)                           :: nelminrange_sp(size(pstart))

    real(sp), parameter :: ccoeff = 0.5_sp
    real(sp), parameter :: ecoeff = 2.0_sp
    real(sp), parameter :: rcoeff = 1.0_sp
    real(sp), parameter :: eps    = 0.001_sp
    real(sp) :: ipstart(size(pstart))
    real(sp) :: ifuncmin
    real(sp) :: ivarmin
    real(sp) :: istep(size(pstart))
    integer(i4) :: ikonvge
    integer(i4) :: imaxeval
    integer(i4) :: ineval
    integer(i4) :: inumrestart
    integer(i4) :: iierror
    integer(i4) :: n, nn
    integer(i4) :: i
    integer(i4) :: ihi
    integer(i4) :: ilo
    integer(i4) :: j
    integer(i4) :: jcount
    integer(i4) :: l
    real(sp) :: del
    real(sp) :: p(size(pstart),size(pstart)+1)
    real(sp) :: p2star(size(pstart))
    real(sp) :: pbar(size(pstart))
    real(sp) :: pstar(size(pstart))
    real(sp) :: rq
    real(sp) :: x
    real(sp) :: y(size(pstart)+1)
    real(sp) :: y2star
    real(sp) :: ylo
    real(sp) :: ystar
    real(sp) :: z
    real(sp) :: dn, dnn
    real(sp) :: p0(size(pstart)), y0
    real(sp), allocatable :: history_tmp(:)
    !
    ! Defaults
    !
    nelminrange_sp(:) = 0.5_sp * ( prange(:,1) + prange(:,2) )

    if (present(varmin)) then
       if (varmin <= 0.0_sp) stop 'Error nelmin: varmin<0'
       ivarmin = varmin
    else
       ivarmin = 1.0e-9_sp
    endif
    ! maximal number of function evaluations
    if (present(maxeval)) then
       if (maxeval <= 1) stop 'Error nelmin: maxeval<=1'
       imaxeval = maxeval
    else
       imaxeval = 1000
    endif
    ! history output
    if (present(history)) then
       ! worst case length
       allocate(history_tmp(imaxeval+3*size(ipstart)+1))
    end if
    if (present(konvge)) then
       ikonvge = konvge
    else
       ikonvge = imaxeval / 10
    endif
    if (ikonvge < 1) stop 'Error nelmin: konvg<1'
    !
    if (present(step)) then
       istep = step
    else ! if not given, deviate initial by 1%
       y0 = func(pstart)
       do i=1, size(pstart)
          p0 = pstart
          if (ne(p0(i),0.0_sp)) then
             ! bound to range
             p0(i) = min( prange(i,2) , max( prange(i,1) , 1.01_sp*p0(i) ) )
          else
             ! bound to range
             p0(i) = min( prange(i,2) , max( prange(i,1) , 0.01_sp ) )
          endif
          istep(i) = abs(func(p0) - y0)
       enddo
    endif
    !
    !  Check the input parameters.
    !
    if (size(prange,2) .ne. 2_i4)           stop 'nelminrange_sp: range has to be array of size (:,2)'
    if (size(prange,1) .ne.  size(ipstart)) stop 'nelminrange_sp: range has to be given for each dimension'
    if (.not. (all(prange(:,1) .le. pstart(:)) .and. all(prange(:,2) .ge. pstart(:)) )) then
       stop 'nelminrange_sp: starting point is not in range'
    end if
    !
    !  Initialization.
    !
    ipstart = pstart
    n       = size(ipstart)
    ineval  = 0_i4
    inumrestart = 0_i4
    jcount = ikonvge
    dn     = real(n, sp)
    nn     = n + 1
    dnn    = real(nn, sp)
    del    = 1.0_sp
    rq     = ivarmin * dn
    !
    !  Initial or restarted loop.
    !
    do
       p(1:n,nn) = ipstart(1:n)
       y(nn)     = func(ipstart)
       ineval     = ineval + 1
       if (present(history)) history_tmp(ineval) = y(nn)
       !
       !  Define the initial simplex.
       !
       do j = 1, n
          x          = ipstart(j)
          ! bound to range
          ipstart(j) =  min( prange(j,2) , max( prange(j,1) , ipstart(j) + istep(j) * del ) )
          p(1:n,j)   = ipstart(1:n)
          y(j)       = func(ipstart)
          ineval     = ineval + 1
          ipstart(j) = x
          if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
       end do
       !
       !  Find highest and lowest Y values.  FUNCMIN = Y(IHI) indicates
       !  the vertex of the simplex to be replaced.
       !
       ilo = minloc(y(1:n+1), 1)
       ylo = y(ilo)
       !
       !  Inner loop.
       !
       do while ( ineval < imaxeval )
          !
          !  FUNCMIN is, of course, the HIGHEST value???
          !
          ihi     = maxloc(y(1:n+1), 1)
          ifuncmin = y(ihi)
          !
          !  Calculate PBAR, the centroid of the simplex vertices
          !  excepting the vertex with Y value FUNCMIN.
          !
          do i = 1, n
             pbar(i) = ( sum(p(i,1:n+1)) - p(i,ihi) ) / dn
          end do
          !
          !  Reflection through the centroid.
          !
          ! bound to range
          pstar(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + rcoeff * ( pbar(1:n) - p(1:n,ihi) ) ) )
          ystar      = func(pstar)
          ineval      = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( ystar,  history_tmp(ineval-1) )
          !
          !  Successful reflection, so extension.
          !
          if ( ystar < ylo ) then

             ! bound to range
             p2star(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ecoeff * ( pstar(1:n) - pbar(1:n) ) ) )
             y2star      = func(p2star)
             ineval       = ineval + 1
             if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
             !
             !  Retain extension or contraction.
             !
             if ( ystar < y2star ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
             else
                p(1:n,ihi) = p2star(1:n)
                y(ihi)     = y2star
             end if
             !
             !  No extension.
             !
          else
             l = 0
             do i = 1, nn
                if ( ystar < y(i) ) l = l + 1
             end do

             if ( 1 < l ) then
                p(1:n,ihi) = pstar(1:n)
                y(ihi)     = ystar
                !
                !  Contraction on the Y(IHI) side of the centroid.
                !
             else if ( l == 0 ) then
                ! bound to range
                p2star(1:n)  = min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ccoeff * ( p(1:n,ihi) - pbar(1:n) ) ) )
                y2star       = func(p2star)
                ineval       = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Contract the whole simplex.
                !
                if ( y(ihi) < y2star ) then
                   do j = 1, n + 1
                      ! bound to range
                      p(1:n,j)  = min( prange(1:n,2) , max( prange(1:n,1) , ( p(1:n,j) + p(1:n,ilo) ) * 0.5_sp ) )
                      nelminrange_sp(1:n) = p(1:n,j)
                      y(j)      = func(nelminrange_sp)
                      ineval     = ineval + 1
                      if (present(history)) history_tmp(ineval) = Min( y(j),  history_tmp(ineval-1) )
                   end do
                   ilo = minloc(y(1:n+1), 1)
                   ylo = y(ilo)

                   cycle
                   !
                   !  Retain contraction.
                   !
                else
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                end if
                !
                !  Contraction on the reflection side of the centroid.
                !
             else if ( l == 1 ) then

                ! bound to range
                p2star(1:n) =  min( prange(1:n,2) , max( prange(1:n,1) , pbar(1:n) + ccoeff * ( pstar(1:n) - pbar(1:n) ) ) )
                y2star      = func(p2star)
                ineval      = ineval + 1
                if (present(history)) history_tmp(ineval) = Min( y2star,  history_tmp(ineval-1) )
                !
                !  Retain reflection?
                !
                if ( y2star <= ystar ) then
                   p(1:n,ihi) = p2star(1:n)
                   y(ihi)     = y2star
                else
                   p(1:n,ihi) = pstar(1:n)
                   y(ihi)     = ystar
                end if

             end if

          end if
          !
          !  Check if YLO improved.
          !
          if ( y(ihi) < ylo ) then
             ylo = y(ihi)
             ilo = ihi
          end if

          jcount = jcount - 1

          if ( 0 < jcount ) cycle
          !
          !  Check to see if minimum reached.
          !
          if ( ineval <= imaxeval ) then
             jcount = ikonvge
             x = sum ( y(1:n+1) ) / dnn
             z = sum ( ( y(1:n+1) - x )**2 )
             if ( z <= rq ) exit
          end if

       end do
       !
       !  Factorial tests to check that FUNCMIN is a local minimum.
       !
       ! bound to range
       nelminrange_sp(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , p(1:n,ilo) ) )
       ifuncmin   = y(ilo)

       if ( imaxeval < ineval ) then
          iierror = 2
          exit
       end if

       iierror = 0

       do i = 1, n
          del     = istep(i) * eps
          ! bound to range: probably not necessary
          nelminrange_sp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_sp(i) + del ) )
          z       = func(nelminrange_sp)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          ! bound to range: probably not necessary
          nelminrange_sp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_sp(i) - del - del ) )
          z       = func(nelminrange_sp)
          ineval  = ineval + 1
          if (present(history)) history_tmp(ineval) = Min( z,  history_tmp(ineval-1) )
          if ( z < ifuncmin ) then
             iierror = 2
             exit
          end if
          ! bound to range: probably not necessary
          nelminrange_sp(i) = min( prange(i,2) , max( prange(i,1) , nelminrange_sp(i) + del ) )
       end do

       if ( iierror == 0 ) exit
       !
       !  Restart the procedure.
       !
       ! bound to range: probably not necessary
       ipstart(1:n) = min( prange(1:n,2) , max( prange(1:n,1) , nelminrange_sp(1:n) ) )
       del          = eps
       inumrestart  = inumrestart + 1

    end do

    if (present(funcmin)) then
       funcmin = ifuncmin
    endif
    if (present(neval)) then
       neval = ineval
    endif
    if (present(numrestart)) then
       numrestart = inumrestart
    endif
    if (present(ierror)) then
       ierror = iierror
    endif
    if (present(history)) then
       allocate(history(ineval))
       history(:) = history_tmp(1:ineval)
    end if

  end function nelminrange_sp

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

END MODULE mo_nelmin


SUBROUTINE clawpack5_rpn2adv_manifold(ixy,maxm,meqn, &
     mwaves,maux,mbc, mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
  IMPLICIT NONE

  INTEGER ixy,maxm,meqn,mwaves,maux,mbc,mx
  DOUBLE PRECISION wave(meqn, mwaves, 1-mbc:maxm+mbc)
  DOUBLE PRECISION    s(mwaves, 1-mbc:maxm+mbc)
  DOUBLE PRECISION   ql(meqn, 1-mbc:maxm+mbc)
  DOUBLE PRECISION   qr(meqn, 1-mbc:maxm+mbc)
  DOUBLE PRECISION apdq(meqn,1-mbc:maxm+mbc)
  DOUBLE PRECISION amdq(meqn,1-mbc:maxm+mbc)
  DOUBLE PRECISION auxl(maux,1-mbc:maxm+mbc)
  DOUBLE PRECISION auxr(maux,1-mbc:maxm+mbc)

  INTEGER iface, i, m

  IF (mwaves .NE. 1) THEN
     WRITE(6,*) 'clawpack5_rpn2 : mwaves should be equal to 1'
     STOP
  ENDIF

  iface = ixy
  DO i = 2-mbc, mx+mbc
     DO m = 1,meqn
        wave(m,1,i) = ql(m,i) - qr(m,i-1)
     ENDDO

     !! # Only one wave
     s(1,i) = auxl(iface+1,i)

     DO m = 1,meqn
        amdq(m,i) = MIN(s(1,i), 0.d0) * wave(m,1,i)
        apdq(m,i) = MAX(s(1,i), 0.d0) * wave(m,1,i)
     ENDDO
  END DO

  RETURN
END SUBROUTINE clawpack5_rpn2adv_manifold


!! fpm test test
program main
    use forlab
    implicit none
    real(RPRE) :: x(2, 2)

    x = 0.0
    x(1, 1) = 1.0
    x(1, 2) = 2.0
    x(2, 1) = 3.0
    x(2, 2) = 4.0

    call disp(x, 'x matrix:')

end program