      subroutine MAKE_HPF

      include 'SIZE'
      include 'SOLN'
      include 'INPUT'         ! param(110),(111)
      include 'TSTEP'         ! ifield
      include 'MASS'          ! BM1

      integer nxyz
      parameter (nxyz=lx1*ly1*lz1)
      integer n

      integer lm,lm2
      parameter (lm=40)
      parameter (lm2=lm*lm)
      real hpf_filter(lm2)

      integer hpf_kut
      real hpf_chi
      logical hpf_ifboyd

      integer nel

      integer icalld
      save icalld
      data icalld /0/

      real TA1,TA2,TA3
      COMMON /SCRUZ/ TA1 (LX1,LY1,LZ1,LELV)
     $ ,             TA2 (LX1,LY1,LZ1,LELV)
     $ ,             TA3 (LX1,LY1,LZ1,LELV)

      real hpf_op(lx1,lx1)
      save hpf_op

c----------------------------------------
      if(.not. iffilter(ifield)) return

      hpf_kut = int(param(101))+1
      hpf_chi = -1.0*abs(param(103))
c     Boyd transform to preserve element boundary values is
c     linearly unstable when used as forcing.
      hpf_ifboyd = .false.

      nel = nelv
      n = nxyz*nel

      if (hpf_chi.eq.0) return
      if(nid.eq.0 .and. loglevel.gt.2) write(6,*) 'apply hpf ',
     $                                 ifield, hpf_kut, hpf_chi

      if (icalld.eq.0) then
c       Create the filter transfer function
        call hpf_trns_fcn(hpf_filter,hpf_kut)

c       Build the matrix to apply the filter function
c       to an input field
        call build_hpf_mat(hpf_op,hpf_filter,hpf_ifboyd)

c       Only initialize once
        icalld=icalld+1
      endif

      if (ifield.eq.1) then
c       Apply the filter
c       to velocity fields
        if (jp.eq.0) then
          call build_hpf_fld(ta1,vx,hpf_op,lx1,lz1)
          call build_hpf_fld(ta2,vy,hpf_op,lx1,lz1)
          if (if3d) call build_hpf_fld(ta3,vz,hpf_op,lx1,lz1)

c         Multiply by filter weight (chi)
          call cmult(ta1,hpf_chi,n)
          call cmult(ta2,hpf_chi,n)
          if (if3d) call cmult(ta3,hpf_chi,n)

c         Multiply by Mass matrix
c         and add to forcing term
          call opadd2col (bfx,bfy,bfz,ta1,ta2,ta3,bm1)
        else
c         Apply filter on velocity perturbation fields
          call build_hpf_fld(ta1,vxp(1,jp),hpf_op,lx1,lz1)
          call build_hpf_fld(ta2,vyp(1,jp),hpf_op,lx1,lz1)
          if (if3d) call build_hpf_fld(ta3,vzp(1,jp),hpf_op,lx1,lz1)

c         Multiply by filter weight (chi)
          call cmult(ta1,hpf_chi,n)
          call cmult(ta2,hpf_chi,n)
          if (if3d) call cmult(ta3,hpf_chi,n)

c         Multiply by Mass matrix
c         and add to forcing term
          call opadd2col (bfxp(1,jp),bfyp(1,jp),bfzp(1,jp),
     $                    ta1,ta2,ta3,bm1)
        endif

      else

c       Apply filter to temp/passive scalar fields
        if (jp.eq.0) then
          call build_hpf_fld(ta1,t(1,1,1,1,ifield-1),
     $         hpf_op,lx1,lz1)

c         Multiply by filter weight (chi)
          call cmult(ta1,hpf_chi,n)

c         Multiply by Mass matrix
c         and add to source term
          call addcol3(bq(1,1,1,1,ifield-1),ta1,bm1,n)
        else
c         Apply filter on scalar perturbation field
          call build_hpf_fld(ta1,tp(1,ifield-1,jp),hpf_op,lx1,lz1)

c         Multiply by filter weight (chi)
          call cmult(ta1,hpf_chi,n)

c         Multiply by Mass matrix
c         and add to source term
          call addcol3(bqp(1,ifield-1,jp),ta1,bm1,n)
        endif

      endif

      return
      end

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

      subroutine build_hpf_mat(op_mat,f_filter,ifboyd)

c     Builds the operator for high pass filtering
c     Transformation matrix from nodal to modal space.
c     Applies f_filter to the the legendre coefficients
c     Transforms back to nodal space
c     Operation: V * f_filter * V^(-1)
c     Where V is the transformation matrix from modal to nodal space

c      implicit none

      include 'SIZE'

      logical IFBOYD
      integer n
      parameter (n=lx1*lx1)
      integer lm, lm2
      parameter (lm=40)
      parameter (lm2=lm*lm)

      real f_filter(lm2)
      real op_mat(lx1,lx1)

      real ref_xmap(lm2)
      real wk_xmap(lm2)

      real wk1(lm2),wk2(lm2)
      real indr(lm),ipiv(lm),indc(lm)

      real rmult(lm)
      integer ierr

      integer i,j

      call spec_coeff_init(ref_xmap,ifboyd)

      call copy(wk_xmap,ref_xmap,lm2)
      call copy(wk1,wk_XMAP,lm2)

      call gaujordf  (wk1,lx1,lx1,indr,indc,ipiv,ierr,rmult)  ! xmap inverse

      call mxm  (f_filter,lx1,wk1,lx1,wk2,lx1)        !          -1
      call mxm  (wk_xmap,lx1,wk2,lx1,op_mat,lx1)      !     V D V

      return
      end

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

      subroutine build_hpf_fld(v,u,f,nx,nz)

c     Appies the operator f to field u
c     using tensor operations
c     v = f*u

c      implicit none

      include 'SIZE'
      include 'TSTEP'         ! ifield

      integer nxyz
      parameter (nxyz=lx1*ly1*lz1)

      real w1(nxyz),w2(nxyz)              ! work arrays
      real v(nxyz,lelv)                   ! output fld
      real u(nxyz,lelv)                   ! input fld
c
      integer nx,nz

      real f(nx,nx),ft(nx,nx)             ! operator f and its transpose
c
      integer e,i,j,k
      integer nel

      nel = nelv

      call copy(v,u,nxyz*nel)
c
      call transpose(ft,nx,f,nx)
c
      if (ldim.eq.3) then
        do e=1,nel
c         Filter
          call copy(w2,v(1,e),nxyz)
          call mxm(f,nx,w2,nx,w1,nx*nx)
          i=1
          j=1
          do k=1,nx
             call mxm(w1(i),nx,ft,nx,w2(j),nx)
             i = i+nx*nx
             j = j+nx*nx
          enddo
          call mxm (w2,nx*nx,ft,nx,w1,nx)

          call sub3(w2,u(1,e),w1,nxyz)
          call copy(v(1,e),w2,nxyz)
c          call copy(v(1,e),w1,nxyz)

        enddo
      else
        do e=1,nel
c         Filter
          call copy(w1,v(1,e),nxyz)
          call mxm(f ,nx,w1,nx,w2,nx)
          call mxm(w2,nx,ft,nx,w1,nx)

          call sub3(w2,u(1,e),w1,nxyz)
          call copy(v(1,e),w2,nxyz)
c          call copy(v(1,e),w1,nxyz)
        enddo
      endif
c
      return
      end

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

      subroutine hpf_trns_fcn(diag,kut)

c      implicit none

      include 'SIZE'
      include 'PARALLEL'

      real diag(lx1*lx1)
      integer nx,k0,kut,kk,k

      real amp

c     Set up transfer function
c
      nx = lx1
      call ident   (diag,nx)
c
      kut=kut                                     ! kut=additional modes
      k0 = nx-kut
      do k=k0+1,nx
        kk = k+nx*(k-1)
        amp = ((k-k0)*(k-k0)+0.)/(kut*kut+0.)     ! Normalized amplitude. quadratic growth
        diag(kk) = 1.-amp
      enddo

c     Output normalized transfer function
      k0 = lx1+1
      if (nio.eq.0) then
        write(6,6) 'HPF :',((1.-diag(k)), k=1,lx1*lx1,k0)
   6    format(a8,16f9.6,6(/,8x,16f9.6))
      endif

      return
      end

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

      subroutine spec_coeff_init(ref_xmap,ifboyd)
c     Initialise spectral coefficients
c     For legendre transform

c      implicit none

      include 'SIZE'
      include 'WZ'

      integer lm, lm2
      parameter (lm=40)
      parameter (lm2=lm*lm)

c     local variables
      integer i, j, k, n, nx, kj
c     Legendre polynomial
      real plegx(lm)
      real z
      real ref_xmap(lm2)
      real pht(lm2)

c     Change of basis
      logical IFBOYD
c----------------------------------------

      nx = LX1
      kj = 0
      n  = nx-1
      do j=1,nx
        z = ZGM1(j,1)
        call legendre_poly(plegx,z,n)
        kj = kj+1
        pht(kj) = plegx(1)
        kj = kj+1
        pht(kj) = plegx(2)

        if (IFBOYD) then        ! change basis to preserve element boundary values
          do k=3,nx
             kj = kj+1
             pht(kj) = plegx(k)-plegx(k-2)
          enddo
        else                    ! legendre basis
          do k=3,nx
             kj = kj+1
             pht(kj) = plegx(k)
          enddo
        endif
      enddo

      call transpose (ref_xmap,nx,pht,nx)

      return
      end


!> \file mo_select_distant_entries.f90

!> \brief Selects elements of distance matrix with most largest distance to each other

!> \details Selects from a distance matrix (symmetric and positive) a specified
!>          number (N) of elements which have large distances to each other.

!> \authors Juliane Mai
!> \date November 2014

module mo_select_distant_entries

  ! Written November 2014, Juliane Mai

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2014 Juliane Mai
  !
  ! 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_orderpack,    only: sort
  use mo_xor4096,      only: get_timeseed, n_save_state, xor4096
  use mo_xor4096_apps, only: xor4096_range

  implicit none

  public :: select_distant_entries   ! selects elements of distance matrix with most largest distance to each other

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

  !     NAME
  !         select_distant_entries

  !     PURPOSE
  !         Selects from a distance matrix (symmetric and positive) a specified
  !         number (N) of elements which have large distances to each other.
  !
  !         Indexes are chosen iteratively. Therefore, it might be possible to
  !         find selections which have an overall larger distance. This is only
  !         a good GUESS of such a selection.
  !
  !         There are two ways implemented how the first pair is chosen.
  !         (1) Default
  !             The first pair is the one with the overall largest distance,
  !             i.e. largest entry in distance matrix
  !             Therfore, the selection is deterministic.
  !         (2) The first pair is randomly chosen.
  !             Therefore, the returened selection is random.

  !     CALLING SEQUENCE
  !         indexes = select_distant_entries( distance_matrix, N, first=0 )

  !     INTENT(IN)
  !         real(sp/dp) :: distance_matrix   2D array of distances between element i and j
  !         integer(i4) :: n_elements        number of elements to return

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         integer(i4) :: first             method how first pair is chosen
  !                                          0 : first pair is the one with the overall
  !                                              largest distance,
  !                                              i.e. result is deterministic
  !                                          1 : first pair is randomly chosen,
  !                                              i.e. result is random
  !                                          DEFAULT: 0
  !         integer(i4) :: seed              seed used for random number generator
  !                                          (only considered if first=1)
  !                                          DEFAULT: timeseed

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !         integer(i4) :: select_distant_entries(n_elements)   indexes of elements with largest distance to each other

  !     RESTRICTIONS
  !         There is no initial mask of distance matrix allowed.

  !     EXAMPLE
  !         -> see also example in test directory
  !
  !     LITERATURE
  !         None
  !
  !     HISTORY
  !         Written,  Juliane Mai, Nov 2014

  interface select_distant_entries
     module procedure select_distant_entries_dp, select_distant_entries_sp
  end interface select_distant_entries

  private

contains

  function select_distant_entries_dp( distance_matrix, n_elements, first, seed )

    implicit none

    real(dp), dimension(:,:), intent(in) :: distance_matrix           ! square matrix with distance between element i and j
    integer(i4),              intent(in) :: n_elements                ! number of elements to return
    integer(i4),    optional, intent(in) :: first                     ! method how first pair is chosen
    !                                                                 !    0 : first pair is the one with the overall
    !                                                                 !        largest distance,
    !                                                                 !        i.e. result is deterministic
    !                                                                 !    1 : first pair is randomly chosen,
    !                                                                 !        i.e. result is random
    !                                                                 ! DEFAULT: 0
    integer(i4),    optional, intent(in) :: seed                      ! seed used for random number generator
    !                                                                 ! (only considered if first=1)
    !                                                                 ! DEFAULT: timeseed
    integer(i4), dimension(n_elements)   :: select_distant_entries_dp ! indexes of elements with largest distance to each other

    ! local variables
    integer(i4)                             :: ii, jj, kk
    integer(i4)                             :: ifirst      ! method how first pair is chosen
    integer(i4)                             :: iseed       ! seed for random number generator
    integer(i4), dimension(n_save_state)    :: save_state
    integer(i4)                             :: n_total     ! number of elements --> number of rows/cols of distance_matrix
    integer(i4)                             :: maxpos(2)
    logical,    dimension(:,:), allocatable :: mask

    ! handling of optionals
    if ( present(first) ) then
       ifirst = first
    else
       ifirst = 0
    end if

    ! handling of optionals
    if ( present(seed) ) then
       iseed = seed
    else
       call get_timeseed(iseed)
    end if

    n_total = size(distance_matrix,1)

    ! initialization
    select_distant_entries_dp(:) = 0

    if (ifirst .eq. 0) then
       ! first pair is the one with overall maximal distance
       maxpos  = maxloc(distance_matrix)
       select_distant_entries_dp(1) = maxpos(1)
       select_distant_entries_dp(2) = maxpos(2)
    else
       ! first pair is chosen randomly
       ! (a) initialize random stream
       call xor4096(iseed, maxpos(1), save_state=save_state)
       iseed = 0
       ! (b) generate first index
       call xor4096_range((/1_i4, n_total/), maxpos(1), save_state=save_state)
       ! (c) generate second index
       call xor4096_range((/1_i4, n_total/), maxpos(2), save_state=save_state)
       do while (maxpos(1) .eq. maxpos(2))
          call xor4096_range((/1_i4, n_total/), maxpos(2), save_state=save_state)
       end do
       select_distant_entries_dp(1) = maxpos(1)
       select_distant_entries_dp(2) = maxpos(2)
    end if

    do ii = 3, n_elements
       allocate( mask(n_total,n_total) )
       mask = .false.
       ! select rows and columns
       do jj = 1, ii-1
          ! select row
          mask(select_distant_entries_dp(jj),:) = .true.
          ! select column
          mask(:,select_distant_entries_dp(jj)) = .true.
          ! de-select diagonal elements and already chosen pairs
          do kk = 1, jj
             mask(select_distant_entries_dp(jj),select_distant_entries_dp(kk)) = .false.
             mask(select_distant_entries_dp(kk),select_distant_entries_dp(jj)) = .false.
          end do
       end do
       ! find largest distance of selected entries
       maxpos  = maxloc(distance_matrix, mask=mask)
       ! either row or column index is already part of the list
       ! --> add the other one
       if ( count(select_distant_entries_dp .eq. maxpos(1)) .eq. 0 ) then
          select_distant_entries_dp(ii) = maxpos(1)
       else
          select_distant_entries_dp(ii) = maxpos(2)
       end if
       deallocate( mask )
    end do

    call sort(select_distant_entries_dp)

  end function select_distant_entries_dp

  function select_distant_entries_sp( distance_matrix, n_elements, first, seed )

    implicit none

    real(sp), dimension(:,:), intent(in) :: distance_matrix           ! square matrix with distance between element i and j
    integer(i4),              intent(in) :: n_elements                ! number of elements to return
    integer(i4),    optional, intent(in) :: first                     ! method how first pair is chosen
    !                                                                 !    0 : first pair is the one with the overall
    !                                                                 !        largest distance,
    !                                                                 !        i.e. result is deterministic
    !                                                                 !    1 : first pair is randomly chosen,
    !                                                                 !        i.e. result is random
    !                                                                 ! DEFAULT: 0
    integer(i4),    optional, intent(in) :: seed                      ! seed used for random number generator
    !                                                                 ! (only considered if first=1)
    !                                                                 ! DEFAULT: timeseed
    integer(i4), dimension(n_elements)   :: select_distant_entries_sp ! indexes of elements with largest distance to each other

    ! local variables
    integer(i4)                             :: ii, jj, kk
    integer(i4)                             :: ifirst      ! method how first pair is chosen
    integer(i4)                             :: iseed       ! seed for random number generator
    integer(i4), dimension(n_save_state)    :: save_state
    integer(i4)                             :: n_total     ! number of elements --> number of rows/cols of distance_matrix
    integer(i4)                             :: maxpos(2)
    logical,    dimension(:,:), allocatable :: mask

    ! handling of optionals
    if ( present(first) ) then
       ifirst = first
    else
       ifirst = 0
    end if

    ! handling of optionals
    if ( present(seed) ) then
       iseed = seed
    else
       call get_timeseed(iseed)
    end if

    n_total = size(distance_matrix,1)

    ! initialization
    select_distant_entries_sp(:) = 0

    if (ifirst .eq. 0) then
       ! first pair is the one with overall maximal distance
       maxpos  = maxloc(distance_matrix)
       select_distant_entries_sp(1) = maxpos(1)
       select_distant_entries_sp(2) = maxpos(2)
    else
       ! first pair is chosen randomly
       ! (a) initialize random stream
       call xor4096(iseed, maxpos(1), save_state=save_state)
       iseed = 0
       ! (b) generate first index
       call xor4096_range((/1_i4, n_total/), maxpos(1), save_state=save_state)
       ! (c) generate second index
       call xor4096_range((/1_i4, n_total/), maxpos(2), save_state=save_state)
       do while (maxpos(1) .eq. maxpos(2))
          call xor4096_range((/1_i4, n_total/), maxpos(2), save_state=save_state)
       end do
       select_distant_entries_sp(1) = maxpos(1)
       select_distant_entries_sp(2) = maxpos(2)
    end if

    do ii = 3, n_elements
       allocate( mask(n_total,n_total) )
       mask = .false.
       ! select rows and columns
       do jj = 1, ii-1
          ! select row
          mask(select_distant_entries_sp(jj),:) = .true.
          ! select column
          mask(:,select_distant_entries_sp(jj)) = .true.
          ! de-select diagonal elements and already chosen pairs
          do kk = 1, jj
             mask(select_distant_entries_sp(jj),select_distant_entries_sp(kk)) = .false.
             mask(select_distant_entries_sp(kk),select_distant_entries_sp(jj)) = .false.
          end do
       end do
       ! find largest distance of selected entries
       maxpos  = maxloc(distance_matrix, mask=mask)
       ! either row or column index is already part of the list
       ! --> add the other one
       if ( count(select_distant_entries_sp .eq. maxpos(1)) .eq. 0 ) then
          select_distant_entries_sp(ii) = maxpos(1)
       else
          select_distant_entries_sp(ii) = maxpos(2)
       end if
       deallocate( mask )
    end do

    call sort(select_distant_entries_sp)

  end function select_distant_entries_sp

end module mo_select_distant_entries


!
! 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
!

program testieee19flushz
use ieee_arithmetic
real*8 a, ral, rone
real*8 aa1(1040), aa2(1040)
logical ll1(1040), ll2(1040), le1(1040)
logical luflow
logical lfsav(5), lfset(5)

lfset = .false.
call ieee_get_halting_mode(ieee_all, lfsav)
call ieee_set_halting_mode(ieee_all, lfset)

call ieee_get_underflow_mode(luflow)
call ieee_set_underflow_mode(.false.)

rone = 1.0d0
rlogb = 0.0d0
a = rone
do j = 1, 1040
  ral = ieee_logb(a)
  aa1(j) = ral
  if (j .le. 1023) then
    aa2(j) = rlogb
  else
    aa2(j) = ieee_value(rlogb, ieee_negative_inf)
  end if
  i = int(ieee_rint(ral))
  a = a * 0.5d0
  rlogb = rlogb - 1.0d0
end do

do j = 1, 1040
  ll1(j) = aa1(j) .eq. aa2(j)
end do

le1 = .true.

call check(ll1, le1, 1040)

call ieee_set_underflow_mode(luflow)
call ieee_set_halting_mode(ieee_all, lfsav)
end


PROGRAM TESTMODELPARSER

  ! TEST INPUTTING THE MODEL FROM FILE USING MODEL_MANAGER MODULE

  USE MODELMODULE
  IMPLICIT NONE

  TYPE (CME_MODEL) :: MODEL, MODEL2

  INTEGER :: I, J, R
  DOUBLE PRECISION :: P1, P2, ERROR

  CALL MODEL%LOAD('MODELS/TOGGLE_TEST_MODEL.INPUT')

  CALL MODEL%RESET_PARAMETERS((/5000.0D0, 1600.D0, 1.0D0, 1.0D0/))

  WRITE (*,*) 'MODEL LOADED.'
  WRITE (*,*) 'NUMBER OF SPECIES: ',MODEL%NSPECIES
  WRITE (*,*) 'SPECIES NAMES: ', MODEL%SPECIES_NAMES
  WRITE (*,*) 'NUMBER OF PARAMETERS:', MODEL%NPARAMETERS
  WRITE (*,*) 'PARAMETER VALUES:', MODEL%PARAMETER_VAL
  WRITE (*,*) 'STOICHIOMETRY:'
  DO I = 1,MODEL%NSPECIES
     DO J = 1, MODEL%NREACTIONS
        WRITE (*,FMT = '(I2 4X)',ADVANCE='NO') MODEL%STOICHIOMETRY(I,J)
     ENDDO
     WRITE (*,*) ''
  END DO

  ERROR = 0.0D0
  ! NOW TEST THE ACCURACY OF THE READ-FROM-FILE PROPENSITIES
  DO I = 1, 50
     DO J = 1,50
        DO R = 1, MODEL%NREACTIONS
           P1 = PROP((/ I, J /), R, (/0D0 , 0D0/))
           P2 = MODEL%PROPENSITY((/I, J/), R)
           ERROR = ERROR + ABS(P1-P2)
           WRITE (*, 201) I, J, R, P1, P2, ABS(P1-P2)
201        FORMAT (1X, 'IE=', I4,2X, 'J=', I4, 2X, 'R=',I4,2X, 'P1=', E9.2, 2X, 'P2=', E9.2, 2X, '|P2-P1|=',E9.2)
        ENDDO
     ENDDO
  ENDDO

  PRINT*,'PROPENSITY TESTING COMPLETED FOR MODEL 1. ACCUMULATED ERROR = ',ERROR

  CALL MODEL2%LOAD('MODELS/TOGGLE_TEST_MODEL.INPUT')
  CALL MODEL2%RESET_PARAMETERS((/5000.0D0, 1600.D0, 1.0D0, 1.0D0/))

  WRITE (*,*) 'MODEL LOADED.'
  WRITE (*,*) 'NUMBER OF SPECIES: ',MODEL2%NSPECIES
  WRITE (*,*) 'SPECIES NAMES: ', MODEL2%SPECIES_NAMES
  WRITE (*,*) 'NUMBER OF PARAMETERS:', MODEL2%NPARAMETERS
  WRITE (*,*) 'PARAMETER VALUES:', MODEL2%PARAMETER_VAL
  WRITE (*,*) 'STOICHIOMETRY:'
  DO I = 1,MODEL2%NSPECIES
     DO J = 1, MODEL2%NREACTIONS
        WRITE (*,FMT = '(I2 4X)',ADVANCE='NO') MODEL2%STOICHIOMETRY(I,J)
     ENDDO
     WRITE (*,*) ''
  END DO
  MODEL2%CUSTOMPROP=>PROP
  ERROR = 0.0D0
  ! NOW TEST THE ACCURACY OF THE READ-FROM-FILE PROPENSITIES
  DO I = 1, 50
     DO J = 1,50
        DO R = 1, MODEL2%NREACTIONS
           P1 = PROP( (/I, J /),R)
           P2 = MODEL2%PROPENSITY((/I, J/), R)
           ERROR = ERROR + ABS(P1-P2)
           WRITE (*, 201) I, J, R, P1, P2, ABS(P1-P2)
        ENDDO
     ENDDO
  ENDDO

  PRINT*,'PROPENSITY TESTING COMPLETED FOR MODEL 2. ACCUMULATED ERROR = ',ERROR

CONTAINS
  DOUBLE PRECISION FUNCTION PROP(STATE, REACTION, PARAMETERS)
    ! PROPENSITY FUNCTION FOR THE TOGGLE SWITCH MODEL
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: STATE(:), REACTION
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: PARAMETERS(:)
    DOUBLE PRECISION C
    !------GENERATE INDIVIDUAL VALUES OF PROPENSITY FUNCTIONS--
    !----------------------------------------------------------
    SELECT CASE (REACTION)
    CASE (1)
       C=5000.0D0
       PROP=C/(1.0D0+DBLE(STATE(2))**(2.5D0))
    CASE (2)
       C=1600.0D0
       PROP=C/(1.0D0+DBLE(STATE(1))**(1.5D0))
    CASE (3)
       C=1.0D0*DBLE(STATE(1))
       PROP=C
    CASE (4)
       C=1.0D0*DBLE(STATE(2))
       PROP=C
    END SELECT
  END FUNCTION PROP

END


!*******************************************************
!
!   TO TEST RNGs
!
!*******************************************************

program RNG

    use mo_kind,  only: i4, i8, SP, DP
    use mo_ansi_colors, only: color, c_red, c_green
    use mo_xor4096, only: xor4096, xor4096g, n_save_state

    implicit none

    integer(i4)                    :: ISeedSP_D0
    integer(i4), allocatable       :: ISeedSP(:)
    integer(i8), allocatable       :: ISeedDP(:)

    integer(i4)                    :: SingleIntegerRN_D0
    integer(i4), allocatable       :: SingleIntegerRN(:)
    integer(i8), allocatable       :: DoubleIntegerRN(:)
    real(SP),    allocatable       :: SingleRealRN(:)
    real(DP),    allocatable       :: DoubleRealRN(:)

    integer(i4)                    :: NumberOfStreams = 3

    character(80)                  :: CheckString, CheckStringShort
    integer(i4), allocatable       :: CheckISP_D0(:)
    integer(i4), allocatable       :: CheckISP_D1(:,:)

    integer(i8)                    :: i,j

    ! Needed for optional versions: Single
    integer(i4), dimension(n_save_state)   :: save_state_d0
    integer(i4), dimension(3, n_save_state) :: save_state_d1_3
    integer(i4), dimension(2, n_save_state) :: save_state_d1_2

    allocate(ISeedSP(NumberOfStreams))
    allocate(ISeedDP(NumberOfStreams))
    allocate(SingleIntegerRN(NumberOfStreams))
    allocate(DoubleIntegerRN(NumberOfStreams))
    allocate(SingleRealRN(NumberOfStreams))
    allocate(DoubleRealRN(NumberOfStreams))

    print*,'----------------------------------------'
    print*,'UNIFORM Single Precision (32 bit) Integer'
    print*,'          1 STREAM                       '
    print*,'----------------------------------------'
    ISeedSP_D0 = 3_i4
    allocate (CheckISP_D0(5))
    CheckISP_D0 = (/-1381736336,1670483215,-70622511,1980498182,-909439004/)
    CheckString = 'mo_xor4096: Uniform Single Integer (1 stream) '//color('o.k.', c_green)
    do i=1,5
        call xor4096(ISeedSP_D0, SingleIntegerRN_D0)
        if (SingleIntegerRN_D0 .eq. CheckISP_D0(i)) then
            CheckStringShort = 'ok'
        else
            CheckString = 'mo_xor4096: Uniform Single Integer (1 stream) '//color('failed', c_red)
            CheckStringShort = 'fail'
        end if
        print '(A8,I6,A4,I12,A4,A10)', 'xor4096(',i,') = ',SingleIntegerRN_D0,'    ',CheckStringShort
        ISeedSP_D0 = 0_i4
    end do
    print *, CheckString
    deallocate (CheckISP_D0)

    print*,'----------------------------------------'
    print*,'UNIFORM Single Precision (32 bit) Integer'
    print*,'          3 STREAMS                      '
    print*,'----------------------------------------'
    ISeedSP = (/ 3_i4, 5_i4, 7_i4 /)
    allocate (CheckISP_D1(5,NumberOfStreams))
    CheckISP_D1(1,:) = (/-1381736336,-1632616910,739198204/)
    CheckISP_D1(2,:) = (/1670483215,28429767,1655944655/)
    CheckISP_D1(3,:) = (/-70622511,692184865,1023508511/)
    CheckISP_D1(4,:) = (/1980498182,-964703497,290140738/)
    CheckISP_D1(5,:) = (/-909439004,94001477,-1671307991/)
    CheckString = 'mo_xor4096: Uniform Single Integer (3 streams) '//color('o.k.', c_green)
    CheckStringShort = 'ok'
    do i=1,5
        call xor4096(ISeedSP,SingleIntegerRN)
        print '(A8,I6,A4)', 'xor4096(',i,') = '
        do j=1,NumberOfStreams
            if (SingleIntegerRN(j) .eq. CheckISP_D1(i,j)) then
                CheckStringShort = 'ok'
            else
                CheckString = 'mo_xor4096: Uniform Single Integer (3 streams) '//color('failed', c_red)
                CheckStringShort = 'fail'
            end if
            print '(A11,I4,A4,I12,A4,A10)', '   stream #',j,'  = ',SingleIntegerRN(j),'    ',CheckStringShort
        end do
        ISeedSP = 0_i4
    end do
    print *, CheckString
    deallocate (CheckISP_D1)

    print*,'-----------------------------------------'
    print*,'UNIFORM Single Precision (32 bit) Integer'
    print*,'          WITH OPTIONAL                  '
    print*,'-----------------------------------------'
    ISeedSP_D0 = 3_i4
    allocate (CheckISP_D0(6))
    CheckISP_D0 = (/-1381736336,1670483215,-70622511,1980498182,-909439004,-1632616910/)
    CheckString = 'mo_xor4096: Uniform Single Integer (with optional) '//color('o.k.', c_green)
    CheckStringShort = 'ok'
    do i=1,3
        call xor4096(ISeedSP_D0,SingleIntegerRN_D0,save_state=save_state_d0)
        if (SingleIntegerRN_D0 .eq. CheckISP_D0(i)) then
            CheckStringShort = 'ok'
        else
            CheckString = 'mo_xor4096: Uniform Single Integer (1st stream) '//color('failed', c_red)
            CheckStringShort = 'fail'
        end if
        print '(A8,I6,A4,I12,A4,A10)', 'xor4096(',i,') = ',SingleIntegerRN_D0,'    ',CheckStringShort
        ISeedSP_D0 = 0_i4
    end do
    ! Start a new Stream
    CheckStringShort = 'ok'
    call xor4096(5_i4,SingleIntegerRN_D0)
    if (SingleIntegerRN_D0 .eq. CheckISP_D0(6)) then
        CheckStringShort = 'ok'
    else
        CheckString = 'mo_xor4096: Uniform Single Integer (2nd stream) '//color('failed', c_red)
        CheckStringShort = 'fail'
    end if
    print '(A8,I6,A4,I12,A4,A10)', 'xor4096(',1,') = ',SingleIntegerRN_D0,'    ',CheckStringShort
    ISeedSP_D0 = 0_i4
    ! Go back to the old stream
    CheckStringShort = 'ok'
    do i=4,5
        call xor4096(ISeedSP_D0,SingleIntegerRN_D0,save_state=save_state_d0)
        if (SingleIntegerRN_D0 .eq. CheckISP_D0(i)) then
            CheckStringShort = 'ok'
        else
            CheckString = 'mo_xor4096: Uniform Single Integer (restart 1st stream) '//color('failed', c_red)
            CheckStringShort = 'fail'
        end if
        print '(A8,I6,A4,I12,A4,A10)', 'xor4096(',i,') = ',SingleIntegerRN_D0,'    ',CheckStringShort
        ISeedSP_D0 = 0_i4
    end do
    print *, CheckString
    deallocate (CheckISP_D0)

    print*,'----------------------------------------'
    print*,'GAUSSIAN Single Precision               '
    print*,'          3 STREAMS and 2 STREAMS       '
    print*,'----------------------------------------'

    print*, '3 streams'
    ISeedSP = (/ 3_i4, 5_i4, 7_i4 /)
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN
    ISeedSP = 0_i4
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN

    print*, '2 streams'
    call xor4096g( (/ 2_i4, 37_i4 /), SingleRealRN(1:2), save_state=save_state_d1_2)
    print*, SingleRealRN(1:2)
    ISeedSP = 0_i4
    call xor4096g((/ 0_i4, 0_i4 /), SingleRealRN(1:2), save_state=save_state_d1_2)
    print*, SingleRealRN(1:2)
    call xor4096g((/ 0_i4, 0_i4 /), SingleRealRN(1:2), save_state=save_state_d1_2)
    print*, SingleRealRN(1:2)

    print*, 'again 3 streams'
    ISeedSP = (/ 3_i4, 5_i4, 7_i4 /)
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN
    ISeedSP = 0_i4
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN
    call xor4096g(ISeedSP,SingleRealRN, save_state=save_state_d1_3)
    print*, SingleRealRN

    deallocate(ISeedSP)
    deallocate(ISeedDP)
    deallocate(SingleIntegerRN)
    deallocate(DoubleIntegerRN)
    deallocate(SingleRealRN)
    deallocate(DoubleRealRN)

end program RNG


      subroutine system_scfft(init,isign,n,scale,x,y,table,work,
     &              isys,ntable,nwork)
*************************************************************************
*** Written by Lin-Wang Wang, 2001
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

cccc input: x  (real)
cccc output: y  (complex)
      implicit none
      integer init,isign,n,isys,ntable,nwork
      real*8 scale,table(1),work(1)
      real*8 x(1),y(1)
ccccccc real to complex 1D fft

cccccc for T3E
c      if(init.eq.1) then
c      call scfft(0,n,scale,0,0,table,0,0)
c      else
c      call scfft(isign,n,scale,x,y,table,work,isys)
c      endif
cccccccccccccccccccccc
cccccc for IBM SP2, essl
      if(init.eq.1) then
      call drcft(1,0,0,0,0,
     &    n,1,-isign,scale,table,ntable,0,0)
      else
      call drcft(0,x,0,y,0,n,1,-isign,scale,
     &    table,ntable,work,nwork)
      endif
cccccccccccccccccccccccccccccccccccc
cccccc for Intel KML
c       if(init.eq.1) then
c       call dzfft1d(y,n,0,table)
c       else
c       do i=1,n
c       y(i)=x(i)*scale
c       enddo
c       call dzfft1d(y,n,-1,table)    ! or -isign
ccccc dzfft1d(y,n,1,table) and dzfft1d(y,n,-1,table) are the same !
c       if(isign.eq.1) then
c       do i=2,n+2,2
c       y(i)=-y(i)
c       enddo
c       endif
c       endif
cccccccccccccccccccccccccccccccccccccccccccc

      return
      end


      SUBROUTINE MT1(N,P,W,C,Z,X,JDIM,JCK,XX,MIN,PSIGN,WSIGN,ZSIGN)
C
C THIS SUBROUTINE SOLVES THE 0-1 SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE  Z = P(1)*X(1) + ... + P(N)*X(N)
C
C SUBJECT TO:   W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
C               X(J) = 0 OR 1  FOR J=1,...,N.
C
C THE PROGRAM IS INCLUDED IN THE VOLUME
C   S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS
C   AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990
C AND IMPLEMENTS THE BRANCH-AND-BOUND ALGORITHM DESCRIBED IN
C SECTION  2.5.2 .
C THE PROGRAM DERIVES FROM AN EARLIER CODE PRESENTED IN
C  S. MARTELLO, P. TOTH, "ALGORITHM FOR THE SOLUTION OF THE 0-1 SINGLE
C  KNAPSACK PROBLEM", COMPUTING, 1978.
C
C THE INPUT PROBLEM MUST SATISFY THE CONDITIONS
C
C   1) 2 .LE. N .LE. JDIM - 1 ;
C   2) P(J), W(J), C  POSITIVE INTEGERS;
C   3) MAX (W(J)) .LE. C ;
C   4) W(1) + ... + W(N) .GT. C ;
C   5) P(J)/W(J) .GE. P(J+1)/W(J+1) FOR J=1,...,N-1.
C
C MT1 CALLS  1  PROCEDURE: CHMT1.
C
C THE PROGRAM IS COMPLETELY SELF-CONTAINED AND COMMUNICATION TO IT IS
C ACHIEVED SOLELY THROUGH THE PARAMETER LIST OF MT1.
C NO MACHINE-DEPENDENT CONSTANT IS USED.
C THE PROGRAM IS WRITTEN IN 1967 AMERICAN NATIONAL STANDARD FORTRAN
C AND IS ACCEPTED BY THE PFORT VERIFIER (PFORT IS THE PORTABLE
C SUBSET OF ANSI DEFINED BY THE ASSOCIATION FOR COMPUTING MACHINERY).
C THE PROGRAM HAS BEEN TESTED ON A DIGITAL VAX 11/780 AND AN H.P.
C 9000/840.
C
C MT1 NEEDS  8  ARRAYS ( P ,  W ,  X ,  XX ,  MIN ,  PSIGN ,  WSIGN
C                        AND  ZSIGN ) OF LENGTH AT LEAST  N + 1 .
C
C MEANING OF THE INPUT PARAMETERS:
C N    = NUMBER OF ITEMS;
C P(J) = PROFIT OF ITEM  J  (J=1,...,N);
C W(J) = WEIGHT OF ITEM  J  (J=1,...,N);
C C    = CAPACITY OF THE KNAPSACK;
C JDIM = DIMENSION OF THE 8 ARRAYS;
C JCK  = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
C      = 0 OTHERWISE.
C
C MEANING OF THE OUTPUT PARAMETERS:
C Z    = VALUE OF THE OPTIMAL SOLUTION IF  Z .GT. 0 ,
C      = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
C        TION  - Z  IS VIOLATED;
C X(J) = 1 IF ITEM  J  IS IN THE OPTIMAL SOLUTION,
C      = 0 OTHERWISE.
C
C ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY.
C
C ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT
C PARAMETERS ARE UNCHANGED.
C
      INTEGER P(JDIM),W(JDIM),X(JDIM),C,Z
      INTEGER XX(JDIM),MIN(JDIM),PSIGN(JDIM),WSIGN(JDIM),ZSIGN(JDIM)
      INTEGER CH,CHS,DIFF,PROFIT,R,T
      Z = 0
      IF ( JCK .EQ. 1 ) CALL CHMT1(N,P,W,C,Z,JDIM)
      IF ( Z .LT. 0 ) RETURN
C INITIALIZE.
      CH = C
      IP = 0
      CHS = CH
      DO 10 LL=1,N
        IF ( W(LL) .GT. CHS ) GO TO 20
        IP = IP + P(LL)
        CHS = CHS - W(LL)
   10 CONTINUE
   20 LL = LL - 1
      IF ( CHS .EQ. 0 ) GO TO 50
      P(N+1) = 0
      W(N+1) = CH + 1
      LIM = IP + CHS*P(LL+2)/W(LL+2)
      A = W(LL+1) - CHS
      B = IP + P(LL+1)
      LIM1 = B - A*FLOAT(P(LL))/FLOAT(W(LL))
      IF ( LIM1 .GT. LIM ) LIM = LIM1
      MINK = CH + 1
      MIN(N) = MINK
      DO 30 J=2,N
        KK = N + 2 - J
        IF ( W(KK) .LT. MINK ) MINK = W(KK)
        MIN(KK-1) = MINK
   30 CONTINUE
      DO 40 J=1,N
        XX(J) = 0
   40 CONTINUE
      Z = 0
      PROFIT = 0
      LOLD = N
      II = 1
      GO TO 170
   50 Z = IP
      DO 60 J=1,LL
        X(J) = 1
   60 CONTINUE
      NN = LL + 1
      DO 70 J=NN,N
        X(J) = 0
   70 CONTINUE
      RETURN
C TRY TO INSERT THE II-TH ITEM INTO THE CURRENT SOLUTION.
   80 IF ( W(II) .LE. CH ) GO TO 90
      II1 = II + 1
      IF ( Z .GE. CH*P(II1)/W(II1) + PROFIT ) GO TO 280
      II = II1
      GO TO 80
C BUILD A NEW CURRENT SOLUTION.
   90 IP = PSIGN(II)
      CHS = CH - WSIGN(II)
      IN = ZSIGN(II)
      DO 100 LL=IN,N
        IF ( W(LL) .GT. CHS ) GO TO 160
        IP = IP + P(LL)
        CHS = CHS - W(LL)
  100 CONTINUE
      LL = N
  110 IF ( Z .GE. IP + PROFIT ) GO TO 280
      Z = IP + PROFIT
      NN = II - 1
      DO 120 J=1,NN
        X(J) = XX(J)
  120 CONTINUE
      DO 130 J=II,LL
        X(J) = 1
  130 CONTINUE
      IF ( LL .EQ. N ) GO TO 150
      NN = LL + 1
      DO 140 J=NN,N
        X(J) = 0
  140 CONTINUE
  150 IF ( Z .NE. LIM ) GO TO 280
      RETURN
  160 IU = CHS*P(LL)/W(LL)
      LL = LL - 1
      IF ( IU .EQ. 0 ) GO TO 110
      IF ( Z .GE. PROFIT + IP + IU ) GO TO 280
C SAVE THE CURRENT SOLUTION.
  170 WSIGN(II) = CH - CHS
      PSIGN(II) = IP
      ZSIGN(II) = LL + 1
      XX(II) = 1
      NN = LL - 1
      IF ( NN .LT. II) GO TO 190
      DO 180 J=II,NN
        WSIGN(J+1) = WSIGN(J) - W(J)
        PSIGN(J+1) = PSIGN(J) - P(J)
        ZSIGN(J+1) = LL + 1
        XX(J+1) = 1
  180 CONTINUE
  190 J1 = LL + 1
      DO 200 J=J1,LOLD
        WSIGN(J) = 0
        PSIGN(J) = 0
        ZSIGN(J) = J
  200 CONTINUE
      LOLD = LL
      CH = CHS
      PROFIT = PROFIT + IP
      IF ( LL - (N - 2) ) 240, 220, 210
  210 II = N
      GO TO 250
  220 IF ( CH .LT. W(N) ) GO TO 230
      CH = CH - W(N)
      PROFIT = PROFIT + P(N)
      XX(N) = 1
  230 II = N - 1
      GO TO 250
  240 II = LL + 2
      IF ( CH .GE. MIN(II-1) ) GO TO 80
C SAVE THE CURRENT OPTIMAL SOLUTION.
  250 IF ( Z .GE. PROFIT ) GO TO 270
      Z = PROFIT
      DO 260 J=1,N
        X(J) = XX(J)
  260 CONTINUE
      IF ( Z .EQ. LIM ) RETURN
  270 IF ( XX(N) .EQ. 0 ) GO TO 280
      XX(N) = 0
      CH = CH + W(N)
      PROFIT = PROFIT - P(N)
C BACKTRACK.
  280 NN = II - 1
      IF ( NN .EQ. 0 ) RETURN
      DO 290 J=1,NN
        KK = II - J
        IF ( XX(KK) .EQ. 1 ) GO TO 300
  290 CONTINUE
      RETURN
  300 R = CH
      CH = CH + W(KK)
      PROFIT = PROFIT - P(KK)
      XX(KK) = 0
      IF ( R .LT. MIN(KK) ) GO TO 310
      II = KK + 1
      GO TO 80
  310 NN = KK + 1
      II = KK
C TRY TO SUBSTITUTE THE NN-TH ITEM FOR THE KK-TH.
  320 IF ( Z .GE. PROFIT + CH*P(NN)/W(NN) ) GO TO 280
      DIFF = W(NN) - W(KK)
      IF ( DIFF ) 370, 330, 340
  330 NN = NN + 1
      GO TO 320
  340 IF ( DIFF .GT. R ) GO TO 330
      IF ( Z .GE. PROFIT + P(NN) ) GO TO 330
      Z = PROFIT + P(NN)
      DO 350 J=1,KK
        X(J) = XX(J)
  350 CONTINUE
      JJ = KK + 1
      DO 360 J=JJ,N
        X(J) = 0
  360 CONTINUE
      X(NN) = 1
      IF ( Z .EQ. LIM ) RETURN
      R = R - DIFF
      KK = NN
      NN = NN + 1
      GO TO 320
  370 T = R - DIFF
      IF ( T .LT. MIN(NN) ) GO TO 330
      IF ( Z .GE. PROFIT + P(NN) + T*P(NN+1)/W(NN+1)) GO TO 280
      CH = CH - W(NN)
      PROFIT = PROFIT + P(NN)
      XX(NN) = 1
      II = NN + 1
      WSIGN(NN) = W(NN)
      PSIGN(NN) = P(NN)
      ZSIGN(NN) = II
      N1 = NN + 1
      DO 380 J=N1,LOLD
        WSIGN(J) = 0
        PSIGN(J) = 0
        ZSIGN(J) = J
  380 CONTINUE
      LOLD = NN
      GO TO 80
      END
      SUBROUTINE CHMT1(N,P,W,C,Z,JDIM)
C
C CHECK THE INPUT DATA.
C
      INTEGER P(JDIM),W(JDIM),C,Z
      IF ( N .GE. 2 .AND. N .LE. JDIM - 1 ) GO TO 10
      Z = - 1
      RETURN
   10 IF ( C .GT. 0 ) GO TO 30
   20 Z = - 2
      RETURN
   30 JSW = 0
      RR = FLOAT(P(1))/FLOAT(W(1))
      DO 50 J=1,N
        R = RR
        IF ( P(J) .LE. 0 ) GO TO 20
        IF ( W(J) .LE. 0 ) GO TO 20
        JSW = JSW + W(J)
        IF ( W(J) .LE. C ) GO TO 40
        Z = - 3
        RETURN
   40   RR = FLOAT(P(J))/FLOAT(W(J))
        IF ( RR .LE. R ) GO TO 50
        Z = - 5
        RETURN
   50 CONTINUE
      IF ( JSW .GT. C ) RETURN
      Z = - 4
      RETURN
      END


!> \file test_derivnum.f90
!! \BRIEF Fortran 90 program to test num_deriv.f90
PROGRAM test_derivnum

   USE msingledouble
   USE mvars
   USE mderivnum

   IMPLICIT NONE

!  Output variables:
   REAL(kind=rx), DIMENSION(1) :: h, ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, BetaD, rhoSW, p, tempis
!  derivative of "vars" Output variables:
   REAL(kind=rx), DIMENSION(1) :: dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx, dco3_dx, dOmegaA_dx, dOmegaC_dx
!  Input variables
   REAL(kind=rx), DIMENSION(1) :: temp, sal, alk, dic, sil, phos, Patm, depth, lat
!  Input options
   CHARACTER(10) :: optCON, optT, optP, optB, optKf, optK1K2

!  Local variables:
   CHARACTER*3, DIMENSION(13) ::  devar = (/'alk','dic','pho','sil','tem','sal','k0 ','k1 ','k2 ','kb ','kw ','ka ','kc '/)
   INTEGER ::  i

  !     derivar = 3-character identifier of input variable with respect to which derivative is requested
  !               possibilities are 'alk', 'dic', 'pho', 'sil', 'tem', or 'sal'
  !

!> Typical options for observations
   optCON  = 'mol/kg'  ! input concentrations are in MOL/KG
   optT    = 'Tinsitu' ! input temperature, variable 'temp' is actually IN SITU temp [°C]
   optP    = 'db'       ! input variable 'depth' is in meters
   optB    = 'l10'
   optK1K2 = 'l'
   optKf   = 'dg'
!> Simple input data (with CONCENTRATION units typical for DATA)
!> (based on observed average surface concentrations from S. Ocean (south of 60°S)--GLODAP and WOA2009)
    temp(1)   = 18.0d0            !Can be "Potential temperature" or "In situ temperature" (see optT below)
    sal(1)    = 35.0d0           !Salinity (practical scale)
    alk(1)    = 2300.0d-6      ! Convert obs. S. Ocean ave surf ALK (umol/kg) to mocsy data units (mol/kg)
    dic(1)    = 2000.0d-6      ! Convert obs. S. Ocean ave surf DIC (umol/kg) to mocsy data units (mol/kg)
    sil(1)    = 0.0d0   ! 60.d-06
    phos(1)   = 0.0d0   !  2.d-06
    sil(1)    = 60.0d-6   ! 60.d-06
    phos(1)   =  2.0d-6   !  2.d-06
    depth(1)  = 0.d0
    Patm(1)   = 1.0d0            !Atmospheric pressure (atm)
    lat(1)    = 0.d0

!  Select input var 'x', choosing set of dy_i/dx to be computed, where y_i are the diff output vars
   call vars(ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, BetaD, rhoSW, p, tempis,         &  ! OUTPUT
             temp, sal, alk, dic, sil, phos, Patm, depth, lat, 1,                             &  ! INPUT
             optCON, optT, optP, optB=optB, optK1K2=optK1K2, optKf=optKf,                     &
             optGAS='Ppot'    )
   h(1) = 10**(- ph(1))

   write (*,*) "Variables:"
   write (*,*) "          h,           ph,         pco2,         fco2,           co2",&
              "           hco3,           co3,         OmegaA,         OmegaC"
   write (*,"(9ES15.6)")  h, ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC

   write (*,*) "Absolute derivatives"
   write (*,*) "             dh_dx         dpco2_dx       dfco2_dx         dco2_dx      dhco3_dx       dco3_dx", &
        "       dOmegaA_dx     dOmegaC_dx"

   do i = 1,13
      call derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,                      &
                      dco3_dx, dOmegaA_dx, dOmegaC_dx,                                   &
                      temp, sal, alk, dic, sil, phos, Patm, depth, lat, 1, devar(i),     &
                      optCON, optT, optP, optB=optB, optK1K2=optK1K2, optKf=optKf          )

      write (*,"(A3,A5,8ES15.6)")  devar(i), "  :  ", dh_dx(1), dpco2_dx(1), dfco2_dx(1), dco2_dx(1), dhco3_dx(1), dco3_dx(1), &
          dOmegaA_dx(1), dOmegaC_dx(1)
   end do

  STOP
END PROGRAM test_derivnum


SUBROUTINE DiffYEvenCurvilinear(var,varY,Nxg,Nyg,Nzg,CompGrid,kappa)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: Nxg, Nyg, Nzg, order, kappa, i,j,k
REAL(KIND=long), DIMENSION(Nzg,Nxg,Nyg) :: var, varY, vare, varn
REAL(KIND=long), DIMENSION(2*kappa+1,2*kappa+1,2) :: DiffStencilArray
REAL(KIND=long) :: ey, ny

DiffStencilArray = CompGrid%CurvilinearStuff%DiffStencils%StencilG

CALL DiffXuniform3D(var,vare,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffYuniform3D(var,varn,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?

DO i = 1, Nxg
	DO j = 1, Nyg
		ey = CompGrid%CurvilinearStuff%ey(i,j)
		ny = CompGrid%CurvilinearStuff%ny(i,j)
		DO k = 1, Nzg
			varY(k,i,j) = ey*vare(k,i,j)+ny*varn(k,i,j)
		END DO
	END DO
END DO
END SUBROUTINE DiffYEvenCurvilinear


*DECK DBNDAC
      SUBROUTINE DBNDAC (G, MDG, NB, IP, IR, MT, JT)
C***BEGIN PROLOGUE  DBNDAC
C***PURPOSE  Compute the LU factorization of a  banded matrices using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      DOUBLE PRECISION (BNDACC-S, DBNDAC-D)
C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     These subroutines solve the least squares problem Ax = b for
C     banded matrices A using sequential accumulation of rows of the
C     data matrix.  Exactly one right-hand side vector is permitted.
C
C     These subroutines are intended for the type of least squares
C     systems that arise in applications such as curve or surface
C     fitting of data.  The least squares equations are accumulated and
C     processed using only part of the data.  This requires a certain
C     user interaction during the solution of Ax = b.
C
C     Specifically, suppose the data matrix (A B) is row partitioned
C     into Q submatrices.  Let (E F) be the T-th one of these
C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
C     and the dimension of C is MT by NB.  The value of NB is the
C     bandwidth of A.  The dimensions of the leading block of zeros in E
C     are MT by JT-1.
C
C     The user of the subroutine DBNDAC provides MT,JT,C and F for
C     T=1,...,Q.  Not all of this data must be supplied at once.
C
C     Following the processing of the various blocks (E F), the matrix
C     (A B) has been transformed to the form (R D) where R is upper
C     triangular and banded with bandwidth NB.  The least squares
C     system Rx = d is then easily solved using back substitution by
C     executing the statement CALL DBNDSL(1,...). The sequence of
C     values for JT must be nondecreasing.  This may require some
C     preliminary interchanges of rows and columns of the matrix A.
C
C     The primary reason for these subroutines is that the total
C     processing can take place in a working array of dimension MU by
C     NB+1.  An acceptable value for MU is
C
C                       MU = MAX(MT + N + 1),
C
C     where N is the number of unknowns.
C
C     Here the maximum is taken over all values of MT for T=1,...,Q.
C     Notice that MT can be taken to be a small as one, showing that
C     MU can be as small as N+2.  The subprogram DBNDAC processes the
C     rows more efficiently if MU is large enough so that each new
C     block (C F) has a distinct value of JT.
C
C     The four principle parts of these algorithms are obtained by the
C     following call statements
C
C     CALL DBNDAC(...)  Introduce new blocks of data.
C
C     CALL DBNDSL(1,...)Compute solution vector and length of
C                       residual vector.
C
C     CALL DBNDSL(2,...)Given any row vector H solve YR = H for the
C                       row vector Y.
C
C     CALL DBNDSL(3,...)Given any column vector W solve RZ = W for
C                       the column vector Z.
C
C     The dots in the above call statements indicate additional
C     arguments that will be specified in the following paragraphs.
C
C     The user must dimension the array appearing in the call list..
C     G(MDG,NB+1)
C
C     Description of calling sequence for DBNDAC..
C
C     The entire set of parameters for DBNDAC are
C
C     Input.. All Type REAL variables are DOUBLE PRECISION
C
C     G(*,*)            The working array into which the user will
C                       place the MT by NB+1 block (C F) in rows IR
C                       through IR+MT-1, columns 1 through NB+1.
C                       See descriptions of IR and MT below.
C
C     MDG               The number of rows in the working array
C                       G(*,*).  The value of MDG should be .GE. MU.
C                       The value of MU is defined in the abstract
C                       of these subprograms.
C
C     NB                The bandwidth of the data matrix A.
C
C     IP                Set by the user to the value 1 before the
C                       first call to DBNDAC.  Its subsequent value
C                       is controlled by DBNDAC to set up for the
C                       next call to DBNDAC.
C
C     IR                Index of the row of G(*,*) where the user is
C                       to place the new block of data (C F).  Set by
C                       the user to the value 1 before the first call
C                       to DBNDAC.  Its subsequent value is controlled
C                       by DBNDAC. A value of IR .GT. MDG is considered
C                       an error.
C
C     MT,JT             Set by the user to indicate respectively the
C                       number of new rows of data in the block and
C                       the index of the first nonzero column in that
C                       set of rows (E F) = (0 C 0 F) being processed.
C
C     Output.. All Type REAL variables are DOUBLE PRECISION
C
C     G(*,*)            The working array which will contain the
C                       processed rows of that part of the data
C                       matrix which has been passed to DBNDAC.
C
C     IP,IR             The values of these arguments are advanced by
C                       DBNDAC to be ready for storing and processing
C                       a new block of data in G(*,*).
C
C     Description of calling sequence for DBNDSL..
C
C     The user must dimension the arrays appearing in the call list..
C
C     G(MDG,NB+1), X(N)
C
C     The entire set of parameters for DBNDSL are
C
C     Input.. All Type REAL variables are DOUBLE PRECISION
C
C     MODE              Set by the user to one of the values 1, 2, or
C                       3.  These values respectively indicate that
C                       the solution of AX = B, YR = H or RZ = W is
C                       required.
C
C     G(*,*),MDG,       These arguments all have the same meaning and
C      NB,IP,IR         contents as following the last call to DBNDAC.
C
C     X(*)              With mode=2 or 3 this array contains,
C                       respectively, the right-side vectors H or W of
C                       the systems YR = H or RZ = W.
C
C     N                 The number of variables in the solution
C                       vector.  If any of the N diagonal terms are
C                       zero the subroutine DBNDSL prints an
C                       appropriate message.  This condition is
C                       considered an error.
C
C     Output.. All Type REAL variables are DOUBLE PRECISION
C
C     X(*)              This array contains the solution vectors X,
C                       Y or Z of the systems AX = B, YR = H or
C                       RZ = W depending on the value of MODE=1,
C                       2 or 3.
C
C     RNORM             If MODE=1 RNORM is the Euclidean length of the
C                       residual vector AX-B.  When MODE=2 or 3 RNORM
C                       is set to zero.
C
C     Remarks..
C
C     To obtain the upper triangular matrix and transformed right-hand
C     side vector D so that the super diagonals of R form the columns
C     of G(*,*), execute the following Fortran statements.
C
C     NBP1=NB+1
C
C     DO 10 J=1, NBP1
C
C  10 G(IR,J) = 0.E0
C
C     MT=1
C
C     JT=N+1
C
C     CALL DBNDAC(G,MDG,NB,IP,IR,MT,JT)
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
C***ROUTINES CALLED  DH12, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBNDAC
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION G(MDG,*)
C***FIRST EXECUTABLE STATEMENT  DBNDAC
      ZERO=0.D0
C
C              ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE.
C
      NBP1=NB+1
      IF (MT.LE.0.OR.NB.LE.0) RETURN
C
      IF(.NOT.MDG.LT.IR) GO TO 5
      NERR=1
      IOPT=2
      CALL XERMSG ('SLATEC', 'DBNDAC', 'MDG.LT.IR, PROBABLE ERROR.',
     +   NERR, IOPT)
      RETURN
    5 CONTINUE
C
C                                             ALG. STEP 5
      IF (JT.EQ.IP) GO TO 70
C                                             ALG. STEPS 6-7
      IF (JT.LE.IR) GO TO 30
C                                             ALG. STEPS 8-9
      DO 10 I=1,MT
        IG1=JT+MT-I
        IG2=IR+MT-I
        DO 10 J=1,NBP1
        G(IG1,J)=G(IG2,J)
   10 CONTINUE
C                                             ALG. STEP 10
      IE=JT-IR
      DO 20 I=1,IE
        IG=IR+I-1
        DO 20 J=1,NBP1
        G(IG,J)=ZERO
   20 CONTINUE
C                                             ALG. STEP 11
      IR=JT
C                                             ALG. STEP 12
   30 MU=MIN(NB-1,IR-IP-1)
      IF (MU.EQ.0) GO TO 60
C                                             ALG. STEP 13
      DO 50 L=1,MU
C                                             ALG. STEP 14
        K=MIN(L,JT-IP)
C                                             ALG. STEP 15
        LP1=L+1
        IG=IP+L
        DO 40 I=LP1,NB
          JG=I-K
          G(IG,JG)=G(IG,I)
   40 CONTINUE
C                                             ALG. STEP 16
        DO 50 I=1,K
        JG=NBP1-I
        G(IG,JG)=ZERO
   50 CONTINUE
C                                             ALG. STEP 17
   60 IP=JT
C                                             ALG. STEPS 18-19
   70 MH=IR+MT-IP
      KH=MIN(NBP1,MH)
C                                             ALG. STEP 20
      DO 80 I=1,KH
        CALL DH12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO,
     1            G(IP,I+1),1,MDG,NBP1-I)
   80 CONTINUE
C                                             ALG. STEP 21
      IR=IP+KH
C                                             ALG. STEP 22
      IF (KH.LT.NBP1) GO TO 100
C                                             ALG. STEP 23
      DO 90 I=1,NB
        G(IR-1,I)=ZERO
   90 CONTINUE
C                                             ALG. STEP 24
  100 CONTINUE
C                                             ALG. STEP 25
      RETURN
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYEIG4
C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
C...Specific application: mixing in neutralino sector.

      SUBROUTINE PYEIG4(A,W,Z)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Arrays: in call and local.
      DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)

C...Coefficients of fourth-degree equation from matrix.
C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
      B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
      B2=0D0
      DO 110 I=1,3
        DO 100 J=I+1,4
          B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
  100   CONTINUE
  110 CONTINUE
      B1=0D0
      B0=0D0
      DO 120 I=1,4
        I1=MOD(I,4)+1
        I2=MOD(I+1,4)+1
        I3=MOD(I+2,4)+1
        B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
     &  A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
     &  A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
        B0=B0+(-1D0)**(I+1)*A(1,I)*(
     &  A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
     &  A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
     &  A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
  120 CONTINUE

C...Coefficients of third-degree equation needed for
C...separation into two second-degree equations.
C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
      C2=-B2
      C1=B1*B3-4D0*B0
      C0=-B1**2-B0*B3**2+4D0*B0*B2
      CQ=C1/3D0-C2**2/9D0
      CR=C1*C2/6D0-C0/2D0-C2**3/27D0
      CQR=CQ**3+CR**2

C...Cases with one or three real roots.
      IF(CQR.GE.0D0) THEN
        S1=(CR+SQRT(CQR))**(1D0/3D0)
        S2=(CR-SQRT(CQR))**(1D0/3D0)
        U=S1+S2-C2/3D0
      ELSE
        SABS=SQRT(-CQ)
        THE=ACOS(CR/SABS**3)/3D0
        SRE=SABS*COS(THE)
        U=2D0*SRE-C2/3D0
      ENDIF

C...Find and solve two second-degree equations.
      P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
      P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
      Q1=U/2D0+SQRT(U**2/4D0-B0)
      Q2=U/2D0-SQRT(U**2/4D0-B0)
      IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
        QSAV=Q1
        Q1=Q2
        Q2=QSAV
      ENDIF
      X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
      X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
      X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
      X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)

C...Order eigenvalues in asceding mass.
      W(1)=X(1)
      DO 150 I1=2,4
        DO 130 I2=I1-1,1,-1
          IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
          W(I2+1)=W(I2)
  130   CONTINUE
  140   W(I2+1)=X(I1)
  150 CONTINUE

C...Find equation system for eigenvectors.
      DO 250 I=1,4
        DO 170 J1=1,4
          D(J1,J1)=A(J1,J1)-W(I)
          DO 160 J2=J1+1,4
            D(J1,J2)=A(J1,J2)
            D(J2,J1)=A(J2,J1)
  160     CONTINUE
  170   CONTINUE

C...Find largest element in matrix.
        DAMAX=0D0
        DO 190 J1=1,4
          DO 180 J2=1,4
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
            JA=J1
            JB=J2
            DAMAX=ABS(D(J1,J2))
  180     CONTINUE
  190   CONTINUE

C...Subtract others by multiple of row selected above.
        DAMAX=0D0
        DO 210 J3=JA+1,JA+3
          J1=J3-4*((J3-1)/4)
          RL=D(J1,JB)/D(JA,JB)
          DO 200 J2=1,4
            D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
            JC=J1
            JD=J2
            DAMAX=ABS(D(J1,J2))
  200     CONTINUE
  210   CONTINUE

C...Do one more subtraction of a row.
        DAMAX=0D0
        DO 230 J3=JC+1,JC+3
          J1=J3-4*((J3-1)/4)
          IF(J1.EQ.JA) GOTO 230
          RL=D(J1,JD)/D(JC,JD)
          DO 220 J2=1,4
            IF(J2.EQ.JB) GOTO 220
            D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
            JE=J1
            DAMAX=ABS(D(J1,J2))
  220     CONTINUE
  230   CONTINUE

C...Construct unnormalized eigenvector.
        JF1=JD+1-4*(JD/4)
        JF2=JD+2-4*((JD+1)/4)
        IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
        IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
        E(JF1)=-D(JE,JF2)
        E(JF2)=D(JE,JF1)
        E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
        E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
     &  D(JA,JB)

C...Normalize and fill in final array.
        EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
        SGN=(-1D0)**INT(PYR(0)+0.5D0)
        DO 240 J=1,4
          Z(I,J)=SGN*E(J)/EA
  240   CONTINUE
  250 CONTINUE

      RETURN
      END


SUBROUTINE p613(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.13 Three-dimensional strain analysis of an elastic-plastic
!              (Mohr-Coulomb) slope using 20-node hexahedra. Viscoplastic
!              strain method. No global stiffness matrix assembly.
!              Diagonally preconditioned conjugate gradient solver.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file

 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,cg_tot,i,iel,ifix,iters,iy,k,limit,ndim=3,    &
   ndof=60,nels,neq,nip=8,nn,nod=20,nodof=3,nprops=6,np_types,nsrf,nst=6, &
   nx1,nx2,ny1,ny2,nze,nlen
 REAL(iwp)::alpha,beta,cf,cg_tol,ddt,det,dq1,dq2,dq3,dsbar,dt=1.0e15_iwp, &
   d1,d4=4.0_iwp,d180=180.0_iwp,e,f,fmax,h1,h2,lode_theta,one=1.0_iwp,phi,&
   phif,pi,psi,psif,sigm,snph,start_dt=1.e15_iwp,s1,tnph,tnps,tol,        &
   two=2.0_iwp,up,v,w1,w2,zero=0.0_iwp
 CHARACTER(LEN=80)::argv,element='hexahedron'
 LOGICAL::converged,cg_converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),d(:),      &
   dee(:,:),der(:,:),deriv(:,:),devp(:),diag_precon(:),eld(:),eload(:),   &
   eps(:),erate(:),evp(:),evpt(:,:,:),flow(:,:),fun(:),gravlo(:),         &
   g_coord(:,:),jac(:,:),km(:,:),loads(:),m1(:,:),m2(:,:),m3(:,:),        &
   oldis(:),p(:),points(:,:),prop(:,:),sigma(:),srf(:),storkm(:,:,:),u(:),&
   weights(:),x(:),xnew(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
!---(ifix=1) smooth-smooth(ifix=2) rough-smooth(ifix=3) rough-rough---
 READ(10,*)w1,s1,w2,h1,h2,d1,nx1,nx2,ny1,ny2,nze,ifix,                    &
   cg_tol,cg_limit,np_types
 nels=(nx1*ny1+ny2*(nx1+nx2))*nze
 nn=((3*(ny1+ny2)+2)*nx1+2*(ny1+ny2)+1+(3*ny2+2)*nx2)*(1+nze)+            &
   ((ny1+ny2+1)*(nx1+1)+(ny2+1)*nx2)*nze
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   num(nod),dee(nst,nst),evpt(nst,nip,nels),coord(nod,ndim),fun(nod),     &
   g_g(ndof,nels),jac(ndim,ndim),der(ndim,nod),etype(nels),               &
   deriv(ndim,nod),g_num(nod,nels),bee(nst,ndof),km(ndof,ndof),eld(ndof), &
   eps(nst),sigma(nst),bload(ndof),eload(ndof),erate(nst),evp(nst),       &
   devp(nst),g(ndof),m1(nst,nst),m2(nst,nst),m3(nst,nst),flow(nst,nst),   &
   prop(nprops,np_types),storkm(ndof,ndof,nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 CALL emb_3d_bc(ifix,nx1,nx2,ny1,ny2,nze,nf)
 neq=MAXVAL(nf)
 WRITE(11,'(A,I7,A)')" There are",neq," equations"
 ALLOCATE(loads(0:neq),bdylds(0:neq),oldis(0:neq),gravlo(0:neq),p(0:neq), &
   x(0:neq),xnew(0:neq),u(0:neq),diag_precon(0:neq),d(0:neq))
!-----------------------loop the elements to find global array sizes-----
 elements_1: DO iel=1,nels
   CALL emb_3d_geom(iel,nx1,nx2,ny1,ny2,nze,w1,s1,w2,h1,h2,d1,coord,num)
   g_num(:,iel)=num
   CALL num_to_g(num,nf,g)
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 pi=ACOS(-one)
 oldis=zero
 gravlo=zero
 p=zero
 xnew=zero
 diag_precon=zero
 CALL sample(element,points,weights)
!----------element stiffness integration, storage and preconditioner------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(5,etype(iel)),prop(6,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   eld=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     eld(2:ndof-1:3)=eld(2:ndof-1:3)+fun(:)*det*weights(i)
   END DO gauss_pts_1
   storkm(:,:,iel)=km
   DO k=1,ndof
     diag_precon(g(k))=diag_precon(g(k))+km(k,k)
   END DO
   gravlo(g)=gravlo(g)-eld*prop(4,etype(iel))
 END DO elements_2
 diag_precon(1:)=one/diag_precon(1:)
 diag_precon(0)=zero
!-----------------------trial strength reduction factor loop--------------
 READ(10,*)tol,limit,nsrf
 ALLOCATE(srf(nsrf))
 READ(10,*)srf
 WRITE(11,'(/A)')"    srf   max disp  iters     cg iters/plastic iter"
 srf_trials: DO iy=1,nsrf
   dt=start_dt
   DO i=1,np_types
     phi=prop(1,i)
     tnph=TAN(phi*pi/d180)
     phif=ATAN(tnph/srf(iy))
     snph=SIN(phif)
     e=prop(5,i)
     v=prop(6,i)
     ddt=d4*(one+v)*(one-two*v)/(e*(one-two*v+snph**2))
     IF(ddt<dt)dt=ddt
   END DO
   iters=0
   bdylds=zero
   evpt=zero
   cg_tot=0
!-----------------------plastic iteration loop----------------------------
   its: DO
     fmax=zero
     iters=iters+1
     loads=gravlo+bdylds
     d=diag_precon*loads
     p=d
     x=zero
     cg_iters=0
!-----------------------pcg equation solution-----------------------------
     pcg: DO
       cg_iters=cg_iters+1
       u=zero
       elements_3: DO iel=1,nels
         CALL deemat(dee,prop(2,etype(iel)),prop(3,etype(iel)))
         g=g_g(:,iel)
         km=storkm(:,:,iel)
         u(g)=u(g)+MATMUL(km,p(g))
       END DO elements_3
       up=DOT_PRODUCT(loads,d)
       alpha=up/DOT_PRODUCT(p,u)
       xnew=x+p*alpha
       loads=loads-u*alpha
       d=diag_precon*loads
       beta=DOT_PRODUCT(loads,d)/up
       p=d+p*beta
       CALL checon(xnew,x,cg_tol,cg_converged)
       IF(cg_converged.OR.cg_iters==cg_limit)EXIT
     END DO pcg
     cg_tot=cg_tot+cg_iters
     loads=xnew
     loads(0)=zero
!-----------------------check plastic convergence-------------------------
     CALL checon(loads,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)bdylds=zero
!-----------------------go round the Gauss Points ------------------------
     elements_4: DO iel=1,nels
       phi=prop(1,etype(iel))
       tnph=TAN(phi*pi/d180)
       phif=ATAN(tnph/srf(iy))*d180/pi
       psi=prop(3,etype(iel))
       tnps=TAN(psi*pi/d180)
       psif=ATAN(tnps/srf(iy))*d180/pi
       cf=prop(2,etype(iel))/srf(iy)
       e=prop(5,etype(iel))
       v=prop(6,etype(iel))
       CALL deemat(dee,e,v)
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       bload=zero
       gauss_points_2: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         eps=eps-evpt(:,i,iel)
         sigma=MATMUL(dee,eps)
         CALL invar(sigma,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phif,cf,sigm,dsbar,lode_theta,f)
         IF(f>fmax)fmax=f
         IF(converged.OR.iters==limit)THEN
           devp=sigma
         ELSE
           IF(f>=zero.OR.(converged.OR.iters==limit))THEN
             CALL mocouq(psif,dsbar,lode_theta,dq1,dq2,dq3)
             CALL formm(sigma,m1,m2,m3)
             flow=f*(m1*dq1+m2*dq2+m3*dq3)
             erate=MATMUL(flow,sigma)
             evp=erate*dt
             evpt(:,i,iel)=evpt(:,i,iel)+evp
             devp=MATMUL(dee,evp)
           END IF
         END IF
         IF(f>=zero.OR.(converged.OR.iters==limit))THEN
           eload=MATMUL(devp,bee)
           bload=bload+eload*det*weights(i)
         END IF
       END DO gauss_points_2
!-----------------------compute the total bodyloads vector----------------
       bdylds(g)=bdylds(g)+bload
       bdylds(0)=zero
     END DO elements_4
     WRITE(*,'(A,F7.2,A,I4,A,F8.3)')                                      &
       "  srf",srf(iy),"  iteration",iters,"  F_max",fmax
     IF(converged.OR.iters==limit)EXIT
   END DO its
   WRITE(11,'(F7.2,E12.4,I5,F17.2)')                                     &
     srf(iy),MAXVAL(ABS(loads)),iters,REAL(cg_tot)/REAL(iters)
   IF(iters==limit)EXIT
 END DO srf_trials

END SUBROUTINE p613


!=====================================================|
subroutine artdif
!=====================================================|
  use geometry_def, only: qqm,qqp,nxg,dx,dt,mtype,cc
  use const_def, only: cv,cp,gm,rr,pii4
  implicit none

  integer :: i,m
  real(KIND(0.d0)), parameter :: fh = 0.d0, ep = 1.d0
  real(KIND(0.d0)), dimension(nxg,mtype) :: fx,dui
  real(KIND(0.d0)) :: dul,dur,duc,mup,mlo
  real(KIND(0.d0)) :: ul,ur,du,ra,pp
  real(KIND(0.d0)) :: dro,drx,dry,drz,dbx,dby,dbz,dse

  real(KIND(0.d0)), dimension(nxg) :: pr,te,hh ! pressure, temperature, enthalpy
!-----------------------------------------------------|

  do i = 1,nxg
     qqp(i,1) = qqm(i,1)
     qqp(i,2) = qqm(i,2)
     qqp(i,3) = qqm(i,3)
     qqp(i,4) = qqm(i,4)
     qqp(i,5) = qqm(i,5)
     qqp(i,6) = qqm(i,6)
     qqp(i,7) = qqm(i,7)
     qqp(i,8) = qqm(i,8)

     pr(i) = qqp(i,1)**gm*exp(qqp(i,8)/cv)
     te(i) = pr(i)/rr/qqp(i,1)
     hh(i) = cp*te(i) + 0.5d0*(qqp(i,2)**2 + qqp(i,3)**2 + qqp(i,4)**2)
  enddo

  ! calculating artificial diffusivity flux
  do i = 2,nxg-1
  do m = 1,mtype
     dul = qqp(i  ,m) - qqp(i-1,m)
     dur = qqp(i+1,m) - qqp(i  ,m)
     duc = 0.5d0*(qqp(i+1,m) - qqp(i-1,m))

     mup = max(ep*dul,ep*dur,duc)
     mlo = min(ep*dul,ep*dur,duc)

     dui(i,m) = min(0.d0,mup) + max(0.d0,mlo)
  enddo
  enddo

  do i = 2,nxg-2
  do m = 1,mtype
     ul = qqp(i  ,m) + 0.5d0*dui(i  ,m)
     ur = qqp(i+1,m) - 0.5d0*dui(i+1,m)
     du = qqp(i+1,m) - qqp(i,m)
     du = sign(1.d0,du)*max(abs(du),1.d-10)
     ra = min((ur-ul)/du,1.d0)
     pp = (0.5d0 + sign(0.5d0,ra))*max(0.d0,1.d0 + fh*(ra-1.d0))
     fx(i,m) = -0.5d0*(ur - ul)*pp*max(cc(i),cc(i+1))
     !fx(i,m) = -0.5d0*(ur - ul)*pp*0.5d0*(cc(i)+cc(i+1))
  enddo
  enddo

  do i = 2,nxg-2
     fx(i,8) = &
          & + 0.5d0*(qqp(i,1)*te(i) + qqp(i+1,1)*te(i+1))*fx(i,8) &
          & + 0.5d0*(qqp(i,1)*qqp(i,2) + qqp(i+1,1)*qqp(i+1,2))*fx(i,2) &
          & + 0.5d0*(qqp(i,1)*qqp(i,3) + qqp(i+1,1)*qqp(i+1,3))*fx(i,3) &
          & + 0.5d0*(qqp(i,1)*qqp(i,4) + qqp(i+1,1)*qqp(i+1,4))*fx(i,4) &
          & + 0.5d0*(qqp(i,5) + qqp(i+1,5))*fx(i,5)*pii4 &
          & + 0.5d0*(qqp(i,6) + qqp(i+1,6))*fx(i,6)*pii4 &
          & + 0.5d0*(qqp(i,7) + qqp(i+1,7))*fx(i,7)*pii4

     fx(i,2) = + 0.5d0*(qqp(i,1) + qqp(i+1,1))*fx(i,2) &
          &    + 0.5d0*(qqp(i,2) + qqp(i+1,2))*fx(i,1)

     fx(i,3) = + 0.5d0*(qqp(i,1) + qqp(i+1,1))*fx(i,3) &
          &    + 0.5d0*(qqp(i,3) + qqp(i+1,3))*fx(i,1)

     fx(i,4) = + 0.5d0*(qqp(i,1) + qqp(i+1,1))*fx(i,4) &
          &    + 0.5d0*(qqp(i,4) + qqp(i+1,4))*fx(i,1)
  enddo

  do i = 3,nxg-2
     dro = -(fx(i,1) - fx(i-1,1))/dx*dt
     drx = -(fx(i,2) - fx(i-1,2))/dx*dt
     dry = -(fx(i,3) - fx(i-1,3))/dx*dt
     drz = -(fx(i,4) - fx(i-1,4))/dx*dt
     dbx = -(fx(i,5) - fx(i-1,5))/dx*dt
     dby = -(fx(i,6) - fx(i-1,6))/dx*dt
     dbz = -(fx(i,7) - fx(i-1,7))/dx*dt
     dse =  ( &
          & - (fx(i,8) - fx(i-1,8))/dx*dt &
          & - (hh(i) - qqp(i,2)**2 - qqp(i,3)**2 - qqp(i,4)**2)*dro &
          & - (qqp(i,2)*drx + qqp(i,3)*dry + qqp(i,4)*drz) &
          & - (qqp(i,5)*dbx + qqp(i,6)*dby + qqp(i,7)*dbz)*pii4 &
          & )
     qqm(i,1) = qqm(i,1) + dro
     qqm(i,2) = (qqp(i,1)*qqm(i,2) + drx)/qqm(i,1)
     qqm(i,3) = (qqp(i,1)*qqm(i,3) + dry)/qqm(i,1)
     qqm(i,4) = (qqp(i,1)*qqm(i,4) + drz)/qqm(i,1)
     qqm(i,5) = qqm(i,5) + dbx
     qqm(i,6) = qqm(i,6) + dby
     qqm(i,7) = qqm(i,7) + dbz
     qqm(i,8) = qqm(i,8) + dse/qqp(i,1)/te(i)
  enddo

  call bc(qqm)
  return
end subroutine artdif


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR EXTRAPOLATION CODES SEULEX AT VAN DER POL
C * * * * * * * * * * * * * * * * * * * * * * * * *
clink dr_seulex seulex dc_decsol decsol
clink dr_seulex seulex dc_lapack lapack lapackc
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR SEULEX (FULL JACOBIAN)
        PARAMETER (ND=2,KM=12,KM2=2+KM*(KM+3)/2,NRDENS=ND)
        PARAMETER (LWORK=2*ND*ND+(KM+8)*ND+4*KM+20+KM2*NRDENS)
        PARAMETER (LIWORK=2*ND+KM+20+NRDENS)
C --- DECLARATIONS
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK)
        EXTERNAL FVPOL,JVPOL,SOLOUT
        RPAR=1.0D-6
C --- DIMENSION OF THE SYSTEM
        N=2
C --- PROBLEM IS AUTONOMOUS
        IFCN=1
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=0
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=1
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=2.0D0
        Y(2)=-0.66D0
C --- ENDPOINT OF INTEGRATION
        XEND=2.0D0
C --- REQUIRED TOLERANCE
        RTOL=1.0D-4
        ATOL=RTOL
        ITOL=0
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- SET DEFAULT VALUES
        DO 10 I=1,20
  10    WORK(I)=0.D0
        DO 12 I=1,20
  12    IWORK(I)=0
        IWORK(6)=N
        DO I=1,NRDENS
          IWORK(20+I)=I
        END DO
C --- CALL OF THE SUBROUTINE SEULEX
        CALL SEULEX(N,FVPOL,IFCN,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JVPOL,IJAC,MLJAC,MUJAC,
     &                  FVPOL,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT FINAL SOLUTION
        WRITE (6,99) X,Y(1),Y(2)
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10)
C --- PRINT STATISTICS
        WRITE (6,90) RTOL
 90     FORMAT('       rtol=',D8.2)
        WRITE (6,91) (IWORK(J),J=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N,
     &                     RPAR,IPAR,IRTRN)
C --- PRINTS SOLUTION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),RC(LRC),IC(LIC)
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=0.2D0
        ELSE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) X,Y(1),Y(2),NR-1
c             write (6,*) CONTEX(1,XOLD,RC,LRC,IC,LIC)
              XOUT=MAX(XOUT+0.2D0,X)
           END IF
        END IF
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END
C
C
        SUBROUTINE FVPOL(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF VAN DER POL'S EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        F(1)=Y(2)
        F(2)=((1-Y(1)**2)*Y(2)-Y(1))/RPAR
        RETURN
        END
C
C
        SUBROUTINE JVPOL(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- JACOBIAN OF VAN DER POL'S EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        DFY(1,1)=0.0D0
        DFY(1,2)=1.0D0
        DFY(2,1)=(-2.0D0*Y(1)*Y(2)-1.0D0)/RPAR
        DFY(2,2)=(1.0D0-Y(1)**2)/RPAR
        RETURN
        END


\ Bresenham Ellipse
\ Based on "A Fast Bresenham Type AlgorithmFor Drawing Ellipses"
\ https://dai.fmph.uniba.sk/upload/0/01/Ellipse.pdf

\ Bresenham Circle
\ based on a post on geeksforgeeks
\ https://www.geeksforgeeks.org/bresenhams-circle-drawing-algorithm/

S" dessin.f" INCLUDED    \ the OpenGL routines
S" rand.f" INCLUDED    \ little Xor Shift pseudo-random generator

0 value xtemp \  xtemp=0
0 value ytemp \  ytemp=0
0 value radius \  radius=0

\ variables for plotting circle
0 value PC_X
0 value PC_Y
0 value Xchange
0 value Ychange
0 value RadiusError
0 value CX
0 value CY
0 value R
0 value pc_d

\ variables for plotting ellipse
0 value PE_X
0 value PE_Y
0 value RadiusError
0 value EllipseError
0 value TwoASquare
0 value TwoBSquare
0 value StoppingX
0 value StoppingY
0 value Xradius
0 value Yradius

\  INIT-MY-OPENGL          \ INITILIZE  OPENGL  VIEWPORT, MUST BE CLEANED, BUT WORKS

: BLUE    200 200 100 Color  ;

0e0  fvalue xn  0e0 fvalue yn

: SET-DOT    (  xn xy  --)
               s>f  fto yn   s>f  fto  xn    \ temporary buffer
          xn    80e0   F/    fto    X   \    x  f.
          yn    80e0   F/    fto    Y    \  y  f.    cr
         Point	        ;

 : P3  ( X Y --)   SET-DOT ;

 : P5  ( X Y --)   SET-DOT ;
 : P6  ( X Y --)   SET-DOT ;

: MS PAUSE ;

\ CODE FOR MISSING 0>
: 0>  0 > ;

\ ------------------------------------------
\ code for missing >=
\ ------------------------------------------
: >= ( n1 n2 -- flag )
  2dup >   \ copy both numbers, test for >
  rot rot  \ bring original 2 numbers to tos
  =        \ test for =
  or       \ or both flags for either or
;

\ missing <=
: <=  2dup < rot rot = or ;
 : F> F< 0= ;
 : F>S  ( --n) F>D  D>S  ;    \   float to integer)

: F2DUP         ( fs: r1 r2 -- r1 r2 r1 r2 )       \ W32F          Floating extra
\ *G Duplicate the top 2 FP stack entries.
                fover fover ;

0e FVALUE win.xleft
0e FVALUE win.xright
0e FVALUE win.ybot
0e FVALUE win.ytop
0e FVALUE win.xdif
0e FVALUE win.ydif

variable SXoffs
variable SXdiff
variable SYoffs
variable SYdiff

1.0e FVALUE PenX
1.0e FVALUE PenY

: SCALE         \ F: <x> <y> --- <>  <> --- <x> <y>
                win.ybot  F-  win.ydif F/  SYdiff @ S>F F*  F>S SYoffs @ +
                win.xleft F-  win.xdif F/  SXdiff @ S>F F*  F>S SXoffs @ +
                SWAP ;

\ -- Won't plot a point that doesn't fall within the window.
: PLOT-POINT  ;  \    PenX win.xleft win.xright       \ <color> --- <>
 \               F2DUP F> IF FSWAP THEN
  \                FWITHIN 0= IF DROP EXIT THEN
  \              PenY win.ybot  win.ytop
  \              F2DUP F> IF FSWAP THEN
  \                FWITHIN 0= IF DROP EXIT THEN
  \              PenX PenY SCALE ROT SET-DOT ;

\  : xypos        ( x y -- )
\                 to prev-y  to prev-x ;

create sinus
     0 ,  1745 ,  3490 ,  5234 ,  6976 ,  8716 , 10453 , 12187 , 13917 ,
 15643 , 17365 , 19081 , 20791 , 22495 , 24192 , 25882 , 27564 , 29237 ,
 30902 , 32567 , 34202 , 35837 , 37461 , 39073 , 40674 , 42262 , 43837 ,
 45399 , 46947 , 48481 , 50000 , 51504 , 52992 , 54464 , 55919 , 57358 ,
 58779 , 60182 , 61566 , 62932 , 64279 , 65606 , 66913 , 68200 , 69466 ,
 70711 , 71934 , 73135 , 74314 , 75471 , 76604 , 77715 , 78801 , 79864 ,
 80902 , 81915 , 82904 , 83867 , 84805 , 85717 , 86603 , 87462 , 88295 ,
 89101 , 89879 , 90631 , 91355 , 92050 , 92718 , 93358 , 93969 , 94552 ,
 95106 , 95630 , 96126 , 96593 , 97030 , 97437 , 97815 , 98163 , 98481 ,
 98769 , 99027 , 99255 , 99452 , 99619 , 99756 , 99863 , 99939 , 99985 ,
100000 ,

: (sinus)  4 * sinus + @ ;   ( angle - unsigned_sin*100000 )

: sin  ( angle - sin*100000 )
   dup abs dup
   360 > if  360 mod
         then dup
         91 < if (sinus)                                 \ < 90
              else dup 181 <
                   if 180 - abs (sinus)                   \ 91 - 179
                   else dup 271 <
                        if 180 - (sinus) negate            \ 180 - 269
                        else 360 - abs (sinus) negate      \ 270 - 360
                        then
                    then
                then
   swap 0< if negate
           then
 ;
\ 90 sin .s abort
: cos          ( angle - cos*100000 )
   90 - dup 0> >r
   abs sin r>
       if negate then
 ;

\ sinustest
800 value fromm 1 value scal1 1 value scal2
\ :  bbsinr   fromm  0 do  i  scal1 scal2  */   i sin 1000 /  300 + p5  loop ;  \  red
\ :  bbsinw  fromm  0 do  i  scal1 scal2  */    i sin 1000 /  300 + p3  loop ;  \ yellow white
\ :  bbsiny  fromm  0 do  i   i sin 1000 /  300 + p6  loop ;  \ white

\  : testsin  800 to fromm  20 0 do bbsinr  300 ms  bbsinw  100 ms loop  ;

\  :  circe   360  0 ?do   i cos 1000 /  200 +       i sin 1000 /  200 + p5  loop ;  \  red

:  CIR1  ( --)    \  ONLY FOR TESTING
           \   INIT-MY-OPENGL  ( --)
                  0.0E fto  X         0e0     fto  Y       Point
              0 0 p3  view

                360  0 do       i sin 1000 /  200 +
                                i cos 1000 /  200 +
                ( 2dup )   p3   \ 5 PAUSE
                                 \       ( BLACK p3 )
                loop
                   \ CR    ." -- END CIRCLE OK -- "
                 VIEW  1000 pause
            \ CR    ." ALL WELL "
            1000 pause     \  view  3000 pause view  \ 6000 pause
;  \  end circle

:  CIR2 ( --)    \  ONLY FOR TESTING
            \   INIT-MY-OPENGL  ( --)
           \ CR  ." CIRCLE 2"
                  0.0E fto  X         0e0     fto  Y       Point
              0 0 p3      view

                360  0 do       i sin 1000 /   30 +
                                i cos 1000 /   30 +
                ( 2dup )   p3   \ 5 PAUSE
                                 \       ( BLACK p3 )
                loop

                 VIEW  3000 pause view  3000 pause view  \ 6000 pause
;  \  end circle

: DrawCircle

CX PC_X +   CY PC_Y +  SET-DOT
CX PC_X -   CY PC_Y +  SET-DOT
CX PC_X -   CY PC_Y -  SET-DOT
CX PC_X +   CY PC_Y -  SET-DOT
CX PC_Y +   CY PC_X +  SET-DOT
CX PC_Y -   CY PC_X +  SET-DOT
CX PC_Y -   CY PC_X -  SET-DOT
CX PC_Y +   CY PC_X -  SET-DOT

;

: Bresenham_Circle

0 TO PC_X
R TO PC_Y
3 2 R * - to pc_d \ pc_d = 3-2*R
DrawCircle

BEGIN
   PC_Y PC_X >= \ WHILE PC_Y >= PC_X
WHILE
     \ For each pixel we will draw 8 pixels
     PC_X 1+ TO PC_X   \ PC_X = PC_X+1
     \ check for decision parameter and correspondingly update d, PC_X and PC_Y
     pc_d 0>   \ if pc_d>0
     if
       PC_Y 1- TO PC_Y \ PC_Y = PC_Y -1
       pc_d 4  PC_X PC_Y - * + 10 + to pc_d  \ pc_d = pc_d + 4*(PC_X - PC_Y) + 10
     else
       pc_d 4 PC_X * 6 + + to pc_d   \ pc_d = pc_d + 4*PC_X + 6
     then

     DrawCircle

REPEAT ;

: Plot4EllipsePoints

CX PE_X  + CY PE_Y +  set-dot
CX PE_X  - CY PE_Y +  set-dot
CX PE_X  - CY PE_Y -  SET-DOT
CX PE_X  + CY PE_Y -  SET-DOT

;

: Bresenham_Ellipse ( cx, cy, Xradius, Yradius -- ) \ Start Bresenham Ellipse algorithm

Xradius dup * 2 * to TwoASquare  \ TwoASquare = 2*Xradius*Xradius
Yradius dup * 2 * to TwoBSquare  \ TwoBSquare = 2*Yradius*Yradius

Xradius to PE_X    \ PE_X = Xradius
0       to PE_Y    \ PE_y = 0
Yradius dup * 1 2 Xradius * - * to Xchange \ Xchange = Yradius*Yradius*(1-2*Xradius)
Xradius dup * to Ychange                   \ Ychange = Xradius*Xradius
0 to EllipseError                          \ EllipseError = 0
TwoBSquare Xradius * to StoppingX          \ StoppingX = TwoSquare*Xradius
0                    to StoppingY          \ StoppingY = 0

Begin

   StoppingX StoppingY >=

While \ While StoppingX >= StoppingY

  Plot4EllipsePoints ( PE_X, PE_Y )
  PE_Y 1+ to PE_Y   \ PE_Y = PE_Y + 1
   StoppingY TwoASquare + to StoppingY       \ Stoppingx = StoppingX + TwoASquare
   EllipseError Ychange + to EllipseError    \ EllipseError = EllipseError + Ychange
   Ychange TwoASquare +   to Ychange         \ Ychange = Ychange + TwoASquare

   2 EllipseError * Xchange + 0>
   if \ if 2*EllipseError + Xchange > 0
      PE_X 1- to PE_X                        \ PE_X = PE_X - 1
      StoppingX TwoBSquare - to StoppingX    \ StoppingX = StoppingX - TwoBSquare
      EllipseError Xchange + to EllipseError \ EllipseError = EllipseError + Xchange
      Xchange TwoBSquare +   to Xchange      \ Xchange = Xchange + TwoBSquare
   then

Repeat

\ 1st point set is done; start the 2nd set of points

0 to PE_X                                   \ PE_X = 0
YRadius to PE_Y                             \ PE_Y = Yradius
Yradius dup * to Xchange                    \ Xchange = Yradius*Yradius
Xradius dup * 1 2 Yradius * - * to Ychange  \ Ychange = Xradius*Xradius*(1-2*Yradius)
0 to EllipseError                           \ EllipseError = 0
0 to StoppingX                              \ StoppingX = 0
TwoASquare Yradius * to StoppingY           \ StoppingY = TwoASquare * Yradius

Begin

StoppingX StoppingY <=

While  \ while StoppingX <= StoppingY
     Plot4EllipsePoints
     PE_X 1+ to PE_X                         \ PE_X = PE_X + 1
      StoppingX TwoBSquare + to StoppingX    \ StoppingX = StoppingX + TwoBSquare
      EllipseError Xchange + to EllipseError \ EllipseError = EllipseError + Xchange
      Xchange  TwoBSquare  + to Xchange      \ Xchange = Xchange + TwoBSquare

      2 EllipseError * Ychange + 0>
      if      \  if  2*EllipseError + Ychange > 0
          PE_Y 1- TO PE_Y                        \ PE_Y = PE_Y - 1
          StoppingY TwoASquare - to StoppingY    \ StoppingY = StoppingY - TwoASquare
          EllipseError Ychange + to EllipseError \ EllipseError = EllipseError + Ychange
          Ychange TwoASquare   + to Ychange      \ Ychange= Ychange + TwoASquare
      then
repeat
;

: circle  Dessin 2  PointSize

100 0 do
	255 Random 255 Random 255 Random Color
	500 Random 300 - TO CX 500 Random 250 - TO CY 300 Random to R
	Bresenham_Circle loop
	view

;

: Ellipse   Dessin 2 PointSize

100 0 do
         255 random 255 random 255 random color
         500 Random 300 - TO CX 500 Random 250 - TO CY 250 RANDOM to XRadius 250 RANDOM to YRadius
         Bresenham_Ellipse
        loop
        VIEW

;
Ellipse


!
! Copyright (C) 2002-2004 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!------------------------------------------------------------------------------!
    MODULE kinds
!------------------------------------------------------------------------------!

      IMPLICIT NONE
      SAVE
! ... kind definitions
      INTEGER, PARAMETER :: DP = selected_real_kind(14,200)
      INTEGER, PARAMETER :: sgl = selected_real_kind(6,30)
      INTEGER, PARAMETER :: i4b = selected_int_kind(9)
      PRIVATE
      PUBLIC :: i4b, sgl, DP, print_kind_info
!
!------------------------------------------------------------------------------!
!
    CONTAINS
!
!------------------------------------------------------------------------------!
!
!!   Print information about the used data types.
!
      SUBROUTINE print_kind_info (stdout)
!
!------------------------------------------------------------------------------!
!
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: stdout
!
        WRITE( stdout,'(/,T2,A)') 'DATA TYPE INFORMATION:'
!
        WRITE( stdout,'(/,T2,A,T78,A,2(/,T2,A,T75,I6),3(/,T2,A,T67,E14.8))') &
          'REAL: Data type name:', 'DP', '      Kind value:', kind(0.0_DP), &
          '      Precision:', precision(0.0_DP), &
          '      Smallest nonnegligible quantity relative to 1:', &
          epsilon(0.0_DP), '      Smallest positive number:', tiny(0.0_DP), &
          '      Largest representable number:', huge(0.0_DP)
        WRITE( stdout,'(/,T2,A,T78,A,2(/,T2,A,T75,I6),3(/,T2,A,T67,E14.8))') &
          '      Data type name:', 'sgl', '      Kind value:', kind(0.0_sgl), &
          '      Precision:', precision(0.0_sgl), &
          '      Smallest nonnegligible quantity relative to 1:', &
          epsilon(0.0_sgl), '      Smallest positive number:', tiny(0.0_sgl), &
          '      Largest representable number:', huge(0.0_sgl)
        WRITE( stdout,'(/,T2,A,T72,A,4(/,T2,A,T61,I20))') &
          'INTEGER: Data type name:', '(default)', '         Kind value:', &
          kind(0), '         Bit size:', bit_size(0), &
          '         Largest representable number:', huge(0)
        WRITE( stdout,'(/,T2,A,T72,A,/,T2,A,T75,I6,/)') 'LOGICAL: Data type name:', &
          '(default)', '         Kind value:', kind(.TRUE.)
        WRITE( stdout,'(/,T2,A,T72,A,/,T2,A,T75,I6,/)') &
          'CHARACTER: Data type name:', '(default)', '           Kind value:', &
          kind('C')
!
      END SUBROUTINE print_kind_info
!
!------------------------------------------------------------------------------!
    END MODULE kinds
!------------------------------------------------------------------------------!


! --- initialize parameters

      subroutine init_pars()

      use cdat

      implicit real*8 (a-h,o-z)

      open(5,file='IN')
      read(5,*) nbx,nby
      read(5,*) kmax,dt,kout
!      read(5,*) xmin,xmax
      read(5,*) amx,amy
      read(5,*) ax0,ay0,ax,ay,beta
      read(5,*) qx0,qy0
      read(5,*) px0,py0
      read(5,*) idum1
      read(5,*) order
      close(5)

!      ipot = 1 ! 1. HO 2. Morse

      end subroutine


module m_specialdata
  type MY_SPECIAL_DATA
     integer key
     integer index
  end type MY_SPECIAL_DATA
contains
  integer function QSORT_COMPARE (a,b)
    type(MY_SPECIAL_DATA), intent(in) :: a,b
    if ( a%key < b%key ) then
       QSORT_COMPARE = -1
    elseif ( a%key == b%key ) then
       QSORT_COMPARE = 0
    else
       QSORT_COMPARE = 1
    endif
  end function QSORT_COMPARE

end module m_specialdata

module m_testsorting
  use m_specialdata
contains

#define _QSORTARRAY_TYPE MY_SPECIAL_DATA
#define _QSORTARRAY_MODULE m_specialdata
#include "qsortarray_template.f90"

end module m_testsorting

! test_qsortarray_template --
!     Test program for sorting.f90.
!
!     See: sorting.f90 for more details
!
!     $Id: test_qsortarray_template.f90,v 1.1 2008/04/17 14:43:56 relaxmike Exp $
!
program test_qsortarray_template
  use m_specialdata, only : MY_SPECIAL_DATA , QSORT_COMPARE
  use m_testsorting, only : qsort_array
  implicit none
  integer :: assertTotalTestSuccess
  integer :: assertTotalTestFail
  integer :: assertTestIndex
  integer , parameter :: log_unit = 12
  call test_main ()
contains
  !
  ! Include support for unit tests.
  !
  include "test_support.f90"
  !
  ! test_main --
  !   The main subroutine for the tests.
  !
  subroutine test_main ()

    call log_startup ( "test_qsortarray_template.log" )
    call assert_startup ( )

    call test_sort_size2 ()
    call test_sort_size3 ()
    call test_sort_size4 ()
    call test_sort_size5 ()
    call test_sort_size6 ()
    call test_sort_perf ()

    !
    ! Shutdown the tests
    !
    call logmsg ( "Test suite completed" )
    call assert_shutdown ()
    call log_shutdown ()

  end subroutine test_main
  !
  ! test_sort_size6 --
  !   Sort an array of size 6.
  !
  subroutine test_sort_size6
    type(MY_SPECIAL_DATA), pointer :: array(:)
    integer, parameter :: array_size = 6
    integer i

    allocate(array(array_size))
    i = 0
    ! Compute a constant array to sort
    ! #1
    i = i + 1
    array(i)%key = 5
    array(i)%index = i
    ! #2
    i = i + 1
    array(i)%key = 4
    array(i)%index = i
    ! #3
    i = i + 1
    array(i)%key = 7
    array(i)%index = i
    ! #4
    i = i + 1
    array(i)%key = 1
    array(i)%index = i
    ! #5
    i = i + 1
    array(i)%key = 8
    array(i)%index = i
    ! #6
    i = i + 1
    array(i)%key = 12
    array(i)%index = i

    call qsort_array ( array, QSORT_COMPARE )
    !
    ! Check array content
    !
    call logmsg ( "Checking array of size 6" )
    call assert ( array(1)%key == 1 , "Wrong array value." )
    call assert ( array(2)%key == 4 , "Wrong array value." )
    call assert ( array(3)%key == 5 , "Wrong array value." )
    call assert ( array(4)%key == 7 , "Wrong array value." )
    call assert ( array(5)%key == 8 , "Wrong array value." )
    call assert ( array(6)%key == 12 , "Wrong array value." )

  end subroutine test_sort_size6
  !
  ! test_sort_size5 --
  !   Sort an array of size 5.
  !
  subroutine test_sort_size5
    type(MY_SPECIAL_DATA), pointer :: array(:)
    integer, parameter :: array_size = 5
    integer i

    allocate(array(array_size))
    i = 0
    ! Compute a constant array to sort
    ! #1
    i = i + 1
    array(i)%key = 5
    array(i)%index = i
    ! #2
    i = i + 1
    array(i)%key = 4
    array(i)%index = i
    ! #3
    i = i + 1
    array(i)%key = 7
    array(i)%index = i
    ! #4
    i = i + 1
    array(i)%key = 1
    array(i)%index = i
    ! #5
    i = i + 1
    array(i)%key = 8
    array(i)%index = i

    call qsort_array ( array, QSORT_COMPARE )
    !
    ! Check array content
    !
    call logmsg ( "Checking array of size 5" )
    call assert ( array(1)%key == 1 , "Wrong array value." )
    call assert ( array(2)%key == 4 , "Wrong array value." )
    call assert ( array(3)%key == 5 , "Wrong array value." )
    call assert ( array(4)%key == 7 , "Wrong array value." )
    call assert ( array(5)%key == 8 , "Wrong array value." )

  end subroutine test_sort_size5
  !
  ! test_sort_size4 --
  !   Sort an array of size 4.
  !
  subroutine test_sort_size4
    type(MY_SPECIAL_DATA), pointer :: array(:)
    integer, parameter :: array_size = 4
    integer i

    allocate(array(array_size))
    i = 0
    ! Compute a constant array to sort
    ! #1
    i = i + 1
    array(i)%key = 5
    array(i)%index = i
    ! #2
    i = i + 1
    array(i)%key = 4
    array(i)%index = i
    ! #3
    i = i + 1
    array(i)%key = 7
    array(i)%index = i
    ! #4
    i = i + 1
    array(i)%key = 1
    array(i)%index = i

    call qsort_array ( array, QSORT_COMPARE )
    !
    ! Check array content
    !
    call logmsg ( "Checking array of size 4" )
    call assert ( array(1)%key == 1 , "Wrong array value." )
    call assert ( array(2)%key == 4 , "Wrong array value." )
    call assert ( array(3)%key == 5 , "Wrong array value." )
    call assert ( array(4)%key == 7 , "Wrong array value." )

  end subroutine test_sort_size4
  !
  ! test_sort_size3 --
  !   Sort an array of size 3.
  !
  subroutine test_sort_size3
    type(MY_SPECIAL_DATA), pointer :: array(:)
    integer, parameter :: array_size = 3
    integer i

    allocate(array(array_size))
    i = 0
    ! Compute a constant array to sort
    ! #1
    i = i + 1
    array(i)%key = 5
    array(i)%index = i
    ! #2
    i = i + 1
    array(i)%key = 4
    array(i)%index = i
    ! #3
    i = i + 1
    array(i)%key = 7
    array(i)%index = i

    call qsort_array ( array, QSORT_COMPARE )
    !
    ! Check array content
    !
    call logmsg ( "Checking array of size 3" )
    call assert ( array(1)%key == 4 , "Wrong array value." )
    call assert ( array(2)%key == 5 , "Wrong array value." )
    call assert ( array(3)%key == 7 , "Wrong array value." )

  end subroutine test_sort_size3
  !
  ! test_sort_size2 --
  !   Sort an array of size 2.
  !
  subroutine test_sort_size2
    type(MY_SPECIAL_DATA), pointer :: array(:)
    integer, parameter :: array_size = 2
    integer i

    allocate(array(array_size))
    i = 0
    ! Compute a constant array to sort
    ! #1
    i = i + 1
    array(i)%key = 5
    array(i)%index = i
    ! #2
    i = i + 1
    array(i)%key = 4
    array(i)%index = i

    call qsort_array ( array, QSORT_COMPARE )
    !
    ! Check array content
    !
    call logmsg ( "Checking array of size 3" )
    call assert ( array(1)%key == 4 , "Wrong array value." )
    call assert ( array(2)%key == 5 , "Wrong array value." )

  end subroutine test_sort_size2
  !
  ! test_sort_perf --
  !   Test the performances of the sorting method.
  !
  subroutine test_sort_perf
    type(MY_SPECIAL_DATA), pointer :: array(:)
    !integer, parameter :: array_size = 1000000
    integer, parameter :: array_size = 1000
    integer i, time_start, time_end
    real :: randomvalue

    allocate(array(array_size))
    !
    ! Randomized array
    !
    do i=1,array_size
       call random_number( randomvalue )
       array(i)%key  = int ( randomvalue * 1000 )
       array(i)%index = i
    end do

    write(6,*) 'Unsorted:'
    write(6,'(I10,I10)') array(1:10)
    write(6,*) ' ...'
    write(6,'(I10,I10)') array(array_size-9:array_size)
    call system_clock(time_start)
    call qsort_array ( array, QSORT_COMPARE )
    call system_clock(time_end)
    write(6,*) 'Sort time = ',time_end-time_start,' ticks'
    write(6,'(I10,I10)') array(1:10)
    write(6,*) ' ...'
    write(6,'(I10,I10)') array(array_size-9:array_size)

  end subroutine test_sort_perf

end program test_qsortarray_template