c#######################################################################
c#      this is subroutine "SMBFCT" as given in : 'Computer Solutions  #
c#      of Large Sparse Positive Definite Systems' by A. George and    #
c#      J.W.-H. Liu, 1981, Prentice Hall, Inc. Englewood Cliffs,       #
c#      New Jersey 07632, pp. 149-151;                                 #
c#      Modified for my own                                            #
c#######################################################################

C----- SUBROUTINE SMBFCT
C****************************************************************          1.
C****************************************************************          2.
C*********     SMBFCT ..... SYMBOLIC FACTORIZATION       ********          3.
C****************************************************************          4.
C****************************************************************          5.
C                                                                          6.
C     PURPOSE - THIS ROUTINE PERFORMS SYMBOLIC FACTORIZATION               7.
C        ON A PERMUTED LINEAR SYSTEM AND IT ALSO SETS UP THE               8.
C        COMPRESSED DATA STRUCTURE FOR THE SYSTEM.                         9.
C                                                                         10.
C     INPUT PARAMETERS -                                                  11.
C        NEQNS - NUMBER OF EQUATIONS.                                     12.
C        (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE.                        13.
C        (PERM, INVP) - THE PERMUTATION VECTOR AND ITS INVERSE.           14.
C                                                                         15.
C     UPDATED PARAMETERS -                                                16.
C        MAXSUB - SIZE OF THE SUBSCRIPT ARRAY NZSUB.  ON RETURN,          17.
C               IT CONTAINS THE NUMBER OF SUBSCRIPTS USED                 18.
C                                                                         19.
C     OUTPUT PARAMETERS -                                                 20.
C        XLNZ - INDEX INTO THE NONZERO STORAGE VECTOR LNZ.                21.
C        (XNZSUB, NZSUB) - THE COMPRESSED SUBSCRIPT VECTORS.              22.
C        MAXLNZ - THE NUMBER OF NONZEROS FOUND.                           23.
C        FLAG - ERROR FLAG.  POSITIVE VALUE INDICATES THAT.               24.
C               NZSUB ARRAY IS TOO SMALL.                                 25.
C                                                                         26.
C     WORKING PARAMETERS -                                                27.
C        MRGLNK - A VECTOR OF SIZE NEQNS.  AT THE KTH STEP,               28.
C               MRGLNK(K), MRGLNK(MRGLNK(K)) , .........                  29.
C               IS A LIST CONTAINING ALL THOSE COLUMNS L(*,J)             30.
C               WITH J LESS THAN K, SUCH THAT ITS FIRST OFF-              31.
C               DIAGONAL NONZERO IS L(K,J).  THUS, THE                    32.
C               NONZERO STRUCTURE OF COLUMN L(*,K) CAN BE FOUND           33.
C               BY MERGING THAT OF SUCH COLUMNS L(*,J) WITH               34.
C               THE STRUCTURE OF A(*,K).                                  35.
C        RCHLNK - A VECTOR OF SIZE NEQNS.  IT IS USED TO ACCUMULATE       36.
C               THE STRUCTURE OF EACH COLUMN L(*,K).  AT THE              37.
C               END OF THE KTH STEP,                                      38.
C                   RCHLNK(K), RCHLNK(RCHLNK(K)), ........                39.
C               IS THE LIST OF POSITIONS OF NONZEROS IN COLUMN K          40.
C               OF THE FACTOR L.                                          41.
C        MARKER  - AN INTEGER VECTOR OF LENGTH NEQNS. IT IS USED          42.
C               TO TEST IF MASS SYMBOLIC ELIMINATION CAN BE               43.
C               PERFORMED.  THAT IS, IT IS USED TO CHECK WHETHER          44.
C               THE STRUCTURE OF THE CURRENT COLUMN K BEING               45.
C               PROCESSED IS COMPLETELY DETERMINED BY THE SINGLE          46.
C               COLUMN MRGLNK(K).                                         47.
C                                                                         48.
C****************************************************************         49.
C                                                                         50.
      SUBROUTINE  SMBFCT ( NEQNS, XADJ, ADJNCY, PERM, INVP,               51.
     1                     XLNZ, MAXLNZ, XNZSUB, NZSUB, MAXSUB,           52.
     1                     RCHLNK, MRGLNK, MARKER, FLAG )                 53.
C                                                                         54.
C****************************************************************         55.
C                                                                         56.
         INTEGER ADJNCY(*), INVP(*), MRGLNK(*), NZSUB(*),                 57.
     1           PERM(*), RCHLNK(*), MARKER(*)                            58.
         INTEGER XADJ(*), XLNZ(*), XNZSUB(*),                             59.
     1           FLAG, I, INZ, J, JSTOP, JSTRT, K, KNZ,                   60.
     1           KXSUB, MRGK, LMAX, M, MAXLNZ, MAXSUB,                    61.
     1           NABOR, NEQNS, NODE, NP1, NZBEG, NZEND,                   62.
     1           RCHM, MRKFLG                                             63.
C                                                                         64.
C****************************************************************         65.
C                                                                         66.
C       ------------------                                                67.
C       INITIALIZATION ...                                                68.
C       ------------------                                                69.
        NZBEG = 1                                                         70.
        NZEND = 0                                                         71.
        XLNZ(1) = 1                                                       72.
        DO 100 K = 1, NEQNS                                               73.
           MRGLNK(K) = 0                                                  74.
           MARKER(K) = 0                                                  75.
  100   CONTINUE                                                          76.
C       --------------------------------------------------                77.
C       FOR EACH COLUMN ......... .  KNZ COUNTS THE NUMBER                78.
C       OF NONZEROS IN COLUMN K ACCUMULATED IN RCHLNK.                    79.
C       --------------------------------------------------                80.
        NP1 = NEQNS + 1                                                   81.
        DO 1500  K = 1, NEQNS                                             82.
           KNZ = 0                                                        83.
           MRGK = MRGLNK(K)                                               84.
           MRKFLG = 0                                                     85.
           MARKER(K) = K                                                  86.
           IF (MRGK .NE. 0 ) MARKER(K) = MARKER(MRGK)                     87.
           XNZSUB(K) = NZEND                                              88.
           NODE = PERM(K)                                                 89.
           JSTRT = XADJ(NODE)                                             90.
           JSTOP = XADJ(NODE+1) - 1                                       91.
           IF (JSTRT.GT.JSTOP)  GO TO 1500                                92.
C          -------------------------------------------                    93.
C          USE RCHLNK TO LINK THROUGH THE STRUCTURE OF                    94.
C          A(*,K) BELOW DIAGONAL                                          95.
C          -------------------------------------------                    96.
           RCHLNK(K) = NP1                                                97.
           DO 300 J = JSTRT, JSTOP                                        98.
              NABOR = ADJNCY(J)                                           99.
              NABOR = INVP(NABOR)                                        100.
              IF ( NABOR .LE. K )  GO TO 300                             101.
                 RCHM = K                                                102.
  200            M = RCHM                                                103.
                 RCHM = RCHLNK(M)                                        104.
                 IF ( RCHM .LE. NABOR )  GO TO 200                       105.
                    KNZ = KNZ+1                                          106.
                    RCHLNK(M) = NABOR                                    107.
                    RCHLNK(NABOR) = RCHM                                 108.
                    IF ( MARKER(NABOR) .NE. MARKER(K) )  MRKFLG = 1      109.
  300      CONTINUE                                                      110.
C          --------------------------------------                        111.
C          TEST FOR MASS SYMBOLIC ELIMINATION ...                        112.
C          --------------------------------------                        113.
           LMAX = 0                                                      114.
           IF ( MRKFLG .NE. 0 .OR. MRGK .EQ. 0 ) GO TO 350               115.
           IF ( MRGLNK(MRGK) .NE. 0 ) GO TO 350                          116.
           XNZSUB(K) = XNZSUB(MRGK) + 1                                  117.
           KNZ = XLNZ(MRGK+1) - (XLNZ(MRGK) + 1)                         118.
           GO TO 1400                                                    119.
C          -----------------------------------------------               120.
C          LINK THROUGH EACH COLUMN I THAT AFFECTS L(*,K).               121.
C          -----------------------------------------------               122.
  350      I = K                                                         123.
  400      I = MRGLNK(I)                                                 124.
           IF (I.EQ.0)  GO TO 800                                        125.
              INZ = XLNZ(I+1) - (XLNZ(I)+1)                              126.
              JSTRT = XNZSUB(I) +  1                                     127.
              JSTOP = XNZSUB(I) + INZ                                    128.
              IF (INZ.LE.LMAX)  GO TO 500                                129.
                 LMAX = INZ                                              130.
                 XNZSUB(K) = JSTRT                                       131.
C             -----------------------------------------------            132.
C             MERGE STRUCTURE OF L(*,I) IN NZSUB INTO RCHLNK.            133.
C             -----------------------------------------------            134.
  500         RCHM = K                                                   135.
              DO 700 J = JSTRT, JSTOP                                    136.
                 NABOR = NZSUB(J)                                        137.
  600            M = RCHM                                                138.
                 RCHM = RCHLNK(M)                                        139.
                 IF (RCHM.LT.NABOR)  GO TO 600                           140.
                 IF (RCHM.EQ.NABOR)  GO TO 700                           141.
                    KNZ = KNZ+1                                          142.
                    RCHLNK(M) = NABOR                                    143.
                    RCHLNK(NABOR) = RCHM                                 144.
                    RCHM = NABOR                                         145.
  700         CONTINUE                                                   146.
              GO TO 400                                                  147.
C          ------------------------------------------------------        148.
C          CHECK IF SUBSCRIPTS DUPLICATE THOSE OF ANOTHER COLUMN.        149.
C          ------------------------------------------------------        150.
  800      IF (KNZ.EQ.LMAX)  GO TO 1400                                  151.
C             -----------------------------------------------            152.
C             OR IF TAIL OF K-1ST COLUMN MATCHES HEAD OF KTH.            153.
C             -----------------------------------------------            154.
              IF (NZBEG.GT.NZEND)  GO TO 1200                            155.
                 I = RCHLNK(K)                                           156.
                 DO 900 JSTRT=NZBEG,NZEND                                157.
                    IF (NZSUB(JSTRT)-I)  900, 1000, 1200                 158.
  900            CONTINUE                                                159.
                 GO TO 1200                                              160.
 1000            XNZSUB(K) = JSTRT                                       161.
                 DO 1100 J=JSTRT,NZEND                                   162.
                    IF (NZSUB(J).NE.I)  GO TO 1200                       163.
                    I = RCHLNK(I)                                        164.
                    IF (I.GT.NEQNS)  GO TO 1400                          165.
 1100            CONTINUE                                                166.
                 NZEND = JSTRT - 1                                       167.
C             ----------------------------------------                   168.
C             COPY THE STRUCTURE OF L(*,K) FROM RCHLNK                   169.
C             TO THE DATA STRUCTURE (XNZSUB, NZSUB).                     170.
C             ----------------------------------------                   171.
 1200         NZBEG = NZEND +  1                                         172.
              NZEND = NZEND + KNZ                                        173.
              IF (NZEND.GT.MAXSUB)  GO TO 1600                           174.
              I = K                                                      175.
              DO 1300 J=NZBEG,NZEND                                      176.
                 I = RCHLNK(I)                                           177.
                 NZSUB(J) = I                                            178.
                 MARKER(I) = K                                           179.
 1300         CONTINUE                                                   180.
              XNZSUB(K) = NZBEG                                          181.
              MARKER(K) = K                                              182.
C          --------------------------------------------------------      183.
C          UPDATE THE VECTOR MRGLNK.  NOTE COLUMN L(*,K) JUST FOUND      184.
C          IS REQUIRED TO DETERMINE COLUMN L(*,J), WHERE                 185.
C          L(J,K) IS THE FIRST NONZERO IN L(*,K) BELOW DIAGONAL.         186.
C          --------------------------------------------------------      187.
 1400      IF (KNZ.LE.1)  GO TO 1500                                     188.
              KXSUB = XNZSUB(K)                                          189.
              I = NZSUB(KXSUB)                                           190.
              MRGLNK(K) = MRGLNK(I)                                      191.
              MRGLNK(I) = K                                              192.
 1500      XLNZ(K+1) = XLNZ(K) + KNZ                                     193.
        MAXLNZ = XLNZ(NEQNS) - 1                                         194.
        MAXSUB = XNZSUB(NEQNS)                                           195.
        XNZSUB(NEQNS+1) = XNZSUB(NEQNS)                                  196.
        FLAG = 0                                                         197.
        RETURN                                                           198.
C       ----------------------------------------------------             199.
C       ERROR - INSUFFICIENT STORAGE FOR NONZERO SUBSCRIPTS.             200.
C       ----------------------------------------------------             201.
 1600   FLAG = 1                                                         202.
        RETURN                                                           203.
        END                                                              204.


program moving_window_stats
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use :: window_statistics
    implicit none
    type(window_stats_type) :: window_stats
    real(kind=dp), parameter :: x_min = 0.0, x_max = 20.0, x_incr = 0.5
    real(kind=dp) :: x

    call window_stats%init(5)
    x = x_min
    do while (x <= x_max)
        call window_stats%add_data(x)
        print *, x, window_stats%mean()
        x = x + x_incr
    end do

end program moving_window_stats


program dependency_tree
  !!  Test topological sort and dependency matrix for a DAG with multiple independent nodes.
  use iso_fortran_env, only : error_unit
  use scheduled_team_mod, only : scheduled_team_t
  implicit none

  type(scheduled_team_t) squad

  squad = scheduled_team_t( new_dag() )

  sync all
  if (this_image()==1) print *,"Test passed."

contains

  function new_dag() result(defined_dag)
    use dag_interface, only : dag

    type(dag) defined_dag

    integer, parameter :: n_nodes = 14, success=0

    integer :: i, row, istat
    integer, allocatable :: order(:) !! topological sort
    logical, allocatable :: mat(:,:) !! dependency matrix
    logical :: expected_mat(n_nodes,n_nodes) = .false.

    integer, parameter :: expected_order(*) = [(i,i=1,n_nodes)]
    character(len=*), parameter :: gray_square = 'shape=square,fillcolor="SlateGray1",style=filled'
    character(len=len(gray_square)), parameter :: silk_circle = 'shape=circle,fillcolor="cornsilk",style=filled'

    call defined_dag%set_vertices(n_nodes)
    call defined_dag%set_edges( 2,[integer::]) !2 depends on nothing
    call defined_dag%set_edges( 3,[integer::]) !3 depends on nothing
    call defined_dag%set_edges( 4,[3])  ; expected_mat(4,3)    = .true. !4 depends on  3
    call defined_dag%set_edges( 5,[4])  ; expected_mat(5,4)    = .true. !5 depends on  4
    call defined_dag%set_edges( 6,[3])  ; expected_mat(6,3)    = .true. !6 depends on  3
    call defined_dag%set_edges( 7,[4])  ; expected_mat(7,4)    = .true. !2 depends on  4
    call defined_dag%set_edges( 8,[5])  ; expected_mat(8,5)    = .true. !3 depends on  5
    call defined_dag%set_edges( 9,[6])  ; expected_mat(9,6)    = .true. !4 depends on  6
    call defined_dag%set_edges(10,[6,7]); expected_mat(10,6:7) = .true. !5 depends on  6 and 7
    call defined_dag%set_edges(11,[7,8]); expected_mat(11,7:8) = .true. !6 depends on  7 and 8
    call defined_dag%set_edges(12,[9])  ; expected_mat(12,9)   = .true. !2 depends on  9
    call defined_dag%set_edges(13,[10]) ; expected_mat(13,10)  = .true. !3 depends on 10
    call defined_dag%set_edges(14,[11]) ; expected_mat(14,11)  = .true. !4 depends on 11

    call defined_dag%toposort(order,istat)

    if (istat/=success) then
      write(error_unit, *) 'istat =', istat
      error stop
    end if

    if (any(order /= expected_order)) then
      write(error_unit, *) 'order =', order
      error stop
    end if

    do i = 1, n_nodes
      call defined_dag%set_vertex_info(i, attributes = merge(gray_square, silk_circle, any(i==[1,2,12,13,14])))
    end do

  end function

end program dependency_tree


! { dg-do link }
! PR 30415 - minloc and maxloc for integer kinds=1 and 2 were missing
! Test case by Harald Anlauf
program gfcbug55
  integer(kind=1) :: i1(4) = 1
  integer(kind=2) :: i2(4) = 1
  print *, minloc(i1), maxloc(i1)
  print *, minloc(i2), maxloc(i2)
end program gfcbug55


program test_iso_fortran_env
use iso_fortran_env, only: int32, int64, real32, real64
implicit none
real(real32) :: r4
real(real64) :: r8
integer(int32) :: i4
integer(int64) :: i8
real(real32), parameter :: r4p = 1._real32
integer(int32), parameter :: i4p = 1_int32
r4 = 1._real32
r8 = 1._real64
i4 = 1_int32
i8 = 1_int64
!if (kind(r4) /= 4) error stop
!if (kind(r8) /= 8) error stop
!if (kind(i4) /= 4) error stop
!if (kind(i8) /= 8) error stop
end program


*       Home work #2
*       Question (3)
*       Write a program to find the root of a function using
*       initial Guess X0

*       (iii)f(x)=cos(x)   X0=1

        func(X0)=cos(X0)
        TOLX=1.E-03
        X0=1
        Dx=0.01
        Iter=0
        Print*,'I    root     '
10      continue
        Iter=Iter+1
        X0=X0+Dx
        write(*,*)Iter,X0
        If(Abs(func(X0)).GT.TOLX) goto 10
        stop
        end


cc Copyright (C) 2010-2011: Leslie Greengard, Zydrunas Gimbustas
cc and Manas Rachh
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.

c
c   Laplace FMM in R^2: evaluate all pairwise particle
c   interactions (ignoring self-interaction)
c   and interactions with targets.
c
c   We use log(r) for the Green's function.
c   Self-interactions are not included
c
c   l2d: charge and dipstr are complex valued, x in \R^2
c
c   \phi(x_i) = \sum_{j\ne i} charge_j log|x_i-x_j}
c   + dipstr_j/x_i - x_j
c
c

      subroutine lfmm2d_st_c_p_vec(nd,eps,ns,sources,
     1            charge,pot,nt,targ,pottarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns)

      complex *16 pot(nd,ns)
      complex *16 pottarg(nd,nt)

c
cc     temporary variables
c
      complex *16 dipstr(nd)
      complex *16 grad(nd,2),gradtarg(nd,2)
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 1

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine lfmm2d_st_c_g_vec(nd,eps,ns,sources,
     1            charge,pot,grad,nt,targ,pottarg,gradtarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt)

c
cc     temporary variables
c
      complex *16 dipstr(nd)
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 2

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine lfmm2d_st_c_h_vec(nd,eps,ns,sources,
     1            charge,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   hess(nd,3,ns)    : hessian at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c   hesstarg(nd,3,nt): hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns),hess(nd,3,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt),hesstarg(nd,3,nt)

c
cc     temporary variables
c
      complex *16 dipstr(nd)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      ifpghtarg = 3

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine lfmm2d_st_d_p_vec(nd,eps,ns,sources,
     1            dipstr,pot,nt,targ,pottarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(nd,ns)

      complex *16 pot(nd,ns)
      complex *16 pottarg(nd,nt)

c
cc     temporary variables
c
      complex *16 charge(nd)
      complex *16 grad(nd,2),gradtarg(nd,2)
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine lfmm2d_st_d_g_vec(nd,eps,ns,sources,
     1            dipstr,pot,grad,nt,targ,pottarg,gradtarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt)

c
cc     temporary variables
c
      complex *16 charge(nd)
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine lfmm2d_st_d_h_vec(nd,eps,ns,sources,
     1            dipstr,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   hess(nd,3,ns)    : hessian at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c   hesstarg(nd,3,nt): hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns),hess(nd,3,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt),hesstarg(nd,3,nt)

c
cc     temporary variables
c
      complex *16 charge(nd)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine lfmm2d_st_cd_p_vec(nd,eps,ns,sources,charge,
     1            dipstr,pot,nt,targ,pottarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns),dipstr(nd,ns)

      complex *16 pot(nd,ns)
      complex *16 pottarg(nd,nt)

c
cc     temporary variables
c
      complex *16 grad(nd,2),gradtarg(nd,2)
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine lfmm2d_st_cd_g_vec(nd,eps,ns,sources,charge,
     1            dipstr,pot,grad,nt,targ,pottarg,gradtarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns),dipstr(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt)

c
cc     temporary variables
c
      complex *16 hess(nd,3),hesstarg(nd,3)
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine lfmm2d_st_cd_h_vec(nd,eps,ns,sources,charge,
     1            dipstr,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg)
c----------------------------------------------
c   INPUT PARAMETERS:
c   nd            : number of expansions
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(nd,ns)    : charge strengths
c   dipstr(nd,ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(nd,ns)       : potential at the source locations
c   grad(nd,2,ns)    : gradients at the source locations
c   hess(nd,3,ns)    : hessian at the source locations
c   pottarg(nd,nt)   : potential at the target locations
c   gradtarg(nd,2,nt): gradient at the target locations
c   hesstarg(nd,3,nt): hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      integer nd
      real *8 eps
      integer ns,nt
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(nd,ns),dipstr(nd,ns)

      complex *16 pot(nd,ns),grad(nd,2,ns),hess(nd,3,ns)
      complex *16 pottarg(nd,nt),gradtarg(nd,2,nt),hesstarg(nd,3,nt)

c
cc     temporary variables
c
      integer ifcharge,ifdipole,iper
      integer ifpgh,ifpghtarg

      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3

      call lfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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


module advance_module

  use multifab_module
  use bds_module

  implicit none

  private

  public :: advance

contains

  subroutine advance(phio,phin,dx,dt)

    type(multifab) , intent(in   ) :: phio
    type(multifab) , intent(inout) :: phin
    real(kind=dp_t), intent(in   ) :: dx
    real(kind=dp_t), intent(in   ) :: dt

    ! local variables
    integer i,dm

    ! an array of multifabs; one for each direction
    type(multifab) :: umac(phio%dim)

    ! vector of dx needed for bds routine
    real(kind=dp_t) :: dx_vec(phio%dim)

    logical :: is_conservative(1)

    dm = phio%dim

    dx_vec(:) = dx

    is_conservative(:) = .true.

    do i=1,dm
       call multifab_build_edge(umac(i),phio%la,1,1,i)
       call multifab_setval(umac(i),1.d0,all=.true.)
    end do

    call bds(phio,phin,umac,dx_vec,dt,is_conservative)

    call multifab_fill_boundary(phin)

    ! make sure to destroy the multifab or you'll leak memory
    do i=1,dm
       call multifab_destroy(umac(i))
    end do

  end subroutine advance

end module advance_module


C STATISTICS: determine statistics for a spectrum
C
       implicit    NONE
C
C Include information on standard array sizes etc.
       include '../include/spec_global.inc'
       include '../include/spec_pars.inc'
C
C Local variables
C   file identifiers
       integer    id
C   status return
       integer    status
C   file and directory name(s)
       character  file*100, dir*100
C   option string
       character  option*80
C   data
       real*4     x(max_ndata)
C   statistics
       real*4     x_min, x_max, x_sum, x_average, x_del
C   number of data/columns and counters
       integer    ndata, ncols, n, nc, ic
C Functions
       integer    chr_lenb
       logical    chr_cmatch

C setup for input
       call io_initio
       call cmd_extpars( 'SPECTRUM', dir, status )
       call cmd_getiline( 'statistics',
     *      dir(1:chr_lenb(dir))//tool_definitions, status)

C find input file name and allocate file
       call cmd_items( 'infile', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id, status)

C find option string if present
       call cmd_items( 'option', option, status )
       call cmd_itemi( 'col', 1, ic, status )

C enquire number of columns and loop for each
       call spec_hd_enqi( id, 'ncols', ncols, status )
       do nc=1,ncols
C .. read data
         call spec_get_data( id, nc, x, ndata, status)
         x_max = -1.0E+30
         x_min =  1.0E+30
         x_sum = 0.0
         do n=1,ndata
           x_max = max(x_max,x(n))
           x_min = min(x_min,x(n))
           x_sum = x_sum + x(n)
         end do
         x_del = (x_max - x_min) / float( ndata - 1 )
         x_average = x_sum / float( ndata )
         if (chr_lenb(option).eq.0) then
           print 10,nc,x_min,x_max,x_sum,x_average
   10      format(1X,'.. column ',i1,' min/max = ',1P2E12.3,
     *             '  sum = ',1PE12.3,'  average = ',1PE12.3 )
         else if (nc.eq.ic) then
           if (chr_cmatch(option(1:chr_lenb(option)),'DEL')) then
             print *,x_del
           elseif (chr_cmatch(option(1:chr_lenb(option)),'SUM')) then
             print *,x_sum
           elseif (chr_cmatch(option(1:chr_lenb(option)),'MAX')) then
             print *,x_max
           elseif (chr_cmatch(option(1:chr_lenb(option)),'MIN')) then
             print *,x_min
           elseif (chr_cmatch(option(1:chr_lenb(option)),'AVG')) then
             print *,x_average
           end if
         end if
       end do

C deallocate spectrum
       call spec_deallocate( id, status )

       end


*DECK SPBFA
      SUBROUTINE SPBFA (ABD, LDA, N, M, INFO)
C***BEGIN PROLOGUE  SPBFA
C***PURPOSE  Factor a real symmetric positive definite matrix stored in
C            band form.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2
C***TYPE      SINGLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SPBFA factors a real symmetric positive definite matrix
C     stored in band form.
C
C     SPBFA is usually called by SPBCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C
C     On Entry
C
C        ABD     REAL(LDA, N)
C                the matrix to be factored.  The columns of the upper
C                triangle are stored in the columns of ABD and the
C                diagonals of the upper triangle are stored in the
C                rows of ABD .  See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. M + 1 .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C                0 .LE. M .LT. N .
C
C     On Return
C
C        ABD     an upper triangular matrix  R , stored in band
C                form, so that  A = TRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  if the leading minor of order  K  is not
C                     positive definite.
C
C     Band Storage
C
C           If  A  is a symmetric positive definite band matrix,
C           the following program segment will set up the input.
C
C                   M = (band width above diagonal)
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-M)
C                      DO 10 I = I1, J
C                         K = I-J+M+1
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SPBFA
      INTEGER LDA,N,M,INFO
      REAL ABD(LDA,*)
C
      REAL SDOT,T
      REAL S
      INTEGER IK,J,JK,K,MU
C***FIRST EXECUTABLE STATEMENT  SPBFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            IK = M + 1
            JK = MAX(J-M,1)
            MU = MAX(M+2-J,1)
            IF (M .LT. MU) GO TO 20
            DO 10 K = MU, M
               T = ABD(K,J) - SDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1)
               T = T/ABD(M+1,JK)
               ABD(K,J) = T
               S = S + T*T
               IK = IK - 1
               JK = JK + 1
   10       CONTINUE
   20       CONTINUE
            S = ABD(M+1,J) - S
            IF (S .LE. 0.0E0) GO TO 40
            ABD(M+1,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END


subroutine regcoil_evaluate_coil_surface()

  ! This subroutine takes the arrays rmnc_coil, zmns_coil, etc, and evaluates the position vector r_coil
  ! and its first and second derivatives with respect to theta and zeta.

  use regcoil_variables
  use stel_kinds

  implicit none

  integer :: imn, m, n, iflag, j
  real(dp) :: rmnc, rmns, zmnc, zmns
  real(dp) :: angle, sinangle, cosangle, dsinangledtheta, dcosangledtheta, dsinangledzeta, dcosangledzeta
  real(dp) :: d2sinangledtheta2, d2sinangledthetadzeta, d2sinangledzeta2, d2cosangledtheta2, d2cosangledthetadzeta, d2cosangledzeta2
  real(dp) :: angle2, sinangle2, cosangle2, dsinangle2dzeta, dcosangle2dzeta, d2sinangle2dzeta2, d2cosangle2dzeta2
  real(dp), dimension(:,:), allocatable :: major_R_squared
  integer :: itheta, izeta
  integer :: tic, toc, countrate
  real(dp), dimension(:,:), allocatable :: sin_m_theta, cos_m_theta, sin_n_zeta, cos_n_zeta

  call system_clock(tic,countrate)

  allocate(sin_m_theta(mnmax_coil,ntheta_coil))
  allocate(cos_m_theta(mnmax_coil,ntheta_coil))
  allocate(sin_n_zeta( mnmax_coil,nzetal_coil))
  allocate(cos_n_zeta( mnmax_coil,nzetal_coil))
  do itheta = 1,ntheta_coil
     sin_m_theta(:,itheta) = sin(xm_coil * theta_coil(itheta))
     cos_m_theta(:,itheta) = cos(xm_coil * theta_coil(itheta))
  end do
  do izeta = 1,nzetal_coil
     sin_n_zeta(:,  izeta) = sin(xn_coil * zetal_coil(izeta))
     cos_n_zeta(:,  izeta) = cos(xn_coil * zetal_coil(izeta))
  end do

  r_coil = 0
  drdtheta_coil = 0
  drdzeta_coil = 0
  d2rdtheta2_coil = 0
  d2rdthetadzeta_coil = 0
  d2rdzeta2_coil = 0

  do izeta = 1,nzetal_coil
     angle2 = zetal_coil(izeta)
     sinangle2 = sin(angle2)
     cosangle2 = cos(angle2)
     dsinangle2dzeta = cosangle2
     dcosangle2dzeta = -sinangle2
     d2sinangle2dzeta2 = -sinangle2
     d2cosangle2dzeta2 = -cosangle2
     do imn = 1, mnmax_coil
        m = xm_coil(imn)
        n = xn_coil(imn)
        rmnc = rmnc_coil(imn)
        rmns = rmns_coil(imn)
        zmnc = zmnc_coil(imn)
        zmns = zmns_coil(imn)
        do itheta = 1,ntheta_coil
           !angle = m*theta_coil(itheta) - n*zetal_coil(izeta)
           !sinangle = sin(angle)
           !cosangle = cos(angle)
           ! Trig angle sum formulae for angle = m*theta_coil(itheta) - n*zetal_coil(izeta):
           sinangle = sin_m_theta(imn,itheta) * cos_n_zeta(imn,izeta) - cos_m_theta(imn,itheta) * sin_n_zeta(imn,izeta)
           cosangle = cos_m_theta(imn,itheta) * cos_n_zeta(imn,izeta) + sin_m_theta(imn,itheta) * sin_n_zeta(imn,izeta)
           !if (abs(sinangle - sin(angle)) > 1d-10) stop "Error sin"
           !if (abs(cosangle - cos(angle)) > 1d-10) stop "Error cos"
           dsinangledtheta = cosangle*m
           dcosangledtheta = -sinangle*m
           dsinangledzeta = -cosangle*n
           dcosangledzeta = sinangle*n

           r_coil(1,itheta,izeta) = r_coil(1,itheta,izeta) + rmnc * cosangle * cosangle2 + rmns * sinangle * cosangle2
           r_coil(2,itheta,izeta) = r_coil(2,itheta,izeta) + rmnc * cosangle * sinangle2 + rmns * sinangle * sinangle2
           r_coil(3,itheta,izeta) = r_coil(3,itheta,izeta) + zmns * sinangle             + zmnc * cosangle

           drdtheta_coil(1,itheta,izeta) = drdtheta_coil(1,itheta,izeta) + rmnc * dcosangledtheta * cosangle2 + rmns * dsinangledtheta * cosangle2
           drdtheta_coil(2,itheta,izeta) = drdtheta_coil(2,itheta,izeta) + rmnc * dcosangledtheta * sinangle2 + rmns * dsinangledtheta * sinangle2
           drdtheta_coil(3,itheta,izeta) = drdtheta_coil(3,itheta,izeta) + zmns * dsinangledtheta + zmnc * dcosangledtheta

           drdzeta_coil(1,itheta,izeta) = drdzeta_coil(1,itheta,izeta) + rmnc * (dcosangledzeta * cosangle2 + cosangle * dcosangle2dzeta) &
                + rmns * (dsinangledzeta * cosangle2 + sinangle * dcosangle2dzeta)
           drdzeta_coil(2,itheta,izeta) = drdzeta_coil(2,itheta,izeta) + rmnc * (dcosangledzeta * sinangle2 + cosangle * dsinangle2dzeta) &
                + rmns * (dsinangledzeta * sinangle2 + sinangle * dsinangle2dzeta)
           drdzeta_coil(3,itheta,izeta) = drdzeta_coil(3,itheta,izeta) + zmns * dsinangledzeta + zmnc * dcosangledzeta

           ! 2nd derivatives are only constructed on 1 field period.
           if (izeta > nzeta_coil) cycle

           d2sinangledtheta2  = -m*m*sinangle
           d2sinangledthetadzeta = m*n*sinangle
           d2sinangledzeta2  = -n*n*sinangle
           d2cosangledtheta2  = -m*m*cosangle
           d2cosangledthetadzeta = m*n*cosangle
           d2cosangledzeta2  = -n*n*cosangle

           d2rdtheta2_coil(1,itheta,izeta) = d2rdtheta2_coil(1,itheta,izeta) + rmnc * d2cosangledtheta2 * cosangle2 + rmns * d2sinangledtheta2 * cosangle2
           d2rdtheta2_coil(2,itheta,izeta) = d2rdtheta2_coil(2,itheta,izeta) + rmnc * d2cosangledtheta2 * sinangle2 + rmns * d2sinangledtheta2 * sinangle2
           d2rdtheta2_coil(3,itheta,izeta) = d2rdtheta2_coil(3,itheta,izeta) + zmns * d2sinangledtheta2 + zmnc * d2cosangledtheta2

           d2rdthetadzeta_coil(1,itheta,izeta) = d2rdthetadzeta_coil(1,itheta,izeta) + rmnc * (d2cosangledthetadzeta * cosangle2 + dcosangledtheta * dcosangle2dzeta) &
                + rmns * (d2sinangledthetadzeta * cosangle2 + dsinangledtheta * dcosangle2dzeta)
           d2rdthetadzeta_coil(2,itheta,izeta) = d2rdthetadzeta_coil(2,itheta,izeta) + rmnc * (d2cosangledthetadzeta * sinangle2 + dcosangledtheta * dsinangle2dzeta) &
                + rmns * (d2sinangledthetadzeta * sinangle2 + dsinangledtheta * dsinangle2dzeta)
           d2rdthetadzeta_coil(3,itheta,izeta) = d2rdthetadzeta_coil(3,itheta,izeta) + zmns * d2sinangledthetadzeta + zmnc * d2cosangledthetadzeta

           d2rdzeta2_coil(1,itheta,izeta) = d2rdzeta2_coil(1,itheta,izeta) + rmnc * (d2cosangledzeta2 * cosangle2 + dcosangledzeta * dcosangle2dzeta &
                + dcosangledzeta * dcosangle2dzeta + cosangle * d2cosangle2dzeta2) &
                + rmns * (d2sinangledzeta2 * cosangle2 + dsinangledzeta * dcosangle2dzeta &
                + dsinangledzeta * dcosangle2dzeta + sinangle * d2cosangle2dzeta2)
           d2rdzeta2_coil(2,itheta,izeta) = d2rdzeta2_coil(2,itheta,izeta) + rmnc * (d2cosangledzeta2 * sinangle2 + dcosangledzeta * dsinangle2dzeta &
                + dcosangledzeta * dsinangle2dzeta + cosangle * d2sinangle2dzeta2) &
                + rmns * (d2sinangledzeta2 * sinangle2 + dsinangledzeta * dsinangle2dzeta &
                + dsinangledzeta * dsinangle2dzeta + sinangle * d2sinangle2dzeta2)
           d2rdzeta2_coil(3,itheta,izeta) = d2rdzeta2_coil(3,itheta,izeta) + zmns * d2sinangledzeta2 + zmnc * d2cosangledzeta2
        end do
     end do
  end do

  deallocate(sin_m_theta, cos_m_theta, sin_n_zeta, cos_n_zeta)

  call system_clock(toc)
  if (verbose) print *,"  Evaluating coil surface & derivatives:",real(toc-tic)/countrate," sec."

!!$  print *,"mnmax_coil:",mnmax_coil
!!$  print *,"xm_coil:",xm_coil
!!$  print *,"xn_coil:",xn_coil
!!$  print *,"rmnc_coil:",rmnc_coil
!!$  print *,"zmns_coil:",zmns_coil
!!$  print *,"r_coil(1,:,:):"
!!$  do j = 1,ntheta_coil
!!$     print *,r_coil(1,j,:)
!!$  end do
!!$  print *,"r_coil(2,:,:):"
!!$  do j = 1,ntheta_coil
!!$     print *,r_coil(2,j,:)
!!$  end do
!!$  print *,"r_coil(3,:,:):"
!!$  do j = 1,ntheta_coil
!!$     print *,r_coil(3,j,:)
!!$  end do

  ! Evaluate cross product:
  normal_coil(1,:,:) = drdzeta_coil(2,:,:) * drdtheta_coil(3,:,:) - drdtheta_coil(2,:,:) * drdzeta_coil(3,:,:)
  normal_coil(2,:,:) = drdzeta_coil(3,:,:) * drdtheta_coil(1,:,:) - drdtheta_coil(3,:,:) * drdzeta_coil(1,:,:)
  normal_coil(3,:,:) = drdzeta_coil(1,:,:) * drdtheta_coil(2,:,:) - drdtheta_coil(1,:,:) * drdzeta_coil(2,:,:)

  if (allocated(norm_normal_coil)) deallocate(norm_normal_coil)
  allocate(norm_normal_coil(ntheta_coil, nzeta_coil),stat=iflag)
  if (iflag .ne. 0) stop 'Allocation error! regcoil_init_coil_surface 11'
  norm_normal_coil = sqrt(normal_coil(1,:,1:nzeta_coil)**2 + normal_coil(2,:,1:nzeta_coil)**2 &
       +  normal_coil(3,:,1:nzeta_coil)**2)

  area_coil = nfp * dtheta_coil * dzeta_coil * sum(norm_normal_coil)

  ! Compute coil surface volume using \int (1/2) R^2 dZ dzeta.
  ! These quantities will be evaluated on the half theta grid, which is the natural grid for dZ,
  ! but we will need to interpolate R^2 from the full to half grid.
  allocate(major_R_squared(ntheta_coil,nzetal_coil))
  major_R_squared = r_coil(1,:,:)*r_coil(1,:,:) + r_coil(2,:,:)*r_coil(2,:,:)
  ! First handle the interior of the theta grid:
  volume_coil = sum((major_R_squared(1:ntheta_coil-1,:) + major_R_squared(2:ntheta_coil,:)) * (0.5d+0) & ! R^2, interpolated from full to half grid
       * (r_coil(3,2:ntheta_coil,:)-r_coil(3,1:ntheta_coil-1,:))) ! dZ
  ! Add the contribution from the ends of the theta grid:
  volume_coil = volume_coil + sum((major_R_squared(1,:) + major_R_squared(ntheta_coil,:)) * (0.5d+0) & ! R^2, interpolated from full to half grid
       * (r_coil(3,1,:)-r_coil(3,ntheta_coil,:))) ! dZ
  volume_coil = abs(volume_coil * dzeta_coil / 2) ! r includes all nfp periods already, so no factor of nfp needed.
  deallocate(major_R_squared)
  if (verbose) print "(a,es10.3,a,es10.3,a)"," Coil surface area:",area_coil," m^2. Volume:",volume_coil," m^3."

end subroutine  regcoil_evaluate_coil_surface


!==========================================================================
elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, &
				       ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t)
!==========================================================================
!
!  Calculates the following three derivatives of Conservative Temperature.
!  These derivatives are done with respect to in-situ temperature t (in the
!  case of CT_T_wrt_t) or at constant in-situ tempertature (in the cases of
!  CT_SA_wrt_t and CT_P_wrt_t).
!   (1) CT_SA_wrt_t, the derivative of CT with respect to Absolute Salinity
!       at constant t and p, and
!   (2) CT_T_wrt_t, derivative of CT with respect to in-situ temperature t
!       at constant SA and p.
!   (3) CT_P_wrt_t, derivative of CT with respect to pressure P (in Pa) at
!       constant SA and t.
!
!  This function uses the full Gibbs function. Note that this function
!  avoids the NaN that would exist in CT_SA_wrt_t at SA = 0 if it were
!  evaluated in the straightforward way from the derivatives of the Gibbs
!  function function.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  t   =  in-situ temperature (ITS-90)                            [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar)
!
!  CT_SA_wrt_t  =  The first derivative of Conservative Temperature with
!                  respect to Absolute Salinity at constant t and p.
!                                              [ K/(g/kg)]  i.e. [ K kg/g ]
!  CT_T_wrt_t  =  The first derivative of Conservative Temperature with
!                 respect to in-situ temperature, t, at constant SA and p.
!                                                              [ unitless ]
!  CT_P_wrt_t  =  The first derivative of Conservative Temperature with
!                 respect to pressure P (in Pa) at constant SA and t.
!                                                                  [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs, gsw_pt0_from_t

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac, gsw_t0, rec_db2pa

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p
real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t

real (r8) :: g_sa_mod, g_sa_t_mod, pt0, x, y, y_pt, z

pt0 = gsw_pt0_from_t(sa,t,p)

if (present(ct_sa_wrt_t)) then

    x = sqrt(gsw_sfac*sa)
    y = 0.025_r8*t
    y_pt = 0.025_r8*pt0
    z = rec_db2pa*p   ! the input pressure (p) is sea pressure in units of dbar

    g_sa_t_mod = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + &
            z*(-687.913805923122_r8 + z*(249.375342232496_r8 + &
	    z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + &
            x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + &
	    x*(-980.14153344888_r8 + 220.542973797483_r8*x) + &
            y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + &
	    y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - &
            90.6734234051316_r8*z) + z*(-525.876123559641_r8 + &
	    (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + &
            y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + &
	    z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + &
            y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + &
	    y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + &
            y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + &
            y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + &
	    25.56203650166196_r8*y) + z*(-2381.829935897496_r8 + &
	    (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + &
            z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + &
	    (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + &
            z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + &
            z*(-713.258224830552_r8 + &
	    (176.8161433232_r8 - 31.68006188846728_r8*z)*z))))
    g_sa_t_mod = 0.5_r8*gsw_sfac*0.025_r8*g_sa_t_mod

    g_sa_mod = 8645.36753595126_r8 + &
            x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + &
            y_pt*(2175.341332000392_r8 + y_pt*(-274.2290036817964_r8 + &
            y_pt*(197.4670779425016_r8 + y_pt*(-68.5590309679152_r8 + &
	    9.98788038278032_r8*y_pt)))) + &
            x*(-5458.34205214835_r8 - 980.14153344888_r8*y_pt + &
            x*(2247.60742726704_r8 - 340.1237483177863_r8*x + &
	    220.542973797483_r8*y_pt))) + &
            y_pt*(-1480.222530425046_r8 + &
            y_pt*(-129.1994027934126_r8 + &
            y_pt*(-30.0682112585625_r8 + y_pt*(2.626801985426835_r8 ))))) + &
            y_pt*(1187.3715515697959_r8 + &
            y_pt*(1760.062705994408_r8 + y_pt*(-450.535298526802_r8 + &
            y_pt*(182.8520895502518_r8 + y_pt*(-43.3206481750622_r8 + &
	    4.26033941694366_r8*y_pt)))))
    g_sa_mod = 0.5_r8*gsw_sfac*g_sa_mod

    ct_sa_wrt_t = (g_sa_mod - (gsw_t0+pt0)*g_sa_t_mod)/gsw_cp0

end if

if (present(ct_t_wrt_t)) &
    ct_t_wrt_t = -(gsw_t0+pt0)*gsw_gibbs(0,2,0,sa,t,p)/gsw_cp0

if (present(ct_p_wrt_t)) &
    ct_p_wrt_t = -(gsw_t0+pt0)*gsw_gibbs(0,1,1,sa,t,p)/gsw_cp0

return
end subroutine

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


c=======================================================================
c
c     subroutine ALLOCVOLRFR
c
c     This function implements Volatility-constrained optimization with
c     risk-free rate
c
c     Max[ w'*rho ]
c      s.t.
c     w'*Q*w <= sigma2         (volatility constraint)
c     C*w <= b                 (linear constraints)
c     Cinf <= w <= Csup        (lower/upper bounds)
c     Cinf <= w(0) <= Csup
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE allocvolrfr ( n, cov, rho,
     &                         neq, nin, ccst, bcst, cinf, csup,
     &                         volb, volp, rfr, cinfrfr, csuprfr,
     &                         iwork, dwork, wopt, lambda, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       cov    : covariance matrix (n*n)                          double
c       rho    : expected returns vector (n)                      double
c       neq    : number equality constraints                     integer
c       nin    : number inequality constraints                   integer
c       ccst   : matrix of constraints (nasset*(neq+nin))         double
c       bcst   : vector initial of constraints (neq+nin)          double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       volb   : volatility budget (>0)                           double
c       volp   : precision of the volatility cst. (>0)            double
c       rfr    : risk-free rate                                   double
c       cinfrfr: risk-free rate lower bound                       double
c       csuprfr: risk-free rate upper bound                       double
c
c     WORKSPACE
c       iwork  : 3*n + 2*nin + neq + 7                           integer
c       dwork  : n*( 2*n+neq+nin+13 ) + 4*nin + 2*neq + 12        double
c
c     OUTPUT
c       wopt   : optimal portfolio (n+1)                          double
c       lambda : lagrange multiplier corresponding to the risk
c                budget constraint (shadow cost)                  double
c       info   : diagnostic argument                             integer
c
c     CALL
c       EVMAX   : max. value of a vector
c       EVMIN   : min. value of a vector
c       OVTMCV  : quadratic form: x'*A*x -> scalar
c       YM      : copy a vectorized matrix in a vectorized matrix
c       OPVOL   : computing optimization for ALLOCVOL (cf. modules/OPVOL.F)
c       TESTSDP : SDP test of a matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION epskat, volb, volp, lambda, rfr, cinfrfr, csuprfr
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, niter, maxiter,
     &        pisdp, piwo, pdsdp, pdwo, pdlagr, pdrho, pdwopt
      DOUBLE PRECISION eps, rhomax, rhomin, rhomean, tmin, tmax, t, sum,
     &                 error, mincinf, var, volmin, volopt,epsilon
      PARAMETER (eps = 1.E-50)
c
c     external subroutines
      EXTERNAL EVMAX, EVMIN, YM, opvolrfr, testsdp, OVTMCV
c
c     intrinsic functions
      INTRINSIC MAX, MIN, ABS
c
c-----------------------------------------------------------------------
c
c     initializations
      info  = 0      ! diagnostic argument
      maxiter = 1000 ! max. number of iterations
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for internal workspaces of OPVOL
c             needs( 3*n + 2*nin + neq + 7 )
c
c     Total size of iwork array = ( 3*n + 2*nin + neq + 7 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdrho = 1
c     pdrho : pointer for excess return ( n )
      pdwopt = pdrho + ( n )
c     pdwopt : pointer for wopt vector ( n )
      pdwo  = pdwopt + ( n )
c     pdwo  : pointer for internal workspaces of OPVOLRFR
c             needs( n*( n + neq + nin + 10 )
c                    + neq + 3*nin + 9  )
      pdlagr = pdwo + ( n*(n+neq+nin+10) + neq + 3*nin + 9 )
c     pdlagr : pointer for Lagr of OPVOLRFR
c              needs ( n + neq + nin + 3 )
c
c     Total size of dwork array = 2*n
c                               + n*( n + neq + nin + 10 )
c                               + neq + 3*nin + 9
c                               + n + neq + nin + 3
c     = n*( 2*n + neq + nin + 13 ) + 4*nin + 2*neq + 12
c
c
c-----------------------------------------------------------------------
c      open(unit=1,file='ALLOCVOLRFR.txt',status='unknown')
c      write(1,*) "Status=", 'OK'
c      do i = 1,n
c        do j = 1,ncsttot
c            write(1,*) ccstot(i,j)
c        enddo
c      enddo
c       write(1,*) "-----------------------"
c      close(unit=1)
c      RETURN
c
c-----------------------------------------------------
c     satisfiability conditions (well-defined problem)
c-----------------------------------------------------
c
c     covariance matrix SDP test
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     excess expected return: rho(i)-rfr
      DO i = 1,n
        dwork(pdrho + i - 1) = rho(i) - rfr
      ENDDO
c
c     test if budget volatility >= min. volatility
      t = -1.E+15
c     optimization (cf. rne/modules/OPVOLRFR.F)
      CALL opvolrfr ( n, cov, dwork(pdrho), t,
     &                neq, nin, ccst, bcst, cinf, csup,
     &                cinfrfr, csuprfr,
     &                iwork(piwo), dwork(pdwo),
     &                dwork(pdwopt), dwork(pdlagr), info)
      sum = 0.0
      DO i = 1,n
        wopt(i+1) = dwork(pdwopt+i-1)
        sum = sum + wopt(i+1)
      ENDDO
      wopt(1) = 1. - sum
c
c     if (w'*Q*w) < volb2 -> volatility budget const. too small !
      CALL OVTMCV ( n, cov, dwork(pdwopt), var)
      volmin = SQRT(var)
      IF (volb .LT. volmin) THEN
        info = -109
        RETURN
      ENDIF
c
c     the risk-budget constraint must be saturated.
c     a sufficient condition is that all the expected returns are not null
c     (case rho(i) = 0)
      DO i = 1,n
        IF (ABS(rho(i)) .LT. eps) THEN
            info = -110
            RETURN
        ENDIF
      ENDDO

c------------------------------------
c     initialization of tmin/tmax
c------------------------------------
c
c     min. lower bound
      CALL EVMIN(n, cinf, mincinf)
c
c     case long positions only
      IF (mincinf .GE. 0) THEN
c
c       max./min. return(s)
        CALL EVMAX(n, rho, rhomax)
        rhomax = MAX(ABS(rfr),rhomax)
        CALL EVMIN(n, rho, rhomin)
        rhomin = MIN(ABS(rfr),rhomin)
        tmax = rhomax
        tmin = rhomin
c
c     case long/short positions
      ELSE
        rhomax = ABS(rfr)
        DO i = 1,n
            rhomax = MAX(rhomax, ABS(rho(i)))
        ENDDO
        tmax = ABS(rfr)*(MAX(ABS(cinfrfr), ABS(csuprfr)))
        DO i = 1,n
            tmax = tmax + rhomax * (MAX(ABS(cinf(i)), ABS(csup(i))))
        ENDDO
        tmin = -tmax
      ENDIF
c
c     myzero := max(1.E-12, mean(rho))
      CALL MV ( n, rho, rhomean )
      epsilon = MAX(1.E-12, rhomean*1.E-8)
c
c      open(unit=1,file='ALLOCVOL.txt',status='unknown')
c
c     dichotomy loop
      error = 1.E+15
      niter = 0
      IF ( ABS(tmax - tmin) .LT. epsilon ) THEN
        info = 112
        RETURN
      ENDIF
c
c---------------------------------
c     dichotomy on tagret perf.
c---------------------------------
c
      DO WHILE ((niter .LT. maxiter) .AND. (error .GT. volp))
c
        niter = niter + 1
        t = ((tmin + tmax)/2.0) - rfr
c
c       optimization with risk-free rate (cf. OPVOLRFR.F)
        CALL opvolrfr ( n, cov, dwork(pdrho), t,
     &                  neq, nin, ccst, bcst, cinf, csup,
     &                  cinfrfr, csuprfr,
     &                  iwork(piwo), dwork(pdwo),
     &                  dwork(pdwopt), dwork(pdlagr), info )
c
c       sqrt[w'*Q*w] (portfolio volatility)
        CALL OVTMCV ( n, cov, dwork(pdwopt), var)
        volopt = SQRT(var)
c
c       if sqrt(w'*Q*w) > volb, then tmax = t, else tmin = t
        IF ((volopt .GT. volb) .OR. (info .NE. 0)) THEN
            tmax = t
        ELSE
            tmin = t
        ENDIF
c
c       if |tmax - tmin| < eps, then EXIT
        IF ( ABS(tmax - tmin) .LT. epsilon ) THEN
            info = 112
            RETURN
        ENDIF
c
c       error = |sqrt(w'*Q*w) - volb|
        error = ABS(volopt - volb)
c
c      open(unit=1,file='ALLOCVOL.txt',status='unknown')
c       write(1,*) "mu=", t
c       write(1,*) "Iteration=", niter
c      do i = 1,n
c        do j = 1,ncsttot
c            write(1,*) ccstot(i,j)
c        enddo
c      enddo
c       write(1,*) "-----------------------"
c      close(unit=1)
c
      ENDDO

      IF (niter .EQ. maxiter) THEN
        info = 111
      ENDIF
c
c--------------------------------------------
c     optimal portfolio: w=[w(0),...,w(n)]
c--------------------------------------------
      sum = 0.0
      DO i = 1,n
        wopt(i+1) = dwork(pdwopt + i - 1)
        sum = sum + wopt(i+1)
      ENDDO
      wopt(1) = 1. - sum
c
c--------------------------------------------
c     Lagrange multiplier (budget constraint)
c--------------------------------------------
      lambda = dwork(pdlagr + n + neq + nin)
c
      RETURN
      END


      subroutine newton(time,ffpast,aveks,avesm,ffnow)
c
c     + + + PURPOSE + + +
c     Calculates cumulative infiltration via Newton's method.
c
c     Called from GRNA.
c     Author(s): Stone
c     Reference in User Guide:
c
c     Changes:
c          1) Local variables: NU1, DEL, & XX deleted.
c          2) 3rd parameter moved to end of list, since it is an
c             "output" parameter, and the others are "input" ones.
c             Corresponding changes required in GRNA and KOSTIA.
c          3) Calculation for TEST simplified.  This caused the
c             familiar annoying changes in the predicted location
c             of max. detach. with a nearly-constant detach. rate.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/24/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real time, ffpast, aveks, avesm, ffnow
c
c     + + + ARGUMENT DEFINITIONS + + +
c     time   - current time
c     ffpast - infiltration depth of last time
c     aveks  - average KS
c     avesm  - average SM
c     ffnow  - infiltration depth of current time
c
c     + + + LOCAL VARIABLES + + +
      real test, yy
c
c     + + + LOCAL DEFINITIONS + + +
c     test   - value which tells when to exit loop.
c     yy     - current computed value for FFNOW.
c
c     + + + END SPECIFICATIONS + + +
c
c     Solution for sm=0.0
c
      if (avesm.le.0.0) then
        yy = time * aveks
      else
c
c       setting the initial yy value to prevent divide by zero
c
        if (ffpast.gt.0.0) then
          yy = ffpast
        else
          yy = 0.1
        end if
c
c       Keep reevaluating test until it becomes very small (<.000001)
c
        test = 0.1
   10   if (abs(test).gt.0.000001) then
          test = (time*aveks+avesm*log(1.0+yy/avesm)-yy) * (1.0+avesm/yy
     1        )
          yy = yy + test
          go to 10
        end if
      end if
c
      ffnow = yy
c
      return
      end


!> \file mo_random_field.f90

!> \brief This module contains generating random fields with certain
!>        statistical properties, e.g. correlation length.

!> \details This module contains generating random fields with certain
!>          statistical properties, e.g. correlation length.\n
!>          Right now there are the following implemented:
!>          * Irrotational flow fields with Gauss-shape correlation functions
!>            described by Attinger et al. (2008) 'Effective velocity for transport in
!>            heterogeneous compressible flows with mean drift' (Eq. 31-32)
!>          * some more...

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

module mo_random_field
  ! Written  Juliane Mai, Jul 2014

  ! 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, i8, dp

  implicit none

  public :: random_velocity_field_gauss ! Fields with gauss-shape correlation function

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

  !     NAME
  !         random_velocity_field_gauss

  !     PURPOSE
  !>        \brief Calculates random velocity fields by using a correlation function
  !>               which is a product of Gauss-shaped functions as described
  !>               by Attinger et al. (2008).
  !
  !>        \details Calculates random velocity fields by using a correlation function
  !>               which is a product of Gauss-shaped functions as described
  !>               by Attinger et al. (2008).\n
  !>               A transport equation in a reference domain is considered where the
  !>               velocity field \f$ u \f$ splits into \f$ u = \bar{u} + \tilde{u}\f$.
  !>               \f$ \bar{u}\f$ is a constant mean and \f$ \tilde{u} \f$ is a random
  !>               compressible velocity field defined by a zero mean random Gaussian
  !>               correlation function.\n
  !>               The potential can be generated by a superposition of randomly
  !>               chosen cosine modes as follows:
  !>                    \f[ u_i^N = \sigma \sqrt{\frac{2}{N}} \sum\limits_{j=1}^{N} k_i^j \cos(k^jx + \omega_j) \f]
  !>               where each component of \f$ k^j=(k_1^j,k_2^j)\f$ obeys a Gaussian
  !>               distribution with zero mean and variance given by \f$ 1/l_i^2 \f$.
  !>               \f$ l_i \f$ are the correlation lengths,  \f$ N \f$ is the number of cosine modes used for approximation.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp)            :: coord(n,m)"       2D-array of n coordinates in m dimensional space
  !>                                                                where field has to be evaluated
  !>        \param[in] "real(sp/dp)            :: corr_length(m)"   correlation length for each of the m dimensions
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !>        \param[in] "real(sp/dp)            :: sigma2"           variance of correlation function\n
  !>                                                                DEFAULT: 1.0_dp
  !>        \param[in] "integer(i4), optional  :: ncosinemode"      number of cosine modes summed up\n
  !>                                                                DEFAULT: 100
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !>        \param[out] "real(sp/dp), optional :: cosine_modes(ncosinemode,m)"
  !>                                                                returns <ncosinemode> random Gaussian modes
  !>                                                                \f$ k^j=(k_1^j,...,k_m^j)\f$, i.e. all
  !>                                                                information describing the field.
  !>                                                                Therefore, additional positions
  !>                                                                coord(:,:) can be evaluated afterwards.
  !>        \param[out] "real(sp/dp), optional :: potential(n)"     returns the potential of the field at all
  !>                                                                requested points
  !
  !     RETURN
  !>       \return     real(sp/dp) :: velocity(n,m) — velocity at given coordinates
  !
  !     RESTRICTIONS
  !>       \note None.
  !
  !     EXAMPLE
  !         -> see also example in test directory

  !     LITERATURE
  !         Attinger, S., & Abdulle, A. (2008).
  !             Effective velocity for transport in heterogeneous compressible flows with mean drift.
  !             Physics of Fluids

  !     HISTORY
  !>        \author Juliane Mai
  !>        \date Jul 2014
  !         Modified,
  interface random_velocity_field_gauss
     module procedure random_velocity_field_gauss_dp !, random_velocity_field_gauss_sp
  end interface random_velocity_field_gauss

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

  private

contains

  function random_velocity_field_gauss_dp(coord, corr_length, ncosinemode, sigma2, seed, &
    cosine_modes_in, cosine_modes_out, potential) result (velocity)

    use mo_constants,    only: pi_dp
    use mo_xor4096,      only: xor4096g, get_timeseed
    use mo_xor4096_apps, only: xor4096g_array

    implicit none

    real(dp), dimension(:,:),              intent(in)            :: coord            ! coordinates where field has to be evaluated
    !                                                                                !    dim1: number of requested points
    !                                                                                !    dim2: number of dimensions
    real(dp), dimension(:),                intent(in)            :: corr_length      ! correlation length for each dimension
    !                                                                                !    dim1: number of dimensions
    integer(i4),                           intent(in), optional  :: ncosinemode      ! number of cosine modes summed up
    !                                                                                !    DEFAULT: 100
    real(dp),                              intent(in), optional  :: sigma2           ! variance of correlation function
    !                                                                                !    DEFAULT: 1.0_dp
    integer(i8),                           intent(in), optional  :: seed             ! seed for random numbers
    !                                                                                !    DEFAULT: -9_i8 --> time_seed
    real(dp), dimension(:,:),              intent(in), optional  :: cosine_modes_in  ! cosine mode is already determined in prev.
    !                                                                                ! run and is now fixed there, i.e. field
    !                                                                                ! generation is skipped and only velocity
    !                                                                                ! and potential are determined
    !                                                                                !    dim1: number of cosine modes
    !                                                                                !    dim2: number of dimensions
    real(dp), dimension(:,:), allocatable, intent(out), optional :: cosine_modes_out ! returns the random cosine modes which
    !                                                                                ! define the field
    !                                                                                !    dim1: number of cosine modes
    !                                                                                !    dim2: number of dimensions
    real(dp), dimension(size(coord,1)),    intent(out), optional :: potential        ! potential of field at given point
    !                                                                                !    dim1: number of requested points
    real(dp), dimension(size(coord,1),size(coord,2))             :: velocity         ! velocity at given point
    !                                                                                !    dim1: number of requested points
    !                                                                                !    dim2: number of dimensions

    ! local variables
    integer(i4)                            :: idim, ipoint, imode  ! counter
    real(dp)                               :: h, h_pot             ! helper variables
    real(dp)                               :: isigma2              ! variance of correlation function
    integer(i4)                            :: incosinemode         ! number of cosine modes summed up
    integer(i4)                            :: npoints              ! number of points given
    integer(i4)                            :: dims                 ! number of dimensions
    real(dp), dimension(size(coord,1))     :: ipotential           ! potential of field at given point
    real(dp), dimension(:,:), allocatable  :: modes                ! random cosine modes which define the field
    integer(i8), dimension(:), allocatable :: iseed                ! seed for random numbers

    if (size(coord,2) .ne. size(corr_length,1)) then
       stop 'random_velocity_field_gauss: correlation length for each dimension has to be given'
    end if

    if ( any(corr_length .lt. 0.0_dp) ) then
       stop 'random_velocity_field_gauss: correlation length has to be positive'
    end if

    if (present(ncosinemode)) then
       if ( ncosinemode .le. 0 ) then
          stop 'random_velocity_field_gauss: ncosinemode is the number of cosine modes summed up and therefore has to be positive'
       else
          incosinemode = ncosinemode
       end if
    else
       incosinemode = 100
    end if

    if (present(cosine_modes_in)) then
       if ( size(cosine_modes_in,2) .ne. size(coord,2) ) then
          stop 'random_velocity_field_gauss: shape mismatch in second dimension'
       end if
       incosinemode = size(cosine_modes_in,1)
       ! later: values handed over to "modes"
    end if

    if (present(sigma2)) then
       if ( sigma2 .lt. 0.0_dp ) then
          stop 'random_velocity_field_gauss: sigma2 is variance of correlation function and therefore has to be positive'
       else
          isigma2 = sigma2
       end if
    else
       isigma2 = 1.0_dp
    end if

    npoints = size(coord,1)
    dims    = size(coord,2)

    allocate(modes(incosinemode, dims))
    modes = 0.0_dp
    set_modes: if (present(cosine_modes_in)) then
       modes = cosine_modes_in
    else
       allocate(iseed(dims))
       if (present(seed)) then
          if (seed .gt. 0_i8) then
             iseed(1) = seed
             do idim=2, dims
                iseed(idim) = iseed(idim-1) + 1000_i8
             end do
          else
             call get_timeseed(iseed)
          end if
       else
          call get_timeseed(iseed)
       end if

       ! initialize Random numbers
       call xor4096g(iseed, modes(1,:))

       ! generate random modes
       call xor4096g_array(modes)

       ! scale with correlation length
       do idim=1, dims
          modes(:,idim) = modes(:,idim) * 1.0_dp/corr_length(idim)
       end do

       deallocate(iseed)
    end if set_modes

    velocity(:,:) = 0.0_dp
    ipotential(:) = 0.0_dp
    do ipoint=1, npoints
       do imode=1, incosinemode
          h     = 0.0_dp ! velocity
          h_pot = 0.0_dp ! potential
          do idim=1, dims
             h  = h + modes(imode,idim) * coord(ipoint,idim)
          end do
          h_pot = h
          h     = cos( h     + real(imode,dp)*2.0_dp*pi_dp/real(incosinemode,dp) )
          h_pot = sin( h_pot + real(imode,dp)*2.0_dp*pi_dp/real(incosinemode,dp) )
          velocity(ipoint,:) = velocity(ipoint,:) + h * modes(imode,:)
          ipotential(ipoint) = ipotential(ipoint) + h_pot
       end do
    end do

    do idim=1,dims
       velocity(:,idim) = velocity(:,idim) * (isigma2) * sqrt( 2.0_dp/real(incosinemode,dp) )
    end do
    ipotential(:) = ipotential(:) * (isigma2) * sqrt( 2.0_dp/real(incosinemode,dp) )

    if (present(cosine_modes_out)) then
       if (allocated(cosine_modes_out)) deallocate(cosine_modes_out)
       allocate(cosine_modes_out(incosinemode, dims))
       cosine_modes_out = modes
    end if

    if (present(potential)) then
       potential = ipotential
    end if

    deallocate(modes)

  end function random_velocity_field_gauss_dp

end module mo_random_field


module mod_tree_set
  implicit none

  type t_node
    private
    type(t_node), pointer :: left => null(), right => null()
    integer :: level = 1
    integer :: e = 0
  end type

  type t_tree_set
    private
    type(t_node), pointer :: root => null()
    integer :: deflt = -1
  contains
    procedure :: size => size_of
    procedure :: clear => clear
    procedure :: add => add
    procedure :: remove => remove
    procedure :: contain => contain
    procedure :: first => firste
    procedure :: poll_first => poll_first
    procedure :: last => laste
    procedure :: poll_last => poll_last
    procedure :: floor => floore
    procedure :: lower => lowere
    procedure :: ceiling => ceilinge
    procedure :: higher => highere
    procedure :: element_list => element_list
  end type

contains

  function new_node(e) result(n)
    integer, intent(in) :: e
    type(t_node), pointer :: n
    n => null()
    allocate(n)
    n%e = e
  end

  integer function level(n)
    type(t_node), pointer, intent(in) :: n
    level = 0
    if (.not.associated(n)) return
    level = n%level
  end

  logical function is_leaf(n)
    type(t_node), pointer, intent(in) :: n
    is_leaf = associated(n) .and. .not.associated(n%left) .and. &
    & .not.associated(n%right)
  end

  recursive function tree_size(n) result(s)
    type(t_node), pointer, intent(in) :: n
    integer :: s
    s = 0
    if (.not.associated(n)) return
    s = 1+tree_size(n%left)+tree_size(n%right)
  end

  function skew(n) result(l)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: l
    l => n
    if (.not.(associated(n) .and. associated(n%left) .and. &
    &   n%left%level == n%level)) return
    l => n%left
    n%left => l%right
    l%right => n
  end

  function split(n) result(r)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: r
    r => n
    if (.not.(associated(n) .and. associated(n%right) .and. &
    &   associated(n%right%right) .and. n%right%right%level == n%level)) return
    r => n%right
    n%right => r%left
    r%left => n
    r%level = r%level+1
  end

  function predecessor(n) result(p)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: p
    p => null()
    if (.not.associated(n%left)) return
    p => n%left
    do while (associated(p%right))
      p => p%right
    end do
  end

  function successor(n) result(s)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: s
    s => null()
    if (.not.associated(n%right)) return
    s => n%right
    do while (associated(s%left))
      s => s%left
    end do
  end

  recursive function insert(n,e) result(t)
    type(t_node), pointer, intent(in) :: n
    integer, intent(in) :: e
    type(t_node), pointer :: t
    t => new_node(e)
    if (.not.associated(n)) return
    t => n
    if (e < t%e) then
      t%left => insert(t%left,e)
    else if (e > t%e) then
      t%right => insert(t%right,e)
    end if
    t => skew(t)
    t => split(t)
  end

  recursive function delete(n,e) result(t)
    type(t_node), pointer, intent(in) :: n
    integer, intent(in) :: e
    type(t_node), pointer :: t, l
    t => n
    if (.not.associated(n)) return
    if (e < t%e) then
      t%left => delete(t%left,e)
    else if (e > t%e) then
      t%right => delete(t%right,e)
    else
      if (is_leaf(t)) return
      if (.not.associated(t%left)) then
        l => successor(t)
        t%right => delete(t%right,l%e)
        t%e = l%e
      else
        l => predecessor(t)
        t%left => delete(t%left,l%e)
        t%e = l%e
      end if
    end if
    t => decrease_level(t)
    t => skew(t)
    t%right => skew(t%right)
    if (associated(t%right)) t%right%right => skew(t%right%right)
    t => split(t)
    t%right => split(t%right)
  end

  function decrease_level(n) result(t)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: t
    integer :: should_be
    t => n
    should_be = min(level(t%left),level(t%right))+1
    if (t%level > should_be) then
      t%level = should_be
      if (level(t%right) > should_be) t%right%level = should_be
    end if
  end

  recursive subroutine release_tree(t)
    type(t_node), pointer, intent(inout) :: t
    if (.not.associated(t)) return
    call release_tree(t%left)
    call release_tree(t%right)
    deallocate(t)
  end

  recursive subroutine get_element(t,es,num)
    type(t_node), pointer, intent(in) :: t
    integer, intent(inout) :: es(:)
    integer, intent(inout) :: num
    if (.not.associated(t)) return
    call get_element(t%left,es,num)
    num = num+1
    es(num) = t%e
    call get_element(t%right,es,num)
  end

  integer function size_of(this)
    class(t_tree_set), intent(in) :: this
    size_of = tree_size(this%root)
  end

  subroutine clear(this)
    class(t_tree_set), intent(inout) :: this
    call release_tree(this%root)
    this%root => null()
  end

  subroutine set_default(this,deflt)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: deflt
    this%deflt = deflt
  end

  subroutine add(this,e)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    this%root => insert(this%root,e)
  end

  subroutine remove(this,e)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    this%root => delete(this%root,e)
  end

  function contain(this,e) result(ret)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    type(t_node), pointer :: n
    logical :: ret
    ret = .false.
    n => this%root
    do while (associated(n))
      if (e < n%e) then
        n => n%left
      else if (e > n%e) then
        n => n%right
      else
        ret = .true.
        return
      end if
    end do
  end

  function firste(this) result(ret)
    class(t_tree_set), intent(inout) :: this
    type(t_node), pointer :: n
    integer :: ret
    ret = this%deflt
    n => this%root
    if (.not.associated(n)) return
    do while (associated(n%left))
      n => n%left
    end do
    ret = n%e
  end

  function poll_first(this) result(ret)
    class(t_tree_set), intent(inout) :: this
    type(t_node), pointer :: n
    integer :: ret
    ret = firste(this)
    if (ret /= this%deflt) this%root => delete(this%root,ret)
  end

  function laste(this) result(ret)
    class(t_tree_set), intent(inout) :: this
    type(t_node), pointer :: n
    integer :: ret
    ret = this%deflt
    n => this%root
    if (.not.associated(n)) return
    do while (associated(n%right))
      n => n%right
    end do
    ret = n%e
  end

  function poll_last(this) result(ret)
    class(t_tree_set), intent(inout) :: this
    type(t_node), pointer :: n
    integer :: ret
    ret = laste(this)
    if (ret /= this%deflt) this%root => delete(this%root,ret)
  end

  function floore(this,e) result(ret)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    type(t_node), pointer :: n
    integer :: ret
    ret = this%deflt
    n => this%root
    do while (associated(n))
      if (e < n%e) then
        n => n%left
      else if (e > n%e) then
        if (ret == this%deflt) ret = n%e
        if (e-ret > e-n%e) ret = n%e
        n => n%right
      else
        ret = n%e
        return
      end if
    end do
  end

  function lowere(this,e) result(ret)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    integer :: ret
    ret = floore(this,e-1)
  end

  function ceilinge(this,e) result(ret)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    type(t_node), pointer :: n
    integer :: ret
    ret = this%deflt
    n => this%root
    do while (associated(n))
      if (e < n%e) then
        if (ret == this%deflt) ret = n%e
        if (e-ret < e-n%e) ret = n%e
        n => n%left
      else if (e > n%e) then
        n => n%right
      else
        ret = n%e
        return
      end if
    end do
  end

  function highere(this,e) result(ret)
    class(t_tree_set), intent(inout) :: this
    integer, intent(in) :: e
    integer :: ret
    ret = ceilinge(this,e+1)
  end

  subroutine element_list(this,es,num)
    class(t_tree_set), intent(inout) :: this
    integer, intent(out) :: es(:)
    integer, intent(out) :: num
    num = 0
    call get_element(this%root,es,num)
  end

end module mod_tree_set


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0
!real(dp), parameter :: stop_time = 10.0
real(dp), parameter :: stop_time = 0.5
!real(dp), parameter :: stop_time = 0.0

real(dp), parameter :: CFL = 0.8

real(dp), parameter :: beta = 0.8

real(dp), parameter :: dt_checkpoint = 0.1

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 1.0

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.5)

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

real(dp), parameter :: bell_mass  = 1.5
real(dp), parameter :: bell_sigma = 0.1

real(dp), parameter :: blast_energy = 1.0
real(dp), parameter :: blast_sigma  = 0.08

real(dp), parameter :: bell_mass_normalized = bell_mass/SQRT((2*pi)**N_DIMS)/bell_sigma**N_DIMS
real(dp), parameter :: blast_ener_normalized = blast_energy/SQRT((2*pi)**N_DIMS)/blast_sigma**N_DIMS

real(dp), parameter :: bell_magx_sigma = 0.03
real(dp), parameter :: bell_magx_normalized = 1.0_dp/SQRT((2*pi)**N_DIMS)/bell_magx_sigma**N_DIMS

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

real(dp), parameter :: dens0 = 1.0_dp
real(dp), parameter :: pres0 = 1.0_dp
real(dp), parameter :: ener0 = 6.0_dp

real(dp), parameter :: velx0 = 0.0_dp
real(dp), parameter :: vely0 = 0.0_dp
real(dp), parameter :: velz0 = 0.0_dp

real(dp), parameter :: magx0 = 2.0_dp
real(dp), parameter :: magy0 = 0.0_dp
real(dp), parameter :: magz0 = 0.0_dp

real(dp), parameter :: glmp0 = 0.0_dp

!real(dp), parameter :: kappa = 7.0_dp/5.0_dp
real(dp), parameter :: kappa = 1.4_dp

real(dp), parameter :: mu0 = 1.0_dp
! real(dp), parameter :: GLM_ch = 0.5_dp
! real(dp), parameter :: GLM_alpha = 2.0_dp

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

integer, parameter :: amr_each_ntimesteps = 8

integer, parameter :: mesh_minlevel = 3
integer, parameter :: mesh_maxlevel = 3

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module