MODULE mo_histo

  ! This module calculates the Histogram of data
  ! and is part of the JAMS Fortran library.
  !
  ! Written  Juliane Mai, Feb 2012

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

  USE mo_kind, ONLY: i4, sp, dp

  IMPLICIT NONE

#ifndef __ABSOFT__
  PUBLIC :: histo           ! Histogram of 1D data
  PUBLIC :: histo2d         ! Histogram of 2D data

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

  !     NAME
  !         histo

  !     PURPOSE
  !         Calculates the histogram of n data 1D points (Xi),i=1,n ,
  !         i.e. the n data points are sorted into k categories (bins).
  !         In case of multidimensional data points (Xij),j=1,n ,
  !         only the first coordinate (X1j) is taken for determination of the category,
  !         while the other coordinates are averged per bin.
  !
  !         With no optional arguments the number of bins k is the integer part of Sqrt(n)
  !         where n is the number of data points. E.g. n=15 will create k=3 bins.
  !         The bin width w is calculated depending on the minimal and maximal value of
  !         the first coordinate):
  !                     w = (maxval(X) - minval(X)) / k
  !
  !         Optionally, one can fix the number of bins k (integer i4)
  !         while the width of the bins is determined.
  !         Or, on can fix the binwidth w (float sp/dp) while k is determined automatically.
  !         If an optional mask is given, the histogram is taken into account only data points (Xij)
  !         which have a true value in the mask.
  !         (Xij) can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         call hist(x, binx, bincount, width)                          ! with no optional arguments
  !         call hist(x, binx, bincount, width, bins=k,     mask=maske)  ! to fix the number of bins k
  !         call hist(x, binx, bincount, width, binwidth=w, mask=maske)  ! to fix the bin width w

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)     1D array of x values
  !       or
  !         real(sp/dp) :: x(:,:)   2D array of x values

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: binx(:)       x-values of the histogram (center of the bin)
  !       or
  !         real(sp/dp) :: binx(:,:)     center of the bins and the averaged 2nd, 3rd... coordinates
  !       and
  !         integer(i4) :: bincount(:)   number of values within each bin
  !         real(sp/dp) :: width         width of a bin

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)    1D-array of logical values with size(x,1).
  !                                   If present, only the data points in (Xij) corresponding
  !                                   to the true values in mask are used.
  !         integer(i4) :: bins       Number of bins to be generated.
  !                                   If present, the number of bins will be fixed to this value.
  !                                   Otherwise, is set to integer part of sqrt(size(x)) or
  !                                   using the optionally set binwidth.
  !         real(sp/dp) :: binwidth   Width of the bins to be generated.
  !                                   If present, the width of bins will be fixed to this value and
  !                                   the INTENT(OUT) width will be set to this value.
  !                                   Otherwise, will be determined using the number of bins.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Input values must be floating points.
  !         Use more than one data point: Size(x,1) > 1.
  !         If you fix the number of bins, it has to be larger than 1: bins > 1.
  !         If you fix the width of the bins, it has to be larger than 0: binwidth > 0.
  !         Either the number of bins or the width of the bins can be fixed, not both.
  !         Not all values of the first coordinate should be equal.
  !         Dimension of x and mask have to match: Size(x,1) = Size(mask).

  !     EXAMPLE
  !         x = (/3.0, 4.0, 6.0, 7.0/)
  !
  !         binx = (/4.0, 6.0/)
  !         bincount = (/2, 2/)
  !         width = 2.0
  !
  !         x = (/ (/3.0, 4.0, 6.0, 7.0/) , (/1.0, 2.0, 5.0, 2.0/) /)
  !
  !         binx = (/ (/4.0, 6.0/) , (/1.5, 3.5/) /)
  !         bincount = (/2, 2/)
  !         width = 2.0
  !
  !         -> see also example in test directory

  !     LITERATURE
  !

  !     HISTORY
  !         Written,  Juliane Mai, Feb 2012
  INTERFACE histo
     MODULE PROCEDURE histo_sp_1d, histo_dp_1d, histo_sp_2d, histo_dp_2d
  END INTERFACE histo

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

  !     NAME
  !         histo2d

  !     PURPOSE
  !         Calculates the 2D histogram of n data 2D points (Xi,Yi),i=1,n ,
  !         i.e. the n data points are sorted into k x k categories (bins).
  !
  !         With no optional arguments the number of bins k per dimension
  !         is the integer part of n**(1/4) where n is the number of data points.
  !         E.g. n=20 will create k=2 bins in each direction (= 4 bins in sum).
  !         The bin width w is calculated depending on the minimal and maximal value of
  !         the first coordinate):
  !                     w = (maxval(X) - minval(X)) / k
  !
  !         Optionally, one can fix the number of bins k (integer i4)
  !         while the width of the bins is determined.
  !         Or, on can fix the binwidth w (float sp/dp) while k is determined automatically.
  !         If an optional mask is given, the histogram is taken into account only data points
  !         (Xi, Yi) which have a true value in the mask.
  !         (Xi, Yi) can be single or double precision.
  !         The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !     with no optional arguments
  !         call hist2d(x, binx, bincount, width)
  !     to fix the number of bins k
  !         call hist2d(x, binx, bincount, width, bins=k,     mask=maske)
  !     to fix the bin width w
  !         call hist2d(x, binx, bincount, width, binwidth=w, mask=maske)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:,2)   2D array of (x,y) values

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: binx(:,2)     (x,y)-values of the histogram (center of the bin)
  !         integer(i4) :: bincount(:)   number of values within each bin
  !         real(sp/dp) :: width         width of a bin

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)      1D-array of logical values with size(x,1).
  !                                     If present, only the data points in (Xij) corresponding
  !                                     to the true values in mask are used.
  !         integer(i4) :: bins         Number of bins to be generated.
  !                                     If present, the number of bins will be fixed to this value.
  !                                     Otherwise, is set to integer part of sqrt(size(x)) or
  !                                     using the optionally set binwidth.
  !         real(sp/dp) :: binwidth(2)  Width of the bins to be generated.
  !                                     One value for each direction.
  !                                     If present, the width of bins will be fixed to this value
  !                                     and the INTENT(OUT) width will be set to this value.
  !                                     Otherwise, will be determined using the number of bins.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         The number of bins is equal in each direction, i.e. x and y.
  !         Input values must be floating points.
  !         Use more than one data point: Size(x,1) > 1.
  !         If you fix the number of bins, it has to be larger than 1: bins > 1.
  !         If you fix the width of the bins, it has to be larger than 0: binwidth > 0.
  !         Either the number of bins or the width of the bins can be fixed, not both.
  !         Not all values of the first coordinate should be equal.
  !         Dimension of x and mask have to match: Size(x,1) = Size(mask).

  !     EXAMPLE
  !     REAL(DP),    DIMENSION(4,2)              :: x
  !     REAL(DP),    DIMENSION(:,:), ALLOCATABLE :: testbinx
  !     INTEGER(I4), DIMENSION(:),   ALLOCATABLE :: testbincount
  !     REAL(DP),    DIMENSION(2)                :: testwidth

  !     x(1,:) = (/3.0_dp, 1.0_dp/)
  !     x(2,:) = (/6.0_dp, 4.0_dp/)
  !     x(3,:) = (/2.0_dp, 3.0_dp/)
  !     x(4,:) = (/1.0_dp, 1.0_dp/)
  !
  !     call histo2d(x, testbinx, testbincount, testwidth)
  !
  !         ^
  !         |                                      x ... data points
  !       4 |  ********************x               * ... edge of bin
  !         |  *         *         *
  !       3 |  *   x     *         *
  !         |  *********************
  !       2 |  *         *         *
  !         |  *         *         *
  !       1 |  x*******x************
  !         |
  !         |- - - - - - - - - - - - -  >
  !            1   2   3   4   5   6
  !
  !     print*, 'testbinx(1)  = ',testbinx(1,:)    --> (/2.25, 1.75/)
  !     print*, 'testbinx(2)  = ',testbinx(2,:)    --> (/4.75, 1.75/)
  !     print*, 'testbinx(3)  = ',testbinx(3,:)    --> (/2.25, 3.25/)
  !     print*, 'testbinx(4)  = ',testbinx(4,:)    --> (/4.75, 3.25/)
  !     print*, 'testbincount = ',testbincount     --> (/ 2, 0, 1, 1/)
  !     print*, 'testwidth    = ',testwidth        --> (/ 2.5, 1.5 /)
  !
  !     LITERATURE
  !
  !     HISTORY
  !         Written,  Juliane Mai, Mar 2012
  INTERFACE histo2d
     MODULE PROCEDURE histo2d_sp, histo2d_dp
  END INTERFACE histo2d

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

  PRIVATE

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

CONTAINS

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

  SUBROUTINE histo_dp_1d(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:),                     INTENT(IN)  :: x
    REAL(DP),    DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(DP),                                      INTENT(OUT) :: width

    INTEGER(I4),            OPTIONAL,              INTENT(IN)  :: bins
    REAL(DP),               OPTIONAL,              INTENT(IN)  :: binwidth
    LOGICAL,  DIMENSION(:), OPTIONAL,              INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x))              :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(DP)                                 :: w        ! binwidth
    REAL(DP)                                 :: minimalvalue
    INTEGER(I4)                              :: i, binnr
    REAL(DP), DIMENSION(:),ALLOCATABLE       :: helpbinx
    INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error histo_dp: size(mask) /= size(x)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x)
    endif

    if (n .le. (1.0_dp+tiny(1.0_dp))) then
       stop 'Error histo_dp: size(x) must be at least 2'
    end if
    if (maxval(x(:), mask=maske)-minval(x(:), mask=maske) <= tiny(1.0_dp)) then
       stop 'Error histo_dp: all entries of x(:) are equal'
    end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo_dp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo_dp: number of bins <= 1'
       k = bins
       w = (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / real(k,dp)
    else
       if (present(binwidth)) then
          if (binwidth .le. tiny(1.0_dp)) stop 'Error histo_dp: width of bins too small'
          w = binwidth
          k = Ceiling( (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / w )
       else
          k = Floor(Sqrt(real(n,dp)))
          w = (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / real(k,dp)
       end if
    endif

    ! Histogram

    allocate (binx(k),bincount(k))

    minimalvalue=minval(x(:), mask=maske)

    do i=1,k
       binx(i) = minimalvalue + real(2*i-1,dp)/2.0_dp*w
       bincount(i) = 0_i4
    end do

    do i=1,size(x)
       If (maske(i)) then
          binnr           = Floor((x(i)-minimalvalue)/w )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr           = binnr - Floor(real(binnr,dp)/real(k,dp)) + 1_i4
          bincount(binnr) = bincount(binnr) + 1_i4
       end if
    end do

    width = w

    if (count(bincount .gt. 0_i4) .lt. k) then
       print *, ' '
       print *, 'WARNING histo_dp: Empty bins have been deleted. size(binx) < bins'
       print *, ' '

       allocate(helpbinx(count(bincount .gt. 0_i4)))
       allocate(helpbincount(count(bincount .gt. 0_i4)))
       binnr=1_i4
       do i=1,k
          if (bincount(i) .gt. 0_i4) then
             helpbinx(binnr) = binx(i)
             helpbincount(binnr) = bincount(i)
             binnr=binnr+1_i4
          end if
       end do
       deallocate(binx,bincount)
       allocate(binx(size(helpbinx)))
       allocate(bincount(size(helpbinx)))
       binx=helpbinx
       bincount=helpbincount
       deallocate(helpbinx,helpbincount)
    end if

  END SUBROUTINE histo_dp_1d

  SUBROUTINE histo_sp_1d(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:),                     INTENT(IN)  :: x
    REAL(SP),    DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(SP),                                      INTENT(OUT) :: width

    INTEGER(I4),            OPTIONAL,              INTENT(IN)  :: bins
    REAL(SP),               OPTIONAL,              INTENT(IN)  :: binwidth
    LOGICAL,  DIMENSION(:), OPTIONAL,              INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x))              :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(SP)                                 :: w        ! binwidth
    REAL(SP)                                 :: minimalvalue
    INTEGER(I4)                              :: i, binnr
    REAL(SP), DIMENSION(:),ALLOCATABLE       :: helpbinx
    INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error histo_sp: size(mask) /= size(x)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x)
    endif

    if (n .le. (1.0_sp+tiny(1.0_sp))) then
       stop 'Error histo_sp: size(x) must be at least 2'
    end if
    if (maxval(x(:), mask=maske)-minval(x(:), mask=maske) <= tiny(1.0_sp)) then
       stop 'Error histo_sp: all entries of x(:) are equal'
    end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo_sp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo_sp: number of bins <= 1'
       k = bins
       w = (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / real(k,sp)
    else
       if (present(binwidth)) then
          if (binwidth .le. tiny(1.0_sp)) stop 'Error histo_sp: width of bins too small'
          w = binwidth
          k = Ceiling( (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / w )
       else
          k = Floor(Sqrt(real(n,sp)))
          w = (maxval(x(:), mask=maske)-minval(x(:), mask=maske)) / real(k,sp)
       end if
    endif

    ! Histogram

    allocate (binx(k),bincount(k))

    minimalvalue = minval(x(:), mask=maske)

    do i=1,k
       binx(i) = minimalvalue + real(2*i-1,sp)/2.0_sp*w
       bincount(i) = 0_i4
    end do

    do i=1,size(x)
       If (maske(i)) then
          binnr           = Floor((x(i)-minimalvalue)/w )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr           = binnr - Floor(real(binnr,sp)/real(k,sp)) + 1_i4
          bincount(binnr) = bincount(binnr) + 1_i4
       end if
    end do

    width = w

    if (count(bincount .gt. 0_i4) .lt. k) then
       print *, ' '
       print *, 'WARNING histo_sp: Empty bins have been deleted. size(binx) < bins'
       print *, ' '

       allocate(helpbinx(count(bincount .gt. 0_i4)))
       allocate(helpbincount(count(bincount .gt. 0_i4)))
       binnr=1_i4
       do i=1,k
          if (bincount(i) .gt. 0_i4) then
             helpbinx(binnr) = binx(i)
             helpbincount(binnr) = bincount(i)
             binnr=binnr+1_i4
          end if
       end do
       deallocate(binx,bincount)
       allocate(binx(size(helpbinx)))
       allocate(bincount(size(helpbinx)))
       binx=helpbinx
       bincount=helpbincount
       deallocate(helpbinx,helpbincount)
    end if

  END SUBROUTINE histo_sp_1d

  SUBROUTINE histo_dp_2d(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:,:),                   INTENT(IN)  :: x
    REAL(DP),    DIMENSION(:,:),      ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(DP),                                      INTENT(OUT) :: width

    INTEGER(I4),            OPTIONAL,              INTENT(IN)  :: bins
    REAL(DP),               OPTIONAL,              INTENT(IN)  :: binwidth
    LOGICAL,  DIMENSION(:), OPTIONAL,              INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x,1))            :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(DP)                                 :: w        ! binwidth
    REAL(DP)                                 :: minimalvalue
    INTEGER(I4)                              :: i, j, binnr
    REAL(DP), DIMENSION(:,:),ALLOCATABLE     :: helpbinx
    INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x,1)) stop 'Error histo_dp: size(mask) /= size(x,1)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x,1)
    endif

    if (n .le. (1.0_dp+tiny(1.0_dp))) then
       stop 'Error histo_dp: size(x,1) must be at least 2'
    end if
    if (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske) <= tiny(1.0_dp)) then
       stop 'Error histo_dp: all entries of x(:,1) are equal'
    end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo_dp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo_dp: number of bins <= 1'
       k = bins
       w = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,dp)
    else
       if (present(binwidth)) then
          if (binwidth .le. tiny(1.0_dp)) stop 'Error histo_dp: width of bins too small'
          w = binwidth
          k = Ceiling( (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / w )
       else
          k = Floor(Sqrt(real(n,dp)))
          w = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,dp)
       end if
    endif

    ! Histogram

    allocate (binx(k,size(x,2)),bincount(k))

    minimalvalue = minval(x(:,1), mask=maske)

    binx = 0.0_dp
    bincount = 0_i4
    do i=1,k
       binx(i,1) = minimalvalue + real(2*i-1,dp)/2.0_dp*w
    end do

    do i=1,size(x,1)
       If (maske(i)) then
          binnr           = Floor((x(i,1)-minimalvalue)/w )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr           = binnr - Floor(real(binnr,dp)/real(k,dp)) + 1_i4
          bincount(binnr) = bincount(binnr) + 1_i4
          do j=2,size(x,2)
             binx(binnr,j)     = binx(binnr,j) + x(i,j)
          end do
       end if
    end do

    width = w

    if (count(bincount .gt. 0_i4) .lt. k) then
       print *, ' '
       print *, 'WARNING histo_dp: Empty bins have been deleted. size(binx) < bins'
       print *, ' '

       allocate(helpbinx(count(bincount .gt. 0_i4),size(x,2)))
       allocate(helpbincount(count(bincount .gt. 0_i4)))
       binnr=1_i4
       do i=1,k
          if (bincount(i) .gt. 0_i4) then
             helpbinx(binnr,1) = binx(i,1)
             do j=2,size(x,2)
                helpbinx(binnr,j) = binx(i,j)/real(bincount(i),dp)
             end do
             helpbincount(binnr) = bincount(i)
             binnr=binnr+1_i4
             !else
             !   print*, 'Delete binx = ', binx(i,1)
          end if
       end do
       deallocate(binx,bincount)
       allocate(binx(size(helpbinx,1),size(helpbinx,2)))
       allocate(bincount(size(helpbinx)))
       binx=helpbinx
       bincount=helpbincount
       deallocate(helpbinx,helpbincount)
    else
       do i=1,k
          do j=2,size(x,2)
             binx(i,j)     = binx(i,j) / real(bincount(i),dp)
          end do
       end do
    end if

  END SUBROUTINE histo_dp_2d

  SUBROUTINE histo_sp_2d(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:,:),                   INTENT(IN)  :: x
    REAL(SP),    DIMENSION(:,:),      ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(SP),                                      INTENT(OUT) :: width

    INTEGER(I4),            OPTIONAL,              INTENT(IN)  :: bins
    REAL(SP),               OPTIONAL,              INTENT(IN)  :: binwidth
    LOGICAL,  DIMENSION(:), OPTIONAL,              INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x,1))            :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(SP)                                 :: w        ! binwidth
    REAL(SP)                                 :: minimalvalue
    INTEGER(I4)                              :: i, j, binnr
    REAL(SP), DIMENSION(:,:),ALLOCATABLE     :: helpbinx
    INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x,1)) stop 'Error histo_sp: size(mask) /= size(x,1)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x,1)
    endif

    if (n .le. (1.0_sp+tiny(1.0_sp))) then
       stop 'Error histo_sp: size(x,1) must be at least 2'
    end if
    if (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske) <= tiny(1.0_sp)) then
       stop 'Error histo_sp: all entries of x(:,1) are equal'
    end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo_sp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo_sp: number of bins <= 1'
       k = bins
       w = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,sp)
    else
       if (present(binwidth)) then
          if (binwidth .le. tiny(1.0_sp)) stop 'Error histo_sp: width of bins too small'
          w = binwidth
          k = Ceiling( (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / w )
       else
          k = Floor(Sqrt(real(n,sp)))
          w = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,sp)
       end if
    endif

    ! Histogram

    allocate (binx(k,size(x,2)),bincount(k))

    minimalvalue = minval(x(:,1), mask=maske)

    binx = 0.0_sp
    bincount = 0_i4
    do i=1,k
       binx(i,1) = minimalvalue + real(2*i-1,sp)/2.0_sp*w
    end do

    do i=1,size(x,1)
       If (maske(i)) then
          binnr           = Floor((x(i,1)-minimalvalue)/w )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr           = binnr - Floor(real(binnr,sp)/real(k,sp)) + 1_i4
          bincount(binnr) = bincount(binnr) + 1_i4
          do j=2,size(x,2)
             binx(binnr,j)     = binx(binnr,j) + x(i,j)
          end do
       end if
    end do

    width = w

    if (count(bincount .gt. 0_i4) .lt. k) then
       print *, ' '
       print *, 'WARNING histo_sp: Empty bins have been deleted. size(binx) < bins'
       print *, ' '

       allocate(helpbinx(count(bincount .gt. 0_i4),size(x,2)))
       allocate(helpbincount(count(bincount .gt. 0_i4)))
       binnr=1_i4
       do i=1,k
          if (bincount(i) .gt. 0_i4) then
             helpbinx(binnr,1) = binx(i,1)
             do j=2,size(x,2)
                helpbinx(binnr,j) = binx(i,j)/real(bincount(i),sp)
             end do
             helpbincount(binnr) = bincount(i)
             binnr=binnr+1_i4
             !else
             !   print*, 'Delete binx = ', binx(i,1)
          end if
       end do
       deallocate(binx,bincount)
       allocate(binx(size(helpbinx,1),size(helpbinx,2)))
       allocate(bincount(size(helpbinx)))
       binx=helpbinx
       bincount=helpbincount
       deallocate(helpbinx,helpbincount)
    else
       do i=1,k
          do j=2,size(x,2)
             binx(i,j)     = binx(i,j) / real(bincount(i),sp)
          end do
       end do
    end if

  END SUBROUTINE histo_sp_2d

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

  SUBROUTINE histo2d_dp(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:,:),                   INTENT(IN)  :: x
    REAL(DP),    DIMENSION(:,:),      ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(DP),    DIMENSION(2),                     INTENT(OUT) :: width

    INTEGER(I4),               OPTIONAL,           INTENT(IN)  :: bins
    REAL(DP),    DIMENSION(2), OPTIONAL,           INTENT(IN)  :: binwidth
    LOGICAL,     DIMENSION(:), OPTIONAL,           INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x,1))            :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(DP), DIMENSION(2)                   :: w        ! binwidth
    REAL(DP), DIMENSION(2)                   :: minimalvalue
    INTEGER(I4)                              :: i, j
    INTEGER(I4)                              :: binnr, binnr1, binnr2
    !REAL(DP), DIMENSION(:),ALLOCATABLE       :: helpbinx
    !INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x,1)) stop 'Error histo_dp: size(mask) /= size(x)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x,1)
    endif

    if (n .le. (1.0_dp+tiny(1.0_dp))) then
       stop 'Error histo2d_dp: size(x) must be at least 2'
    end if
    !if (maxval(x(:), mask=maske)-minval(x(:), mask=maske) <= tiny(1.0_dp)) then
    !   stop 'Error histo_dp: all entries of x(:) are equal'
    !end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo2d_dp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo2d_dp: number of bins <= 1'
       k = bins
       w(1) = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,dp)
       w(2) = (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / real(k,dp)
    else
       if (present(binwidth)) then
          if (any(binwidth .le. tiny(1.0_dp))) stop 'Error histo2d_dp: width of bins too small'
          if (size(binwidth,1) .ne. 2_i4) stop 'Error histo2d_dp: size(width) has to be 2'
          w(:) = binwidth(:)
          k = Max( Ceiling( (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / w(1) ), &
               Ceiling( (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / w(2) ) )
       else
          k = Floor(real(n,dp)**0.25_dp)
          w(1) = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,dp)
          w(2) = (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / real(k,dp)
       end if
    endif

    ! Histogram

    allocate (binx(k*k,2),bincount(k*k))

    minimalvalue(1)=minval(x(:,1), mask=maske)
    minimalvalue(2)=minval(x(:,2), mask=maske)

    do i=1,k
       do j=1,k
          binx((i-1)*k+j,1)   = minimalvalue(1) + real(2*j-1,dp)/2.0_dp*w(1)
          binx((i-1)*k+j,2)   = minimalvalue(2) + real(2*i-1,dp)/2.0_dp*w(2)
          bincount((i-1)*k+j) = 0_i4
       end do
    end do

    do i=1,size(x,1)
       If (maske(i)) then
          !print*, 'x(i) = ',x(i,:)
          binnr1 =   Floor((x(i,1)-minimalvalue(1))/w(1) )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr1 =   binnr1 - Floor(real(binnr1,dp)/real(k,dp)) + 1_i4
          !print*, 'i = ',i,'  binnr 1 = ',binnr1

          binnr2 =   Floor((x(i,2)-minimalvalue(2))/w(2) )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr2 =   binnr2 - Floor(real(binnr2,dp)/real(k,dp)) + 1_i4
          !print*, 'i = ',i,'  binnr 2 = ',binnr2

          binnr           = (binnr2-1_i4)*k + binnr1
          !print*, 'i = ',i,'  binnr 3 = ',binnr
          bincount(binnr) = bincount(binnr) + 1_i4
       end if
    end do

    width(:) = w(:)

  END SUBROUTINE histo2d_dp

  SUBROUTINE histo2d_sp(x, binx, bincount, width, mask, bins, binwidth)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:,:),                   INTENT(IN)  :: x
    REAL(SP),    DIMENSION(:,:),      ALLOCATABLE, INTENT(OUT) :: binx
    INTEGER(I4), DIMENSION(:),        ALLOCATABLE, INTENT(OUT) :: bincount
    REAL(SP),    DIMENSION(2),                     INTENT(OUT) :: width

    INTEGER(I4),               OPTIONAL,           INTENT(IN)  :: bins
    REAL(SP),    DIMENSION(2), OPTIONAL,           INTENT(IN)  :: binwidth
    LOGICAL,     DIMENSION(:), OPTIONAL,           INTENT(IN)  :: mask

    ! Local variables
    LOGICAL, DIMENSION(size(x,1))            :: maske
    INTEGER(I4)                              :: n        ! number of data points
    INTEGER(I4)                              :: k        ! number of bins
    REAL(SP), DIMENSION(2)                   :: w        ! binwidth
    REAL(SP), DIMENSION(2)                   :: minimalvalue
    INTEGER(I4)                              :: i, j
    INTEGER(I4)                              :: binnr, binnr1, binnr2
    !REAL(SP), DIMENSION(:),ALLOCATABLE       :: helpbinx
    !INTEGER(I4), DIMENSION(:),ALLOCATABLE    :: helpbincount

    if (present(mask)) then
       if (size(mask) /= size(x,1)) stop 'Error histo_sp: size(mask) /= size(x)'
       maske = mask
       n = count(maske)
    else
       maske(:) = .true.
       n = size(x,1)
    endif

    if (n .le. (1.0_sp+tiny(1.0_sp))) then
       stop 'Error histo2d_sp: size(x) must be at least 2'
    end if
    !if (maxval(x(:), mask=maske)-minval(x(:), mask=maske) <= tiny(1.0_sp)) then
    !   stop 'Error histo_sp: all entries of x(:) are equal'
    !end if

    if (present(bins) .and. present(binwidth)) then
       stop 'Error histo2d_sp: Either fix number of bins or binwidth, not both.'
    end if

    if (present(bins)) then
       if (bins .le. 1_i4) stop 'Error histo2d_sp: number of bins <= 1'
       k = bins
       w(1) = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,sp)
       w(2) = (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / real(k,sp)
    else
       if (present(binwidth)) then
          if (any(binwidth .le. tiny(1.0_sp))) stop 'Error histo2d_sp: width of bins too small'
          if (size(binwidth,1) .ne. 2_i4) stop 'Error histo2d_sp: size(width) has to be 2'
          w(:) = binwidth(:)
          k = Max( Ceiling( (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / w(1) ), &
               Ceiling( (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / w(2) ) )
       else
          k = Floor(Sqrt(real(n,sp)))
          w(1) = (maxval(x(:,1), mask=maske)-minval(x(:,1), mask=maske)) / real(k,sp)
          w(2) = (maxval(x(:,2), mask=maske)-minval(x(:,2), mask=maske)) / real(k,sp)
       end if
    endif

    ! Histogram

    allocate (binx(k*k,2),bincount(k*k))

    minimalvalue(1)=minval(x(:,1), mask=maske)
    minimalvalue(2)=minval(x(:,2), mask=maske)

    do i=1,k
       do j=1,k
          binx((i-1)*k+j,1)   = minimalvalue(1) + real(2*j-1,sp)/2.0_sp*w(1)
          binx((i-1)*k+j,2)   = minimalvalue(2) + real(2*i-1,sp)/2.0_sp*w(2)
          bincount((i-1)*k+j) = 0_i4
       end do
    end do

    do i=1,size(x,1)
       If (maske(i)) then
          !print*, 'x(i) = ',x(i,:)
          binnr1 =   Floor((x(i,1)-minimalvalue(1))/w(1) )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr1 =   binnr1 - Floor(real(binnr1,sp)/real(k,sp)) + 1_i4
          !print*, 'i = ',i,'  binnr 1 = ',binnr1

          binnr2 =   Floor((x(i,2)-minimalvalue(2))/w(2) )
          ! maxval(x) has to be assigned to last bin k not k+1
          binnr2 =   binnr2 - Floor(real(binnr2,sp)/real(k,sp)) + 1_i4
          !print*, 'i = ',i,'  binnr 2 = ',binnr2

          binnr           = (binnr2-1_i4)*k + binnr1
          !print*, 'i = ',i,'  binnr 3 = ',binnr
          bincount(binnr) = bincount(binnr) + 1_i4
       end if
    end do

    width(:) = w(:)

  END SUBROUTINE histo2d_sp
#endif

END MODULE mo_histo


      SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM,
     $                    NSPLIT, ISPLIT, INFO )
      IMPLICIT NONE
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N, NSPLIT
      REAL                SPLTOL, TNRM
*     ..
*     .. Array Arguments ..
      INTEGER            ISPLIT( * )
      REAL               D( * ), E( * ), E2( * )
*     ..
*
*  Purpose
*  =======
*
*  Compute the splitting points with threshold SPLTOL.
*  SLARRA sets any "small" off-diagonal elements to zero.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix. N > 0.
*
*  D       (input) REAL             array, dimension (N)
*          On entry, the N diagonal elements of the tridiagonal
*          matrix T.
*
*  E       (input/output) REAL             array, dimension (N)
*          On entry, the first (N-1) entries contain the subdiagonal
*          elements of the tridiagonal matrix T; E(N) need not be set.
*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
*          are set to zero, the other entries of E are untouched.
*
*  E2      (input/output) REAL             array, dimension (N)
*          On entry, the first (N-1) entries contain the SQUARES of the
*          subdiagonal elements of the tridiagonal matrix T;
*          E2(N) need not be set.
*          On exit, the entries E2( ISPLIT( I ) ),
*          1 <= I <= NSPLIT, have been set to zero
*
*  SPLTOL (input) REAL
*          The threshold for splitting. Two criteria can be used:
*          SPLTOL<0 : criterion based on absolute off-diagonal value
*          SPLTOL>0 : criterion that preserves relative accuracy
*
*  TNRM (input) REAL
*          The norm of the matrix.
*
*  NSPLIT  (output) INTEGER
*          The number of blocks T splits into. 1 <= NSPLIT <= N.
*
*  ISPLIT  (output) INTEGER array, dimension (N)
*          The splitting points, at which T breaks up into blocks.
*          The first block consists of rows/columns 1 to ISPLIT(1),
*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*          etc., and the NSPLIT-th consists of rows/columns
*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Beresford Parlett, University of California, Berkeley, USA
*     Jim Demmel, University of California, Berkeley, USA
*     Inderjit Dhillon, University of Texas, Austin, USA
*     Osni Marques, LBNL/NERSC, USA
*     Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               EABS, TMP1

*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      INFO = 0

*     Compute splitting points
      NSPLIT = 1
      IF(SPLTOL.LT.ZERO) THEN
*        Criterion based on absolute off-diagonal value
         TMP1 = ABS(SPLTOL)* TNRM
         DO 9 I = 1, N-1
            EABS = ABS( E(I) )
            IF( EABS .LE. TMP1) THEN
               E(I) = ZERO
               E2(I) = ZERO
               ISPLIT( NSPLIT ) = I
               NSPLIT = NSPLIT + 1
            END IF
 9       CONTINUE
      ELSE
*        Criterion that guarantees relative accuracy
         DO 10 I = 1, N-1
            EABS = ABS( E(I) )
            IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
     $      THEN
               E(I) = ZERO
               E2(I) = ZERO
               ISPLIT( NSPLIT ) = I
               NSPLIT = NSPLIT + 1
            END IF
 10      CONTINUE
      ENDIF
      ISPLIT( NSPLIT ) = N

      RETURN
*
*     End of SLARRA
*
      END


SUBROUTINE fsparv(kv,km,g,kdiag)
!
! This subroutine assembles element matrices into a symmetric skyline
! global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::g(:),kdiag(:)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::kv(:)
 INTEGER::i,idof,k,j,iw,ival
 idof=UBOUND(g,1)
 DO i=1,idof
   k=g(i)
   IF(k/=0)THEN
     DO j=1,idof
       IF(g(j)/=0)THEN
         iw=k-g(j)
         IF(iw>=0)THEN
           ival=kdiag(k)-iw
           kv(ival)=kv(ival)+km(i,j)
         END IF
       END IF
     END DO
   END IF
 END DO
RETURN
END SUBROUTINE fsparv


program main
    use FEMDomainClass
    implicit none

    type(FEMDomain_) :: root2d, rootRandom(2)
    type(Random_) :: random
    integer(int32) :: i
    real(real64) :: length, rot_x,x,y,z

    ! case #1 :: create root by rule
    call root2d%create(meshtype="root")
    length=1.0d0
    rot_x = 0.0d0
    do i=1,2999
        rot_x = rot_x + 0.010d0
        call root2d%add(Length=length,rot_x=rot_x)
        length=length*0.9990d0
    enddo

    call root2d%add(From=100,Length=length,rot_x=rot_x)
    length=1.0d0
    rot_x = 0.0d0
    do i=1,1000
        rot_x = rot_x + 0.010d0
        call root2d%add(Length=length,rot_x=rot_x)
        length=length*0.9990d0
    enddo

    call root2d%add(From=300,Length=length,rot_x=rot_x)
    length=1.0d0
    rot_x = 0.0d0
    do i=1,1000
        rot_x = rot_x + 0.010d0
        call root2d%add(Length=length,rot_z=rot_x)
        length=length*0.9990d0
    enddo

    call root2d%add(From=1000,Length=length,rot_z=rot_x)
    length=1.0d0
    do i=1,1000
        rot_x = rot_x + 0.010d0
        call root2d%add(Length=length,rot_z=rot_x)
        length=length*0.9990d0
    enddo

    call root2d%msh("root")

    call random%init()

    ! case #2 :: randomly generated 2d root
    x = random%gauss(mu=0.0d0,sigma=1.0d0)
    y = 0.0d0
    z = random%gauss(mu=0.0d0,sigma=1.0d0)
    call rootRandom(1)%create(meshtype="root",x=x,y=y,z=z)
    do i=1,1000
        x = random%gauss(mu=0.0d0,sigma=1.0d0)
        y = 0.0d0
        z = random%gauss(mu=0.0d0,sigma=1.0d0)
        call rootRandom(1)%add(x=x,y=y,z=z)
    enddo
    call rootRandom(1)%msh("random-2d")

    ! case #3 :: randomly generated 2d root
    x = random%gauss(mu=0.0d0,sigma=1.0d0)
    y = random%gauss(mu=0.0d0,sigma=1.0d0)
    z = random%gauss(mu=0.0d0,sigma=1.0d0)
    call rootRandom(2)%create(meshtype="root",x=x,y=y,z=z)
    do i=1,1000
        x = random%gauss(mu=0.0d0,sigma=1.0d0)
        y = random%gauss(mu=0.0d0,sigma=1.0d0)
        z = random%gauss(mu=0.0d0,sigma=1.0d0)
        call rootRandom(2)%add(x=x,y=y,z=z)
    enddo
    call rootRandom(2)%msh("random-3d_x")

    ! case #4 :: randomly generated 2d root (give dx, dy and dz)
    x = random%gauss(mu=0.0d0,sigma=1.0d0)
    y = random%gauss(mu=0.0d0,sigma=1.0d0)
    z = random%gauss(mu=0.0d0,sigma=1.0d0)
    call rootRandom(2)%create(meshtype="root",dx=x,dy=y,dz=z)
    do i=1,1000
        x = random%gauss(mu=0.0d0,sigma=1.0d0)
        y = random%gauss(mu=0.0d0,sigma=1.0d0)
        z = random%gauss(mu=0.0d0,sigma=1.0d0)
        call rootRandom(2)%add(dx=x,dy=y,dz=z)
    enddo
    call rootRandom(2)%msh("random-3d_dx")

end program main


!
!
!
   INTEGER FUNCTION MJ (J)
   IMPLICIT NONE
   INTEGER J, L, M, K
   REAL*4 Z
!
! Given the harmonic index j=l(l+1)/2+m+1, returns m (order)
! -GS 10.09.07
!
 If(j<0) then
	  Write(88,*) "MJ: The J-index is out of bounds"
 	  Write(88,*) "The program will STOP ----------"
 	  Write(*, *) "MJ: The J-index is out of bounds"
 	  Write(*, *) "The program will STOP ----------"
          call stop_config
	  Stop
 endif
!
   mj=0
   k=j
10 z=(-1.0+sqrt(8.*float(k)-7.))/2.
   l=aint(z)
   if(z-aint(z)==0.) return
   k=k-1
   mj=mj+1
   goto 10
   return
   end FUNCTION MJ
!
!
!


      SUBROUTINE PREFIL(A,NA,B,NB,Q,NQ,W,NW,R,NR,F,NF,IOP,DUMMY)
C
C   PURPOSE:
C      Compute an r x n (r <= n) matrix F which, when used in the vector
C      equation u = -Fx + v eliminates the cross-product term in the
C      quadratic scalar function, x'Qx + x'Wu + u'Ru, where Q = Q'>=0,
C      W, and R=R'>0 are constant matrices.  Specifically, F=(R**-1)
C      (W/2).
C
C   Subroutines employed by PREFIL: DPOCO, DPOSL, EQUATE, LNCNT, MULT,
C      PRNT, SCALE, SUBT, TRANP
C   Subroutines employing PREFIL: IMMDFL
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),Q(1),W(1),R(1),F(1),DUMMY(1)
      DIMENSION NA(2),NB(2),NQ(2),NW(2),NR(2),NF(2),IOP(3)
C
      IF( IOP(1) .EQ. 0 ) GO TO 100
      CALL LNCNT(5)
      WRITE(6,25)
   25 FORMAT(// ' PROGRAM TO COMPUTE PREFILTER GAIN F TO ELIMINATE  CROS
     1S-PRODUCT TERM '/' IN QUADRATIC PERFORMANCE INDEX '/)
      IF( IOP(3) .EQ. 0 ) GO TO 50
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(B,NB,' B  ',1)
   50 CONTINUE
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL PRNT(W,NW,' W  ',1)
      CALL PRNT(R,NR,' R  ',1)
C
  100 CONTINUE
      CALL TRANP(W,NW,F,NF)
      CALL SCALE(F,NF,F,NF,0.5D0)
      CALL EQUATE(R,NR,DUMMY,NR)
      N1 = NR(1)**2 + 1
      M = NR(1)
C
C   * * * CALL TO MATHLIB FUNCTIONS * * *
      CALL DPOCO(DUMMY,M,M,RCOND,DUMMY(N1),IERR)
      IF( IERR .EQ. 0 ) GO TO 200
      CALL LNCNT(4)
      WRITE(6,150)
  150 FORMAT(//' IN PREFIL, THE MATRIX R IS NOT POSITIVE DEFINITE'/)
      RETURN
C
  200 CONTINUE
      NT = 1
      DO 250 M1 = 1,NF(2)
         CALL DPOSL(DUMMY,M,M,F(NT))
         NT = NT + M
  250 CONTINUE
      IF( IOP(2) .EQ. 0 ) GO TO 300
      CALL MULT(W,NW,F,NF,DUMMY,NQ)
      CALL SCALE(DUMMY,NQ,DUMMY,NQ,0.5D0)
      CALL SUBT(Q,NQ,DUMMY,NQ,Q,NQ)
C
  300 CONTINUE
      IF( IOP(3) .EQ. 0 ) GO TO 400
      CALL MULT(B,NB,F,NF,DUMMY,NA)
      CALL SUBT(A,NA,DUMMY,NA,A,NA)
C
  400 CONTINUE
      IF( IOP(1) .EQ. 0 ) RETURN
      CALL PRNT(F,NF,' F  ',1)
      IF( IOP(2) .EQ. 0 ) GO TO 500
      CALL LNCNT(3)
      WRITE(6,450)
  450 FORMAT(/ ' MATRIX  Q - (W/2)F '/)
      CALL PRNT(Q,NQ,'NEWQ',1)
C
  500 CONTINUE
      IF( IOP(3) .EQ. 0 ) RETURN
      CALL PRNT(A,NA,'NEWA',1)
      RETURN
      END


program test_cova

   use libatoms_module
   use real_space_covariance_module

   implicit none

   type(RealSpaceCovariance), target :: rscov
   type(CInOutput) :: in
   type(Atoms) :: at
   real(dp), pointer :: force_ptr(:,:)
   real(dp) :: force(3), error, r0
   type(Dictionary) :: params
   character(STRING_LENGTH) :: teaching_file, test_file
   logical :: do_optimise, use_qr, test_data, do_teach, print_covariance, test_data_2
   integer n_grid_minim
   real(dp) :: sigma_alpha, sigma_beta, sigma_covariance, sigma_error, cutoff_in, transition_width, covariance_tol

   type(minimise_overlap) :: am
   integer :: i, j, am_data_size
   character(len=1), dimension(1) :: am_mold
   character(len=1), allocatable :: am_data(:)
   real(dp) :: q(4), cov, d2, force_covariance, force_difference

   call system_initialise(enable_timing=.false.)

   call initialise(params)
   call param_register(params, 'n_grid_minim', '5', n_grid_minim, "start minimisations from the n_grid_minim biggest overlap grid points")
   call param_register(params, 'sigma_alpha', '0.1', r0, "Set sigma_rho via equation sigma_rho = sigma_alpha*r**2 + sigma_beta")
   call param_register(params, 'sigma_beta', '0.0', r0, "Set sigma_rho via equation sigma_rho = sigma_alpha*r**2 + sigma_beta")
   call param_register(params, 'sigma_covariance', '0.5', sigma_covariance, "sigma used for construction of covariance")
   call param_register(params, 'sigma_error', '0.1', sigma_error, "expected error on forces")
   call param_register(params, 'cutoff', '5.0', cutoff_in, "cutoff radius used for rho")
   call param_register(params, 'transition_width', '0.5', transition_width, "transition width used for rho")
   call param_register(params, 'covariance_tol', '0.001', covariance_tol, "Covariance tolerance used for minimizations")
   call param_register(params, 'teaching_file', 'data.xyz', teaching_file, "file to read teaching configurations from")
   call param_register(params, 'test_file', 'test.xyz', test_file, "file to read test configuration from")
   call param_register(params, 'do_teach', 'T', do_teach, "do teaching? (default T)")
   call param_register(params, 'do_optimise', 'F', do_optimise, "do likelihood optimisation in the space of hyperparameters")
   call param_register(params, 'print_covariance', 'F', print_covariance, "print covariance of each config with frame 0")
   call param_register(params, 'use_qr', 'F', use_qr, "Use QR decomposition instead of Cholesky for likelihood optimisation")
   call param_register(params, 'test_data', 'T', test_data, "Include teaching data in test set (default T)")
   call param_register(params, 'test_data_2', 'F', test_data_2, "Test data using method #2 (default F)")

   if (.not. param_read_args(params, task="test_cova command line params")) then
      call print("Usage: test_cova [options]")
      call system_abort("Confused by command line arguments")
   end if

   call print_title('params')
   call param_print(params)
   call finalise(params)

   call print_title('teaching')
   call initialise(in, teaching_file, INPUT)
   call print('Got '//in%n_frame//' teaching configurations.')

   call initialise(rscov, in%n_frame, n_grid_minim, sigma_alpha, sigma_beta, sigma_covariance, sigma_error, cutoff_in, transition_width, covariance_tol)
   do i=1,in%n_frame
      call read(in, rscov%data(i))
      call centre_on_atom_1(rscov%data(i))
   end do
   call finalise(in)

   if (print_covariance) then
      mainlog%prefix = 'COVARIANCE'
      do i=1,rscov%n
         call verbosity_push(PRINT_SILENT)
         cov = covariance(rscov, rscov%data(1), rscov%data(i), &
              q=rscov%q_min(:,i), &
              distance=d2, force_covariance=force_covariance, &
              force_difference=force_difference)
         call verbosity_pop()
         call print(i//' '//cov//'  '//d2//' '//force_covariance//' '//force_difference)
      end do
      mainlog%prefix = ''
   end if

   if (do_teach) then
      call teach(rscov, do_optimise, use_qr)
   end if

   ! Testing the implementation of overlap_func and doverlap_func.
   if(.false.) then
      am%at1 => rscov%data(1)
      am%at2 => rscov%data(1)
      am%rscov => rscov
      am_data_size = size(transfer(am,am_mold))
      allocate(am_data(am_data_size))
      am_data = transfer(am,am_mold)
      q = random_quaternion()
      !q = (/.99619_dp, .08716_dp, + 0.00000_dp, 0.00000_dp/)
      call print('starting test gradient')
      call verbosity_push(PRINT_NERD)
      call n_test_gradient(q,overlap_func,doverlap_func,data=am_data)
      print*, test_gradient(q,overlap_func,doverlap_func,data=am_data)
      call verbosity_pop()
   endif

   if (test_data) then
      mainlog%prefix = 'DATA'
      do i=1,size(rscov%data)
         call print_title('predict data('//i//')')

         call system_timer('predict_force')
         call predict(rscov, rscov%data(i), force, error)
         call system_timer('predict_force')
         call assign_property_pointer(rscov%data(i), 'force', force_ptr)
         call print('RESULT '//force_ptr(:,1)//' '//force//' '//' '//maxval(abs(force_ptr(:,1)-force))//' '//error)
      end do
      mainlog%prefix = ''
   end if

   if (trim(test_file) /= '') then
      call print_title('Test config')

      mainlog%prefix = 'TEST'
      call initialise(in, test_file, INPUT)
      do i=1,in%n_frame
         call read(in, at)
         call centre_on_atom_1(at)
         call system_timer('predict_force')
         call predict(rscov, at, force, error)
         call system_timer('predict_force')
         call assign_property_pointer(at, 'force', force_ptr)
         do j=1,size(rscov%data)
            call print('RESULT '//j//' q='//rscov%q_min(:,j)//' k='//rscov%k(j))
         end do
         call print('RESULT '//force_ptr(:,1)//' '//force//' '//maxval(abs(force_ptr(:,1)-force))//' '//error)
      end do
      mainlog%prefix = ''
      call finalise(in)
   end if

   if (test_data_2) then
      mainlog%prefix = 'DATA'
      do i=1,size(rscov%data)
         call print_title('predict_2 data('//i//')')

         call system_timer('predict_force')
         call predict_2(rscov, rscov%data(i), force, error)
         call system_timer('predict_force')
         call assign_property_pointer(rscov%data(i), 'force', force_ptr)
         call print('RESULT_2 '//force_ptr(:,1)//' '//force//' '//' '//maxval(abs(force_ptr(:,1)-force))//' '//error)
      end do
      mainlog%prefix = ''

      call print_title('Test config - method 2')

      mainlog%prefix = 'TEST'
      call initialise(in, test_file, INPUT)
      do i=1,in%n_frame
         call read(in, at)
         call centre_on_atom_1(at)
         call system_timer('predict_force')
         call predict_2(rscov, at, force, error)
         call system_timer('predict_force')
         call assign_property_pointer(at, 'force', force_ptr)
         do j=1,size(rscov%data)
            call print('RESULT_2 '//j//' q='//rscov%q_min(:,j)//' k='//rscov%k(j))
         end do
         call print('RESULT_2 '//force_ptr(:,1)//' '//force//' '//maxval(abs(force_ptr(:,1)-force))//' '//error)
      end do
      mainlog%prefix = ''
      call finalise(in)

   end if
   call system_finalise()

   call finalise(rscov)

end program test_cova


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

*   Exponentiation (** operator) to double complex powers.

	program p
	implicit double complex (c)

	parameter (N=6)
	integer rslts(N), expect(N)

	integer ctoi
	ctoi(c) = real(c) + dimag(c)

	data x2 / 2.0/
	data c2, c23, c11, c12/ (2, 0), (2, 3), (1, 1), (1, 2) /

	rslts(1) = ctoi( (2.1d0, 0.0) ** (2.0d0, 0.0) )
	rslts(2) = ctoi( (2.1, 0.0d0) ** c2)
	rslts(3) = ctoi( c23 ** x2 + .001 )
	rslts(4) = c23 ** c11 + 10
	rslts(5) = ctoi( 10 ** c12 )
	rslts(6) = ctoi(x2 ** (-1.0d0, 2.0) * 10)

c --- check results:

	call check(rslts, expect, N)

	data expect /
     +                4, 4, 7, 9, -11, 5      /

	end


      SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine the one-dimensional state feedback matrix G of the
C     linear time-invariant single-input system
C
C           dX/dt = A * X + B * U,
C
C     where A is an NCONT-by-NCONT matrix and B is an NCONT element
C     vector such that the closed-loop system
C
C           dX/dt = (A - B * G) * X
C
C     has desired poles. The system must be preliminarily reduced
C     to orthogonal canonical form using the SLICOT Library routine
C     AB01MD.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NCONT   (input) INTEGER
C             The order of the matrix A as produced by SLICOT Library
C             routine AB01MD.  NCONT >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix Z.  N >= NCONT.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             (LDA,NCONT)
C             On entry, the leading NCONT-by-NCONT part of this array
C             must contain the canonical form of the state dynamics
C             matrix A as produced by SLICOT Library routine AB01MD.
C             On exit, the leading NCONT-by-NCONT part of this array
C             contains the upper quasi-triangular form S of the closed-
C             loop system matrix (A - B * G), that is triangular except
C             for possible 2-by-2 diagonal blocks.
C             (To reconstruct the closed-loop system matrix see
C             FURTHER COMMENTS below.)
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,NCONT).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (NCONT)
C             On entry, this array must contain the canonical form of
C             the input/state vector B as produced by SLICOT Library
C             routine AB01MD.
C             On exit, this array contains the transformed vector Z * B
C             of the closed-loop system.
C
C     WR      (input) DOUBLE PRECISION array, dimension (NCONT)
C     WI      (input) DOUBLE PRECISION array, dimension (NCONT)
C             These arrays must contain the real and imaginary parts,
C             respectively, of the desired poles of the closed-loop
C             system. The poles can be unordered, except that complex
C             conjugate pairs of poles must appear consecutively.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, the leading N-by-N part of this array must
C             contain the orthogonal transformation matrix as produced
C             by SLICOT Library routine AB01MD, which reduces the system
C             to canonical form.
C             On exit, the leading NCONT-by-NCONT part of this array
C             contains the orthogonal matrix Z which reduces the closed-
C             loop system matrix (A - B * G) to upper quasi-triangular
C             form.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,N).
C
C     G       (output) DOUBLE PRECISION array, dimension (NCONT)
C             This array contains the one-dimensional state feedback
C             matrix G of the original system.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*NCONT)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The method is based on the orthogonal reduction of the closed-loop
C     system matrix (A - B * G) to upper quasi-triangular form S whose
C     1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles.
C     That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix.
C
C     REFERENCES
C
C     [1] Petkov, P. Hr.
C         A Computational Algorithm for Pole Assignment of Linear
C         Single Input Systems.
C         Internal Report 81/2, Control Systems Research Group, School
C         of Electronic Engineering and Computer Science, Kingston
C         Polytechnic, 1981.
C
C     NUMERICAL ASPECTS
C                                   3
C     The algorithm requires 0(NCONT ) operations and is backward
C     stable.
C
C     FURTHER COMMENTS
C
C     If required, the closed-loop system matrix (A - B * G) can be
C     formed from the matrix product Z * S * Z' (where S and Z are the
C     matrices output in arrays A and Z respectively).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB01AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, May 1981.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Closed loop spectrum, closed loop systems, eigenvalue assignment,
C     orthogonal canonical form, orthogonal transformation, pole
C     placement, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDZ, N, NCONT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*),
     $                  Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           COMPL
      INTEGER           I, IM1, K, L, LL, LP1, NCONT2, NI, NJ
      DOUBLE PRECISION  B1, P, Q, R, S, T
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT,
     $                  DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NCONT.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.NCONT ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN
         INFO = -4
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return
C
         CALL XERBLA( 'SB01MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( NCONT.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
C     Return if the system is not complete controllable.
C
      IF ( B(1).EQ.ZERO )
     $   RETURN
C
      IF ( NCONT.EQ.1 ) THEN
C
C        1-by-1 case.
C
         P = A(1,1) - WR(1)
         A(1,1) = WR(1)
         G(1) = P/B(1)
         Z(1,1) = ONE
         RETURN
      END IF
C
C     General case.  Save the contents of WI in DWORK.
C
      NCONT2 = 2*NCONT
      CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 )
C
      B1 = B(1)
      B(1) = ONE
      L  = 0
      LL = 0
   20 CONTINUE
      L  = L + 1
      LL = LL + 1
      COMPL = DWORK(NCONT2+L).NE.ZERO
      IF ( L.NE.NCONT ) THEN
         LP1 = L + 1
         IF ( LL.NE.2 ) THEN
            IF ( COMPL ) THEN
C
C              Compute complex eigenvector.
C
               DWORK(NCONT) = ONE
               DWORK(NCONT2) = ONE
               P = WR(L)
               T = DWORK(NCONT2+L)
               Q = T*DWORK(NCONT2+LP1)
               DWORK(NCONT2+L) = ONE
               DWORK(NCONT2+LP1) = Q
C
               DO 40 I = NCONT, LP1, -1
                  IM1 = I - 1
                  DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) )
     $               /A(I,IM1)
                  DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) )
     $               /A(I,IM1)
   40          CONTINUE
C
            ELSE
C
C              Compute real eigenvector.
C
               DWORK(NCONT) = ONE
               P = WR(L)
C
               DO 60 I = NCONT, LP1, -1
                  IM1 = I - 1
                  DWORK(IM1) = ( P*DWORK(I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) )
     $               /A(I,IM1)
   60          CONTINUE
C
            END IF
         END IF
C
C        Transform eigenvector.
C
         DO 80 K = NCONT - 1, L, -1
            IF ( LL.NE.2 ) THEN
               R = DWORK(K)
               S = DWORK(K+1)
            ELSE
               R = DWORK(NCONT+K)
               S = DWORK(NCONT+K+1)
            END IF
            CALL DLARTG( R, S, P, Q, T )
            DWORK(K) = T
            IF ( LL.NE.2 ) THEN
               NJ = MAX( K-1, L )
            ELSE
               DWORK(NCONT+K) = T
               NJ = L - 1
            END IF
C
C           Transform  A.
C
            CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q )
C
            IF ( COMPL .AND. LL.EQ.1 ) THEN
               NI = NCONT
            ELSE
               NI = MIN( K+2, NCONT )
            END IF
            CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q )
C
            IF ( K.EQ.L ) THEN
C
C              Transform  B.
C
               T = B(K)
               B(K) = P*T
               B(K+1) = -Q*T
            END IF
C
C           Accumulate transformations.
C
            CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q )
C
            IF ( COMPL .AND. LL.NE.2 ) THEN
               T = DWORK(NCONT+K)
               DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1)
               DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T
            END IF
   80    CONTINUE
C
      END IF
C
      IF ( .NOT.COMPL ) THEN
C
C        Find one element of  G.
C
         K = L
         R = B(L)
         IF ( L.NE.NCONT ) THEN
            IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN
               K = LP1
               R = B(LP1)
            END IF
         END IF
         P = A(K,L)
         IF ( K.EQ.L ) P = P - WR(L)
         P = P/R
C
         CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 )
C
         G(L) = P/B1
         IF ( L.NE.NCONT ) THEN
            LL = 0
            GO TO 20
         END IF
      ELSE IF ( LL.EQ.1 ) THEN
         GO TO 20
      ELSE
C
C        Find two elements of  G.
C
         K = L
         R = B(L)
         IF ( L.NE.NCONT ) THEN
            IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN
               K = LP1
               R = B(LP1)
            END IF
         END IF
         P = A(K,L-1)
         Q = A(K,L)
         IF ( K.EQ.L ) THEN
            P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L)
            Q = Q - WR(L) +
     $            ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L)
         END IF
         P = P/R
         Q = Q/R
C
         CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 )
         CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 )
C
         G(L-1) = P/B1
         G(L) = Q/B1
         IF ( L.NE.NCONT ) THEN
            LL = 0
            GO TO 20
         END IF
      END IF
C
C     Transform  G.
C
      CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1,
     $            ZERO, DWORK, 1 )
      CALL DCOPY( NCONT, DWORK, 1, G, 1 )
      CALL DSCAL( NCONT, B1, B, 1 )
C
C     Annihilate A after the first subdiagonal.
C
      IF ( NCONT.GT.2 )
     $   CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1),
     $                LDA )
C
      RETURN
C *** Last line of SB01MD ***
      END


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

      program ip_exp

      ! Test L2 inner product of two DLR expansions for Green's
      ! functions which are each a single exponential. Compare result
      ! with analytically-known inner product.

      implicit none
      real *8 lambda,eps,beta

      ! Input parameters

      lambda = 10.0d0   ! DLR high energy cutoff
      eps = 1.0d-14       ! DLR error tolerance

      beta = 10.0d0     ! Inverse temperature

      ! Main test subroutine

      call ip_exp_main(lambda,eps,beta)

      end program ip_exp

      subroutine ip_exp_main(lambda,eps,beta)

      implicit none
      real *8 lambda,eps,beta

      integer j,k,r
      integer, allocatable :: it2cfp(:)
      real *8 ip,err
      real *8, allocatable :: it2cf(:,:),dlrit(:),dlrrf(:),g1(:),g2(:)
      real *8, allocatable :: ipmat(:,:)
      real *8, external :: iptrue

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

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

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

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

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

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

      ! Sample G1 and G2 at imaginary time nodes

      allocate(g1(r),g2(r))

      do j=1,r

        call gfun1(beta,dlrit(j),g1(j))
        call gfun2(beta,dlrit(j),g2(j))

      enddo

      ! Get inner product weight matrix ipmat

      allocate(ipmat(r,r))

      call dlr_ipmat(beta,r,dlrit,dlrrf,it2cf,it2cfp,ipmat)

      ! Compute inner product by g1^T * ipmat * g2

      g2 = matmul(ipmat,g2)
      ip = sum(g1*g2)

      ! Compute error

      err = abs(ip-iptrue(beta))

      write(6,*) ''
      write(6,*) 'DLR rank = ',r
      write(6,*) 'Abs err = ',err
      write(6,*) 'Rel err   = ',err/abs(iptrue(beta))
      write(6,*) ''

      ! Return failed status if error is not sufficiently small

      if (err.gt.1.0d-13) then
        call exit(1)
      endif

      end subroutine ip_exp_main

      subroutine gfun1(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1

      a1 = 0.804d0

      g = kfunf_rel(t,beta*a1)

      end subroutine gfun1

      subroutine gfun2(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a2

      a2 = -0.443d0

      g = kfunf_rel(t,beta*a2)

      end subroutine gfun2

      function iptrue(beta)

      ! Evaluate Green's function corresponding to convolution of two
      ! single exponentials

      implicit none
      real *8 iptrue,beta

      real *8 a1,a2
      real *8, external :: kfunf

      a1 = 0.804d0
      a2 = -0.443d0

      a1 = beta*a1
      a2 = beta*a2

      iptrue = beta*kfunf(0.0d0,a1)*kfunf(0.0d0,a2)&
        *(1.0d0-exp(-(a1+a2)))/(a1+a2)

      end function iptrue


!***********************************************************************
!                                                                      *
      SUBROUTINE COUNT(FR, MTPFR, NNCFF, SGN)
!                                                                      *
!   This subroutine counts the nodes in the radial function FR using   *
!   the criteria  given by C Froese Fischer, Comp Phys Rep, 3 (1986)   *
!   314-315 . The  function FR is assumed defined on the first MTPFR   *
!   points of the radial grid. The sign of the function at the first   *
!   oscillation is also determined.                                    *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 08 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:46:58   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------                       *
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param,  ONLY: DOUBLE
      USE parameter_def,    ONLY: NNNP
      USE COUN_C
      USE DEF_C, ONLY: ACCY
      USE GRID_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: MTPFR
      INTEGER, INTENT(OUT) :: NNCFF
      REAL(DOUBLE), INTENT(OUT) :: SGN
      REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: FR
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER, DIMENSION(NNNP) :: LCEXT
      INTEGER :: NEXT, I, LOC, NSTPS
      REAL(DOUBLE) :: EXT, EMX, ABFRI, TEST, THRESE, ABLCL
!-----------------------------------------------
!
!
!   (1) Find all extrema in FR
!   (2) Find the maximum amplitudes of FR
!
      NEXT = 1
      EXT = 0.0D00
      LCEXT(1) = 1
      EMX = 0.0D00
      DO I = 2, MTPFR
         ABFRI = ABS(FR(I))
         TEST = ABS(SIGN(1.0D00,FR(I))+SIGN(1.0D00,FR(I-1)))
         IF (TEST <= ACCY) THEN
            NEXT = NEXT + 1
            LCEXT(NEXT) = 0
            EXT = 0.0D00
         ENDIF
         IF (ABFRI > EXT) THEN
            EXT = ABFRI
            LCEXT(NEXT) = I
         ENDIF
         IF (ABFRI <= EMX) CYCLE
         EMX = ABFRI
      END DO
!
!   Eliminate oscillations with amplitude less than THRESH times
!   the maximum
!
      LOC = 0
      THRESE = THRESH*EMX
    4 CONTINUE
      LOC = LOC + 1
      IF (LOC <= NEXT) THEN
         IF (LCEXT(LOC) == 0) THEN
            ABLCL = 0.0D00
         ELSE
            ABLCL = ABS(FR(LCEXT(LOC)))
         ENDIF
         IF (ABLCL < THRESE) THEN
            NEXT = NEXT - 1
            NSTPS = NEXT - LOC
            LCEXT(LOC:NSTPS+LOC) = LCEXT(LOC+1:NSTPS+1+LOC)
            LOC = LOC - 1
         ENDIF
         GO TO 4
      ENDIF
!
!   Count changes of sign using the remaining oscillations
!
      NNCFF = 0
      DO I = 2, NEXT
         TEST = ABS(SIGN(1.0D00,FR(LCEXT(I)))+SIGN(1.0D00,FR(LCEXT(I-1))))
         IF (TEST > ACCY) CYCLE
         NNCFF = NNCFF + 1
      END DO
!
!   Determine the position of the first oscillation, and the
!   sign of the function at this location
!
      SGN = SIGN(1.0D00,FR(LCEXT(1)))
!
      RETURN
      END SUBROUTINE COUNT


!   DTGEVC Example Program Text
!   Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!   For licence see
!     https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

    Module dtgevc_example_mod

!     DTGEVC Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public :: normalize
!     .. Parameters ..
      Real (Kind=dp), Parameter, Public :: one = 1.0_dp
      Real (Kind=dp), Parameter, Public :: zero = 0.0_dp
      Integer, Parameter, Public :: nin = 5, nout = 6
    Contains
      Subroutine normalize(n, alphai, v, ldv)

!       .. Use Statements ..
        Use blas_interfaces, Only: dnrm2
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: ldv, n
!       .. Array Arguments ..
        Real (Kind=dp), Intent (In) :: alphai(n)
        Real (Kind=dp), Intent (Inout) :: v(ldv, *)
!       .. Local Scalars ..
        Real (Kind=dp) :: a, b, r, r1, r2, v1, v2
        Integer :: i, j, k
!       .. Intrinsic Procedures ..
        Intrinsic :: sqrt
!       .. Executable Statements ..

        Do j = 1, n

          If (alphai(j)>=0.0_dp) Then
            If (alphai(j)==0.0_dp) Then
!             Real eigenvalue
!             The 2-norm of Q is calculated using dnrm2.
              r = dnrm2(n, v(1,j), 1)
              v(1:n, j) = v(1:n, j)/r
            Else
!             Complex eigenvalue (positive imaginary part)
!             Make largest element real and positive
              r1 = dnrm2(n, v(1,j), 1)
              r2 = dnrm2(n, v(1,j+1), 1)
              r1 = sqrt(r1**2+r2**2)
              r2 = -1.0_dp
              Do i = 1, n
                r = v(i, j)**2 + v(i, j+1)**2
                If (r>r2) Then
                  r2 = r
                  k = i
                End If
              End Do
              r = r1*sqrt(r2)
              a = v(k, j)/r
              b = v(k, j+1)/r
              Do i = 1, n
                v1 = v(i, j)
                v2 = v(i, j+1)
                v(i, j) = v1*a + v2*b
                v(i, j+1) = v2*a - v1*b
              End Do
            End If
          End If
        End Do
      End Subroutine
    End Module
    Program dtgevc_example

!     DTGEVC Example Main Program

!     .. Use Statements ..
      Use dtgevc_example_mod, Only: nin, normalize, nout, one, zero
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen_comp
      Use lapack_interfaces, Only: dgeqrf, dggbak, dggbal, dgghrd, dhgeqz, &
        dlacpy, dlaset, dorgqr, dormqr, dtgevc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Integer :: i, icols, ifail, ihi, ilo, info, irows, jwork, lda, ldb, &
        ldvl, ldvr, lwork, m, n
      Logical :: ileft, iright
      Character (1) :: compq, compz, howmny, job, side
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), lscale(:), rscale(:), tau(:), vl(:, :), vr(:, :), work(:)
      Logical, Allocatable :: select(:)
      Character (0) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: nint
!     .. Executable Statements ..
      Write (nout, *) 'DTGEVC Example Program Results'
      Flush (nout)

!     ileft  is TRUE if left  eigenvectors are required
!     iright is TRUE if right eigenvectors are required

      ileft = .True.
      iright = .True.

!     Skip heading in data file

      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvl = n
      ldvr = n
      lwork = 6*n
      Allocate (a(lda,n), alphai(n), alphar(n), b(ldb,n), beta(n), lscale(n), &
        rscale(n), tau(n), vl(ldvl,ldvl), vr(ldvr,ldvr), work(lwork), &
        select(n))

!     READ matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     READ matrix B from data file
      Read (nin, *)(b(i,1:n), i=1, n)

!     Balance matrix pair (A,B)
      job = 'B'
      Call dggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, &
        info)

!     Matrix A after balancing
!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, a, lda, &
        'F8.4', 'Matrix A after balancing', 'I', rlabs, 'I', clabs, 80, 0, &
        ifail)
      Write (nout, *)
      Flush (nout)

!     Matrix B after balancing
      ifail = 0
      Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, b, ldb, &
        'F8.4', 'Matrix B after balancing', 'I', rlabs, 'I', clabs, 80, 0, &
        ifail)
      Write (nout, *)
      Flush (nout)

!     Reduce B to triangular form using QR
      irows = ihi + 1 - ilo
      icols = n + 1 - ilo
      Call dgeqrf(irows, icols, b(ilo,ilo), ldb, tau, work, lwork, info)

!     Apply the orthogonal transformation to matrix A
      Call dormqr('L', 'T', irows, icols, irows, b(ilo,ilo), ldb, tau, &
        a(ilo,ilo), lda, work, lwork, info)

!     Initialize VL (if left eigenvectors are required)
      If (ileft) Then

        Call dlaset('General', n, n, zero, one, vl, ldvl)
        Call dlacpy('Lower', irows-1, irows-1, b(ilo+1,ilo), ldb, &
          vl(ilo+1,ilo), ldvl)

        Call dorgqr(irows, irows, irows, vl(ilo,ilo), ldvl, tau, work, lwork, &
          info)
      End If

!     Initialize VR (if right eigenvectors are required)
      If (iright) Then
        Call dlaset('General', n, n, zero, one, vr, ldvr)
      End If

!     Compute the generalized Hessenberg form of (A,B)
      compq = 'V'
      compz = 'V'
      Call dgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, vl, ldvl, vr, &
        ldvr, info)

!     Matrix A in generalized Hessenberg form
      ifail = 0
      Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, a, lda, &
        'F8.4', 'Matrix A in Hessenberg form', 'I', rlabs, 'I', clabs, 80, 0, &
        ifail)
      Write (nout, *)
      Flush (nout)

!     Matrix B in generalized Hessenberg form
      ifail = 0
      Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, b, ldb, &
        'F8.4', 'Matrix B in Hessenberg form', 'I', rlabs, 'I', clabs, 80, 0, &
        ifail)

!     Routine DHGEQZ
!     Workspace query: jwork = -1

      jwork = -1
      job = 'S'

      Call dhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alphar, &
        alphai, beta, vl, ldvl, vr, ldvr, work, jwork, info)

      Write (nout, *)
      Write (nout, 100) nint(work(1))
      Write (nout, 110) lwork
      Write (nout, *)
      Write (nout, 120)
      Write (nout, 130)

!     Compute the generalized Schur form
!     if the workspace lwork is adequate
!     The Schur form also gives parameters
!     required to compute generalized eigenvalues

      If (nint(work(1))<=lwork) Then

        Call dhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alphar, &
          alphai, beta, vl, ldvl, vr, ldvr, work, lwork, info)

!       Print the generalized eigenvalues

        Do i = 1, n
          If (beta(i)/=0.0E0_dp) Then
            Write (nout, 140) i, '(', alphar(i)/beta(i), ',', &
              alphai(i)/beta(i), ')'
          Else
            Write (nout, 130) i
          End If
        End Do
        Write (nout, *)
        Flush (nout)

!       Compute left and right generalized eigenvectors
!       of the balanced matrix

        howmny = 'B'
        If (ileft .And. iright) Then
          side = 'B'
        Else If (ileft) Then
          side = 'L'
        Else If (iright) Then
          side = 'R'
        End If

        Call dtgevc(side, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, &
          ldvr, n, m, work, info)

        If (iright) Then

!         Compute right eigenvectors of the original matrix

          job = 'B'
          side = 'R'

          Call dggbak(job, side, n, ilo, ihi, lscale, rscale, n, vr, ldvr, &
            info)

          Call normalize(n, alphai, vr, ldvr)
!         Print the right eigenvectors

          ifail = 0
          Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, vr, &
            ldvr, 'F8.4', 'Right eigenvectors', 'I', rlabs, 'I', clabs, 80, 0, &
            ifail)

          Write (nout, *)
          Flush (nout)
        End If

!       Compute left eigenvectors of the original matrix

        If (ileft) Then
          job = 'B'
          side = 'L'

          Call dggbak(job, side, n, ilo, ihi, lscale, rscale, n, vl, ldvl, &
            info)

          Call normalize(n, alphai, vl, ldvl)
!         Print the left eigenvectors

          ifail = 0
          Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, vl, &
            ldvl, 'F8.4', 'Left eigenvectors', 'I', rlabs, 'I', clabs, 80, 0, &
            ifail)

        End If
      Else
        Write (nout, 150)
      End If

100   Format (1X, 'Minimal required LWORK = ', I6)
110   Format (1X, 'Actual value of  LWORK = ', I6)
120   Format (1X, 'Generalized eigenvalues')
130   Format (1X, I4, 5X, 'Infinite eigenvalue')
140   Format (1X, I4, 5X, A, F7.3, A, F7.3, A)
150   Format (1X, 'Insufficient workspace for array WORK', /, ' in DHGEQZ/', &
        'DHGEQZ')
    End Program


        FUNCTION PR_PR24 ( p01, p02, p03, p04 )
C************************************************************************
C* PR_PR24                                                              *
C*                                                                      *
C* This function computes PR24, the 24-hour precipitation calculated by *
C* summing four 6-hour precipitation values.                            *
C*                                                                      *
C* REAL PR_PR24  ( P01, P02, P03, P04 )					*
C*                                                                      *
C* Input parameters:                                                    *
C*      P01		REAL	First 6-hour precipitation amount	*
C*	P02 		REAL    Second 6-hour precipitation amount	*
C*	P03		REAL    Third 6-hour precipitation amount	*
C*	P04		REAL    Fourth 6-hour precipitation amount	*
C*                                                                      *
C* Output parameters:                                                   *
C*      PR_PR24         REAL    Total 24-hour precipitation amount      *
C**                                                                     *
C* Log:                                                                 *
C* D. Kidwell/NCEP	11/00                                           *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
C------------------------------------------------------------------------
	p24 = AMAX1 ( p01, p02, p03, p04 )
C
	IF ( p24 .gt. 0. ) THEN
	    p24 = 0.
	    IF ( p01 .gt. 0. ) p24 = p24 + p01
	    IF ( p02 .gt. 0. ) p24 = p24 + p02
	    IF ( p03 .gt. 0. ) p24 = p24 + p03
	    IF ( p04 .gt. 0. ) p24 = p24 + p04
	  ELSE IF ( p24 .lt. 0. ) THEN
            p24 = RMISSD
	END IF
C
	PR_PR24 = p24
C*
        RETURN
        END


      program interpolate
!
!
!     Pure cubic-spline interpolation, so extremes are not restricted to the
!     amplitude at digitized points.  Source:  Forsythe, G.E., M.A. Malcolm,
!     and C.B. Moler, 1977. Computer Methods for Mathematical Computations,
!     Prentice-Hall, Inc.
!     Read in a sac file, delta_new, and number of characters in extension.
!     If extension is dHHZ, output is idHHZ.
!     Interpolation keeps start and stop times unchanged.

      parameter (max=524288)
      real*4 signal(max), signal_out(max),time_in(max)
      real*4 a(max),b(max),c(max)
      character filename*80, name*20

      nmarg = iargc()
      if (nmarg .eq. 0) then
         write(*,*)'Usage: interpolate filename delta_new'
         write(*,*)'  filename: the input filename,'
         write(*,*)'  delta_new: the new digitizing interval,'
         write(*,*)'Output filename is unchanged except a letter i'
         write(*,*)'  precedes last char; e.g., bla.bhz => bla.bhiz'
         stop
      end if

      call getarg(1,filename)
      call getarg(2,name)
      read(name,'(f10.0)') delta_new

      nf = lenc(filename)
      call rsac1(filename(1:nf),signal,npts,secs,delta,max,nerr)
      if (nerr .ne. 0) then
         write(*,*)
     1        'Error reading sac file ',
     2        filename(1:nf),'  nerr =',nerr
         stop
      endif

      e = secs + (npts-1)*delta

!     In this version, the "x" vales are equally spaced, but don't need to be

      do j=1,npts
         time_in(j) = secs + (j-1)*delta
      enddo
      npts_new = int( (e-secs)/delta_new ) + 1
      call setfhv('delta',delta_new,ierr)
      call setnhv('npts',npts_new,nerr)
      write(*,'(a,f8.4,i10)') 'delta_new: npts_new',delta_new,npts_new

!     Forsythe Interpolation

      call interp_f(npts,time_in,signal,npts_new,delta_new,
     1     signal_out,a,b,c)
      filename = filename(1:nf-1)//'i'//filename(nf:nf)

      call wsac0(filename(1:nf+1),dummy,signal_out,nerr)
      end


!*robodoc*u* tests/testABM
!  NAME
!    testABM
!  SYNOPSIS

!$Id: testABM.f90 530 2018-03-26 16:10:00Z mexas $

program testABM

!  PURPOSE
!    Testing MPI/IO, cgca_m2mpiio/cgca_pswci
!  DESCRIPTION
!    Timing output of MPI/IO (cgca_pswci) against
!    the serial version (cgca_swci).
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux
use mpi

implicit none

real,parameter :: gigabyte=real(2**30), resolution=1.0e-5,             &
 loge2 = log(real(2))
logical(kind=ldef),parameter :: yesdebug = .true., nodebug = .false.

real( kind=rdef ) ::    &
 qual,                  & ! quality
 bsz0(3),               & ! the given "box" size
 bsz(3),                & ! updated "box" size
 dm,                    & ! mean grain size, linear dim, phys units
 lres,                  & ! linear resolution, cells per unit of length
 res                      ! resolutions, cells per grain

integer :: c(3), ir(3), nimgs, img, ng
integer( kind=iarr ), allocatable :: space(:,:,:,:)[:,:,:]

integer( kind=ilrg ) :: icells, mcells

integer :: ierr

real :: time1, time2, fsizeb, fsizeg, tdiff

logical :: iflag

!*********************************************************************72
! first executable statement

! physical dimensions of the box, assume mm
bsz0 = (/ 2.0, 3.0, 1.0 /)

! mean grain size, linear dimension, e.g. mean grain diameter, also mm
dm = 1.0e-1

! resolution
res = 1.0e5

    img = this_image()
nimgs = num_images()

! do a check on image 1
if ( img .eq. 1 ) then
 ! print a banner
 call banner("ABM")
 ! print the parameter values
 call cgca_pdmp
 write (*,'(a,i0,a)') "running on ", nimgs, " images in a 3D grid"
end if

! I want pdmp output appear before the rest.
! This might help
sync all

! each image calculates the coarray grid dimensions
call cgca_gdim( nimgs, ir, qual )

! calculate the resolution and the actual phys dimensions
! of the box
! subroutine cgca_cadim( bsz, res, dm, ir, c, lres, ng )
! c - coarray sizes
! ir - coarray grid sizes
bsz = bsz0
call cgca_cadim( bsz, res, dm, ir, c, lres, ng )

! total number of cells in a coarray
icells = int( c(1), kind=ilrg ) * int( c(2), kind=ilrg ) *             &
         int( c(3), kind=ilrg )

! total number of cells in the model
mcells = icells * int( nimgs, kind=ilrg )

if ( img .eq. 1 ) then
  write ( *, "(9(a,i0),tr1,g10.3,tr1,g10.3,3(a,g10.3),a)" )            &
    "img: ", img  , " nimgs: ", nimgs, " (", c(1) ,                    &
    ","    , c(2) , ","       , c(3) , ")[", ir(1),                    &
    ","    , ir(2), ","       , ir(3), "] ", ng   ,                    &
    qual, lres,                                                        &
    " (", bsz(1), ",", bsz(2), ",", bsz(3), ")"
  write (*,'(a,i0,a)') "Each image has ",icells, " cells"
  write (*,'(a,i0,a)') "The model has ", mcells, " cells"
end if

! Total output file size, in B and in GB.
fsizeb = real( mcells * storage_size( space, kind=ilrg ) / 8_ilrg )
fsizeg = fsizeb / gigabyte

! allocate space coarray with a single layer
! implicit sync all
!subroutine cgca_as( l1, u1, l2, u2, l3, u3, col1, cou1, col2, cou2,   &
!                    col3, props, coarray )
call cgca_as(1, c(1), 1, c(2), 1, c(3), 1, ir(1), 1, ir(2), 1, 1, space)

! initialise coarray to image number
space = int( img, kind=iarr )

! dump the model, serial
call cpu_time( time1 )
call cgca_swci( space, cgca_state_type_grain, 10, 'serial.raw' )
call cpu_time( time2 )
tdiff = time2-time1
if (img .eq. 1)                                                        &
  write (*,*) "Serial IO: ", tdiff, "s, rate: ", fsizeg/tdiff, "GB/s."

! All images start MPI, used only for I/O here, so no need to start
! earlier. Note that OpenCoarrays doesn't like MPI_Init.
! Probably it's called automatically by the runtime, so
! I put a check for it.
call MPI_Initialized( iflag, ierr )
if ( .not. iflag ) call MPI_Init(ierr)

! dump the model, MPI/IO
call cpu_time( time1 )
call cgca_pswci( space, cgca_state_type_grain, 'mpiio.raw' )
call cpu_time( time2 )
tdiff = time2-time1
if (img .eq. 1)                                                        &
  write (*,*) "MPI/IO: ", tdiff, "s, rate: ", fsizeg/tdiff, "GB/s."

! terminate MPI
! See the note above on MPI_Init
!call MPI_Finalized( iflag, ierr)
!if ( .not. iflag ) call MPI_Finalize(ierr)

! deallocate all arrays
call cgca_ds(space)

end program testABM

!*roboend*


MODULE Circle
   REAL, PARAMETER :: Pi = 3.1415927
   REAL :: radius
END MODULE Circle


C FUNCTION RESIST             (NEXT)
      FUNCTION RESIST (S)
C
C     RESIST - PARAMETERS FOR THE MUTUAL RESISTANCE EVALUATION BY
C        GAUSSIAN INTEGRATION.
C     CALLED BY AGAUSS (BY DIRECTION OF MUTUAL) TO EVALUATE INTEGRAND
C     SEE REFERENCES IN SUBROUTINE GAIN
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
      COMMON /MUT /CFAC, CT, H2, PROD1, RHI2, R21, X21, Y0, Z0
C
C.......................................................................
      SZ = S * CT
      SY = S * PROD1
      TERM = Y0 + SY
      RHO2 = TERM * * 2
      CA = Z0 + SZ
      CA1 = CA + H2
      CA2 = CA - H2
      R = SQRT (RHO2 + CA * * 2)
      R1 = SQRT (RHO2 + CA1 * * 2)
      R2 = SQRT (RHO2 + CA2 * * 2)
      SR = SIN (PI2 * R) / R
      FACR = 2.0 * CFAC * SR
      SR1 = SIN (PI2 * R1) / R1
      SR2 = SIN (PI2 * R2) / R2
      RESIST = (((SR1 * CA1 + SR2 * CA2 - FACR * CA) * SY) / TERM + (FAC
     1R - SR1 - SR2) * SZ) * SIN (PI2 * (H2 - ABS (S))) / S
      RETURN
      END