!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2011 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                     FFTPACK  version 5.1                      *
!     *                                                               *
!     *                 A Fortran Package of Fast Fourier             *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *               Paul Swarztrauber and Dick Valent               *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program tcost1

    use, intrinsic :: ISO_Fortran_env, only: &
        wp => REAL64, &
        ip => INT32, &
        stdout => OUTPUT_UNIT, &
        stderr => ERROR_UNIT

    use type_FFTpack, only: &
        FFTpack

    ! Explicit typing only
    implicit none

    !------------------------------------------------------------------
    ! Dictionary
    !------------------------------------------------------------------
    type (FFTpack)          :: my_fft
    integer (ip), parameter :: n=10**3
    real (wp)               :: real_data(n), data_copy(n)
    !------------------------------------------------------

    !
    !==> Identify test
    !
    write( stdout, '(A)') 'program tcost1 and related messages:'

    !
    !==> Generate test vector for forward-backward test
    !
    call get_random_vector(real_data, data_copy)

    !
    !==> Perform forward transform
    !
    call my_fft%dct(real_data)

    !
    !==> Perform backward transform
    !
    call my_fft%idct(real_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(real_data-data_copy)) )

        write( stdout, '(A,E23.15E3)' ) 'cost1 forward-backward max error =', max_err

    end associate

    !
    !==> Generate test vector for backward-forward test
    !
    call get_random_vector(real_data, data_copy)

    !
    !==> Perform backward transform
    !
    call my_fft%idct(real_data)

    !
    !==> Perform forward transform
    !
    call my_fft%dct(real_data)
    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(real_data-data_copy)) )

        write( stdout, '(A,E23.15E3)' ) 'cost1 backward-forward max error =', max_err
        write( stdout, '(A,/)') 'end program tcost1 and related messages'

    end associate

contains

    subroutine get_random_vector(real_data, real_copy)
        !--------------------------------------------------
        ! Dictionary: calling arguments
        !--------------------------------------------------
        real (wp), intent (out) :: real_data(:)
        real (wp), intent (out) :: real_copy(:)
        !--------------------------------------------------

        call random_seed()
        call random_number(real_data)
        real_copy = real_data

    end subroutine get_random_vector

end program tcost1


program tsp_recursive
    implicit none
    integer :: n, min_distance, i
    integer, allocatable :: d(:, :)
    integer, allocatable :: min_route(:), route(:)

    print '(a)', "How many towns?"
    read *, n

    allocate(d(n, n))
    print '(a)', "Distances between the towns are"
    do i = 1, n
        read *, d(i, :)
    end do

    min_distance = huge(0)
    allocate(min_route(n))
    allocate(route(n))

    route(:) = [ (i, i = 1, n) ] ! [1, 2, 3, ..., n]
    call permute(route, 1)

    print '(a, i0, a)', "The shortest distance ", min_distance, " is for route:"
    print '(*(i0, :, 2x))', min_route(:)

    deallocate(d)
    deallocate(min_route)
    deallocate(route)
contains
    subroutine swap(a, b)
        integer, intent(inout) :: a, b
        integer :: temp
        temp = a; a = b; b = temp
    end subroutine swap

    recursive subroutine permute(a, m)
        integer, intent(inout) :: a(:)
        integer, intent(in)    :: m
        integer :: asize, j, l

        asize = size(a)
        if (m == asize) then
            !print '(*(i2, 2x))', a(:)
            l = d(a(asize), a(1))
            do j = 1, asize - 1
                l = l + d(a(j), a(j + 1))
            end do
            if (l < min_distance) then
                min_distance = l
                min_route(:) = a(:)
            end if
        else
            do j = m, asize
                call swap(a(m), a(j))
                call permute(a, m + 1)
                call swap(a(m), a(j))
            end do
        end if
    end subroutine permute
end program tsp_recursive


  parameter (nmax=10000000)

      include 'mpif.h'
      real x(nmax),y(nmax)
      real*8 sum
      common /arry/x,y
      integer npart, nrest
      integer error, rank, size, status(mpi_status_size)

      call mpi_init(error)
      call mpi_comm_rank(mpi_comm_world, rank, error)
      call mpi_comm_size(mpi_comm_world, size, error)

      npart = nmax/size
      nrest = nmax - npart*size
      if(nrest .ne. 0)then
        write(*,*)' size =',size,' should be a factor of nmax =',nmax
        stop
      endif

      if(rank .eq. 0)then
      do 100 i=1, nmax
        x(i) = i
  100 continue
        if(size .gt. 1)then
        do 200 iproc = 1, size-1
          index = iproc*npart+1
          call mpi_send(x(index),npart,mpi_real,iproc,1,mpi_comm_world,error)
  200   continue
        endif
        do 210 i = 1, npart
              y(i)=0
          do j = 1, 8
              y(i) = y(i)+(x(i)**2.3/x(i))
          enddo
  210   continue
        if(size .gt. 1)then
        do 215 iproc = 1, size-1
          index = iproc*npart+1
          call mpi_recv(y(index),npart,mpi_real,iproc,2,mpi_comm_world,status,error)
  215   continue
        endif
        sum = 0
        do 300 i=1,nmax
          sum = sum + y(i)
  300   continue
        write(*,*)' sum=',sum
      else
        call mpi_recv(x,npart,mpi_real,0,1,mpi_comm_world,status,error)
        do 220 i=1,npart
              y(i)=0
          do j = 1, 8
              y(i) = y(i)+(x(i)**2.3/x(i))
          enddo
  220   continue
        call mpi_send(y,npart,mpi_real,0,2,mpi_comm_world,error)
      endif

      call mpi_finalize(error)

      stop
      end


      INTEGER FUNCTION MOD1 (X,M)

C  MOD1 returns X mod M, but coerced between 1 and M, not between
C  0 and M-1.

      INTEGER    X,M, XW

      IF (X.LT.0) THEN
         XW = X - (X/M - 2) * M
      ELSE
         XW = X
      ENDIF
      MOD1 = MOD(XW,M)
      IF (MOD1.LE.0) MOD1 = M

      END


program matrix_expression_do_loop
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    integer, parameter :: m = 20000, n = 3000
    integer :: i, j
    real(kind=dp), dimension(m, n) :: A, B, C, D

    A = 1.0_dp
    B = 1.0_dp
    C = 1.0_dp
    do j = 1, n
        do i = 1, m
            D(i, j) = 5.0_dp*A(i, j)*B(i, j) + C(i, j)/1.5_dp + 8.0_dp
          end do
    end do

    print *, sum(D)

end program matrix_expression_do_loop


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C========================================================================
      SUBROUTINE EXTQ(IGLND,INVCN,MAXLN,NOD,INVLEN,XA,YA,CNTRA,SOLEA,
     &                SOLENA,ITT,iblk)

C************************************************************************

C Subroutine EXTQ sets up the matrix and vectors for a least squares
C linear interpolation/extrapolation of element variable data to the
C nodes for a 4-node quad element. In the special case of data from
C only 3 elements, the result is not least squares fit but a
C triangularization.

C Calls subroutines FRGE & BS

C Called by ELTON3

C************************************************************************

C  IGLND  INT   The global node number being processed
C  INVCN  INT   The inverse connectivity (1:maxln,1:numnda)
C  MAXLN  INT   The maximum number of elements connected to any node
C  NOD    INT   The node used to get the elements from INVCN
C  INVLEN INT   The number of elements connected to NOD
C  XA,etc REAL  Vectors containing nodal coordinates
C  CNTRA  REAL  Array containing the coordinates of the element
C               centroids (1:3)
C  SOLEA  REAL  The element variables
C  SOLENA REAL  Element variables at nodes
C               number with the global mesh node number (1:numnda)
C  ITT    INT   truth table
C  IM     INT   element block being processed (not ID)
C  S      REAL  The coefficient matrix for the least squares fit
C  L      INT   Dummy vector - used in FRGE and BS
C  X      REAL  The solution vector - used in BS
C  G      REAL  Dummy vector - used in FRGE
C  F      REAL  The load vector for the least squares fit

C************************************************************************

      include 'aexds1.blk'
      include 'amesh.blk'
      include 'ebbyeb.blk'
      include 'tapes.blk'

      DIMENSION INVCN(MAXLN,*),XA(*),YA(*)
      DIMENSION CNTRA(NUMEBA,*),SOLEA(NUMEBA,*)
      DIMENSION SOLENA(NODESA,NVAREL), ITT(NVAREL,*)
      DOUBLE PRECISION S(3,3),G(3),F(3),X(3)
      INTEGER L(3)

C************************************************************************

C  Zero matrix

      DO I = 1,3
         DO J = 1,3
            S(I,J) = 0.D+00
         end do
      end do

C  Set up matrix for linear fit

      S(1,1) = DBLE(INVLEN)
      DO I = 1, INVLEN
        S(1,2) = S(1,2) + DBLE(XA(IGLND) - CNTRA(INVCN(I,NOD),1))
        S(1,3) = S(1,3) + DBLE(YA(IGLND) - CNTRA(INVCN(I,NOD),2))
        S(2,2) = S(2,2) + DBLE((XA(IGLND) - CNTRA(INVCN(I,NOD),1)) *
     &                    (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
        S(2,3) = S(2,3) + DBLE((YA(IGLND) - CNTRA(INVCN(I,NOD),2)) *
     &                    (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
        S(3,3) = S(3,3) + DBLE((YA(IGLND) - CNTRA(INVCN(I,NOD),2)) *
     &                    (YA(IGLND) - CNTRA(INVCN(I,NOD),2)))
      end do
      S(2,1) = S(1,2)
      S(3,1) = S(1,3)
      S(3,2) = S(2,3)

C  Forward Gauss elimination (Kincaid pg. 220) (double precision)

      CALL FRGE(3,S,L,G)

C  Set up load vectors - number of element variables

      DO IVAR = 1, NVAREL
        IF (ITT(IVAR,iblk) .EQ. 0)GO TO 30
        F(1) = 0.D+00
        F(2) = 0.D+00
        F(3) = 0.D+00
        DO I = 1, INVLEN
          F(1) = F(1) + DBLE(SOLEA(INVCN(I,NOD),IVAR))
          F(2) = F(2) + DBLE(SOLEA(INVCN(I,NOD),IVAR) *
     &                  (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
          F(3) = F(3) + DBLE(SOLEA(INVCN(I,NOD),IVAR) *
     &                  (YA(IGLND) - CNTRA(INVCN(I,NOD),2)))
       end do

C  Back substitution (Kincaid pg. 223) (double precision)

        CALL BS(3,S,F,L,X)

C  Fill in nodal element value array (SOLENA)
C  Note: X and Y distances in S and F are centered on node being
C        interpolated to (IGLND), thus X and Y are zero in the eq.
C        Value = X(1) + X(2) * X + X(3) * Y

        SOLENA(IGLND,IVAR) = SNGL(X(1))
      end do
   30 CONTINUE
      RETURN
      END


  subroutine clpv  (fbuObj, p1, v, p2, e1)

! ======================================================================
!
!    Called by: RASTAR
!
!   Transforms momentum p1 in frame moving with velocity v with respect
!   to the lab frame into the lab frame momentum p2.
!
!    Last change: 13-Aug-2003 BY NVMokhov
!    Edited by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by A. J. Sierk, LANL T-2, February, 2009.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!    Edited by CMJ, XCP-3, July 2018 (creation of FermiBreakup class)
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use fermiBreakupParams, only : zro, one

    implicit none
    class(FermiBreakup),        intent(inout) :: fbuObj
    real(real64), dimension(3), intent(in   ) :: p1
    real(real64), dimension(3), intent(in   ) :: v
    real(real64), dimension(3), intent(  out) :: p2
    real(real64),               intent(in   ) :: e1

    integer(int32) :: i, k
    real(real64)   :: gam, spv, temp, temp2, v2

! ======================================================================

    spv = zro
    v2 = zro
    do i = 1,3
       v2 = v2 + v(i)**2
       spv = spv + p1(i)*v(i)
    end do
    temp = one - v2
    if (temp < div0Lim) then
       temp = 0.01d0
       write(fbuObj%io%message,1050) "265"
       call fbuObj%io%print(4, 3, fbuObj%io%message)
    end if
    gam = one/sqrt(temp)
    temp = gam + one
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(fbuObj%io%message,1000) "271"
       call fbuObj%io%print(4, 3, fbuObj%io%message)
    end if
    temp2 = gam*(spv*gam/(temp) + e1)
    do k = 1,3
       p2(k) = p1(k) + v(k)*temp2
    end do
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'clpv.f90', line ", A)
1050 format("Square root/divide by zero error prevented in ", &
          & "'clpv.f90', line ", A)
! ======================================================================
  end subroutine clpv


C PR tree-optimization/36922
C { dg-do compile }
C { dg-options "-O2 -ftree-loop-linear" }
      SUBROUTINE PR36922(N,F,Z,C)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION C(23821),Z(0:2*N+1),F(0:2*N)
      I=0
      DO L=0,N
        DO M=0,L
          DO M2=M,L
            I=I+1
            C(I)=F(L+M)*F(L-M)*Z(L-M2)/(F(M2+M)*F(M2-M)*F(L-M2)*F(L-M2))
          ENDDO
        ENDDO
      ENDDO
      END


module tree_node_module
    implicit none

    type tree_node
        integer :: number
        type(tree_node), pointer :: left => null(), &
            right => null()
    end type
end module

module tree_module
    implicit none

contains
    recursive function tree(n) result(answer)
        use tree_node_module
        implicit none

        integer, intent(in) :: n
        type(tree_node), pointer :: answer
        type(tree_node), pointer :: new_node
        integer :: l, r, x

        if (n==0) then
            print *, ' terminate tree'
            nullify(answer)
        else
            l = n/2
            r = n-l-1
            print *, l, r, n
            print *, ' next item'
            read *, x
            allocate(new_node)
            new_node%number = x
            print *, ' left branch'
            new_node%left => tree(l)
            print *, ' right branch'
            new_node%right => tree(r)
            answer => new_node
        end if
        print *, ' function tree ends'
    end function
end module

module print_tree_module
    implicit none

contains
    recursive subroutine print_tree(t, h)
        use tree_node_module
        implicit none

        type(tree_node), pointer, intent(in) :: t
        integer, intent(in) :: h
        integer :: i

        if (associated(t)) then
            call print_tree(t%left,h+1)
            do i = 1, h
                write(*,'(1x)',advance='no')
            end do
            print *, t%number
            call print_tree(t%right,h+1)
        end if
    end subroutine
end module

program ch2205
    ! Perfectly Balanced Tree
    use tree_node_module
    use tree_module
    use print_tree_module
    implicit none

    type(tree_node), pointer :: root
    integer :: n_of_items

    print *, 'enter number of items'
    read *, n_of_items
    root => tree(n_of_items)
    call print_tree(root,0)
end program


MODULE diago_m
!$ USE omp_lib
  IMPLICIT NONE

   PRIVATE
   PUBLIC diagonalization

  INTERFACE diagonalization
     MODULE PROCEDURE QML_diagonalization
  END INTERFACE

   CONTAINS
!============================================================
!
!   Driver for the diagonalization
!      Default: tred2+tql2 (type_diag=2)
!            Other possibilities: Jacobi (type_diag=1) or Lapack (type_diag=3)
!            Rk: Lapack diago is not possible
!      Sort: the eigenvalues/eigenvectors:
!            sort=1:  ascending (default)
!            sort=-1: descending
!            sort=2:  ascending on the absolute eigenvalues
!     phase:
!============================================================
!
  RECURSIVE SUBROUTINE QML_diagonalization(Mat,REig,Vec,n,type_diag,sort,phase,IEig)
    USE, intrinsic :: ISO_FORTRAN_ENV, ONLY : real64,int32
    USE NumParameters_m
    IMPLICIT NONE

    integer,       intent(in)              :: n ! when n < size(REig), only n eigenvectors and  eigenvectors are calculated
    real(kind=Rk), intent(in)              :: Mat(:,:)
    real(kind=Rk), intent(inout)           :: REig(:),Vec(:,:)
    real(kind=Rk), intent(inout), optional :: IEig(:)

    integer,          intent(in),    optional :: type_diag,sort
    logical,          intent(in),    optional :: phase

    !local variables
    integer            :: type_diag_loc
    integer            :: type_diag_default = 2 ! tred+tql
    !                                    Jacobi tred+tql DSYEV  DGEEV Lanczos
    integer, parameter :: list_type(7) = [1,    2,       3,377, 4,477,   5]

    real(kind=Rk), allocatable :: trav(:),Mat_save(:,:)
    integer :: n_size,n_vect

    !for lapack
    integer              :: i
    integer              :: lwork ,lda ,ldvr ,ierr
    integer(kind=int32)  :: n4,lwork4,lda4,ldvr4,ierr4
    real(kind=Rk), allocatable :: work(:)
    real(kind=Rk), allocatable :: IEig_loc(:)

    real(kind=Rk) :: dummy(1,1)

    !----- for debuging --------------------------------------------------
    character (len=*), parameter :: name_sub='QML_diagonalization'
    logical, parameter :: debug = .FALSE.
    !logical, parameter :: debug = .TRUE.
    !-----------------------------------------------------------

    n_size = size(REig)
    IF (n_size /= size(Mat,dim=1) .OR. n_size /= size(Vec,dim=1)) THEN
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) ' The matrix or vector sizes are not consistant'
      write(out_unitp,*) '   size(REig):     ',size(REig)
      write(out_unitp,*) '   size(Mat):      ',size(Mat,dim=1)
      write(out_unitp,*) '   size(Vec):      ',size(Vec,dim=1)
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: The matrix or vector sizes are not consistant.'
    END IF
    IF (n < 1) THEN
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,"(a,i0,a)") ' n < 1. It MUST be in the range [1,',n_size,']'
      write(out_unitp,*) '   n:              ',n
      write(out_unitp,*) '   size(REig):     ',size(REig)
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: The matrix or vector sizes are not consistant.'
    END IF
    n_vect = min(n,n_size)

    IF (present(type_diag)) THEN
      type_diag_loc = type_diag
    ELSE
      type_diag_loc = type_diag_default
    END IF

    !when lapack is used and Rk /= real64 (not a double)
    IF (Rk /= real64 .AND. type_diag_loc == 3) type_diag_loc = type_diag_default

!#if __LAPACK != 1
    IF (count([3,377,395] == type_diag_loc) == 1) type_diag_loc = type_diag_default
    IF (count([4,477] == type_diag_loc) == 1) THEN
      !type_diag_loc = 0
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) ' The diagonalization of non-symmetric needs LAPACK.'
      write(out_unitp,*) '  Try to link LAPACK with the code (use LAPACK=1 in the makfile).'
      write(out_unitp,*) '   type_diag:      ',type_diag_loc
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: Problem with non-symmetric matrix.'
    END IF
!#endif

    IF (count(list_type == type_diag_loc) == 0) THEN
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) ' type_diag is out-of-range.'
      write(out_unitp,*) '   type_diag:      ',type_diag_loc
      write(out_unitp,*) '   Possible values:',list_type(:)
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: type_diag is out-of-range.'
    END IF

    SELECT CASE (type_diag_loc)
    CASE(1) ! jacobi
      IF (debug) write(out_unitp,*) 'Jacobi (symmetric)'
      allocate(Mat_save(n,n))
      Mat_save = Mat ! save mat

      CALL QML_JACOBI2(Mat_save,n,REig,Vec)

      deallocate(Mat_save)
    CASE (2) ! tred+tql
      IF (debug) write(out_unitp,*) 'tred+tql, new version (symmetric)'
      allocate(trav(n))

      Vec = Mat
      CALL QML_TRED2_EISPACK(Vec,n,n,REig,trav)
      CALL QML_TQLI_EISPACK(REig,trav,n,n,Vec)

      deallocate(trav)
    CASE(3,377) ! lapack77
      IF (debug) write(out_unitp,*) 'lapack77: DSYEV (symmetric)'

! #if __LAPACK == 1
!       lwork = 3*n-1
!       allocate(work(lwork))
!       Vec(:,:) = Mat(:,:)
!
!       ! lapack subroutines need integer (kind=4 or int32), therefore, we add a conversion, otherwise
!       ! it fails when integers (kind=8 or int64) are used (at the compilation).
!       n4     = int(n,kind=int32)
!       lwork4 = int(lwork,kind=int32)
!       CALL DSYEV('V','U',n4,Vec,n4,REig,work,lwork4,ierr4)
!
!       IF (debug) write(out_unitp,*) 'ierr=',ierr4
!       flush(out_unitp)
!
!       IF (ierr4 /= 0_int32) THEN
!          write(out_unitp,*) ' ERROR in ',name_sub
!          write(out_unitp,*) ' DSYEV lapack subroutine has FAILED!'
!          STOP
!       END IF
!
!
!       deallocate(work)
! #else
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) '  LAPACK is not linked (LAPACK=0 in the makefile).'
      write(out_unitp,*) '  The program should not reach the LAPACK case.'
      write(out_unitp,*) '  => Probabely, wrong type_diag_default.'
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: LAPACK case impossible'
!#endif

    CASE(4,477) ! lapack77 (non-symmetric)
! #if __LAPACK == 1
!       IF (debug) write(out_unitp,*) 'lapack77: DGEEV (non-symmetric)'
!       flush(out_unitp)
!
!       allocate(Mat_save(n,n))
!       Mat_save = Mat ! save mat
!
!
!       lwork = (2+64)*n
!       ldvr  = n
!       lda   = n
!       allocate(work(lwork))
!
!
!       n4     = int(n,kind=int32)
!       lwork4 = int(lwork,kind=int32)
!       lda4   = int(lda,kind=int32)
!       ldvr4  = int(ldvr,kind=int32)
!
!       IF (present(IEig)) THEN
!         CALL DGEEV('N','V',n4,Mat_save,lda4,REig,IEig,dummy,              &
!                    int(1,kind=int32),Vec,ldvr4,work,lwork4,ierr4)
!         IF (debug) write(out_unitp,*)'ierr=',ierr4
!         IF (ierr4 /= 0_int32) THEN
!            write(out_unitp,*) ' ERROR in ',name_sub
!            write(out_unitp,*) ' DGEEV lapack subroutine has FAILED!'
!            STOP
!         END IF
!
!         IF (debug) THEN
!           DO i=1,n
!             write(out_unitp,*) 'Eigenvalue(', i, ') = ', REig(i),'+I ',IEig(i)
!           END DO
!         END IF
!       ELSE
!         allocate(IEig_loc(n))
!
!         CALL DGEEV('N','V',n4,Mat_save,lda4,REig,IEig_loc,dummy,        &
!                    int(1,kind=int32),Vec,ldvr4,work,lwork4,ierr4)
!         IF (debug) write(out_unitp,*)'ierr=',ierr4
!         IF (ierr4 /= 0_int32) THEN
!            write(out_unitp,*) ' ERROR in ',name_sub
!            write(out_unitp,*) ' DGEEV lapack subroutine has FAILED!'
!            STOP
!         END IF
!
!         DO i=1,n
!           write(out_unitp,*) 'Eigenvalue(', i, ') = ', REig(i),'+I ',IEig_loc(i)
!         END DO
!
!         deallocate(IEig_loc)
!       END IF
!
!       deallocate(work)
!       deallocate(Mat_save)
! #else
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) '  LAPACK is not linked (LAPACK=0 in the makefile).'
      write(out_unitp,*) '  The program should not reach the LAPACK case.'
      write(out_unitp,*) '  => Probabely, wrong type_diag_default.'
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: LAPACK case impossible'
!#endif

    CASE(5) ! lanczos

      CALL QML_Lanczos(Mat,n_vect,REig,Vec,epsi=ONETENTH**6,max_it=100)

    CASE DEFAULT
      write(out_unitp,*) ' ERROR in ',name_sub
      write(out_unitp,*) ' The default CASE is not defined.'
      write(out_unitp,*) '  => CHECK the fortran!!'
      STOP 'ERROR in QML_diagonalization: default case impossible'
    END SELECT

    IF (present(sort)) THEN
        SELECT CASE (sort)
        CASE(1)
          CALL QML_sort(REig,Vec)
          CALL QML_rota_denerated(REig,Vec)
        CASE(-1)
          REig = -REig
          CALL QML_sort(REig,Vec)
          REig = -REig
          CALL QML_rota_denerated(REig,Vec)
        CASE(2)
          CALL QML_sort_abs(REig,Vec)
        CASE DEFAULT ! no sort
          CONTINUE
        END SELECT
    ELSE
      CALL QML_sort(REig,Vec)
      CALL QML_rota_denerated(REig,Vec)
    END IF

    IF (present(phase)) THEN
      IF (phase) CALL QML_Unique_phase(Vec)
    ELSE
      CALL QML_Unique_phase(Vec)
    END IF

  END SUBROUTINE QML_diagonalization

  SUBROUTINE QML_JACOBI2(A,N,D,V)
      USE NumParameters_m
      IMPLICIT NONE

      integer            :: N
      real(kind=Rk)   :: A(N,N),V(N,N),D(N)

      integer, parameter :: max_it = 500
      real(kind=Rk)   :: B(N),Z(N)

      real(kind=Rk)   :: h,t,g,sm,tresh,tau,s,theta,c

      integer            :: i,j,iq,nrot,ip

!     V(:,:) = Id(:,:)
      V(:,:) = ZERO
      DO IP=1,N
        V(IP,IP)=ONE
      END DO

!     initialization
      DO IP=1,N
        B(IP)=A(IP,IP)
        D(IP)=B(IP)
        Z(IP)=ZERO
      END DO

      NROT=0
      DO I=1,max_it ! main loop

        ! SM value
        SM = ZERO
        DO IP=1,N-1
          DO IQ=IP+1,N
            SM = SM+abs(A(IP,IQ))
          END DO
        END DO
        IF(SM == ZERO)RETURN

        ! TRESH value
        IF(I < 4)THEN
          TRESH = TWOTENTHS*SM/N**2
        ELSE
          TRESH = ZERO
        ENDIF

        DO IP=1,N-1
          DO IQ=IP+1,N
            G = HUNDRED*abs(A(IP,IQ))
            IF ( I > 4 .AND. ABS(D(IP))+G == ABS(D(IP))                 &
               .AND. ABS(D(IQ))+G == ABS(D(IQ)) ) THEN
              A(IP,IQ)=ZERO
            ELSE IF ( ABS(A(IP,IQ)) > TRESH ) THEN
              H=D(IQ)-D(IP)
              IF ( ABS(H)+G == ABS(H) ) THEN
                T=A(IP,IQ)/H
              ELSE
                THETA=HALF*H/A(IP,IQ)
                T=ONE/(ABS(THETA)+sqrt(ONE+THETA**2))
                IF ( THETA < ZERO) T=-T
              ENDIF
              C=ONE/sqrt(ONE+T**2)
              S=T*C
              TAU=S/(ONE+C)

              H=T*A(IP,IQ)

              Z(IP)=Z(IP)-H
              Z(IQ)=Z(IQ)+H
              D(IP)=D(IP)-H
              D(IQ)=D(IQ)+H
              A(IP,IQ)=ZERO
              DO J=1,IP-1
                G=A(J,IP)
                H=A(J,IQ)
                A(J,IP)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
              END DO
              DO J=IP+1,IQ-1
                G=A(IP,J)
                H=A(J,IQ)
                A(IP,J)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
              END DO
              DO J=IQ+1,N
                G=A(IP,J)
                H=A(IQ,J)
                A(IP,J)=G-S*(H+G*TAU)
                A(IQ,J)=H+S*(G-H*TAU)
              END DO
              DO J=1,N
                G=V(J,IP)
                H=V(J,IQ)
                V(J,IP)=G-S*(H+G*TAU)
                V(J,IQ)=H+S*(G-H*TAU)
              END DO
              NROT=NROT+1
            ENDIF
          END DO
        END DO

        DO IP=1,N
          B(IP)=B(IP)+Z(IP)
          D(IP)=B(IP)
          Z(IP)=ZERO
        END DO

      END DO ! end main loop

      write(out_unitp,*) max_it,' iterations should never happen'
      STOP

  end subroutine QML_JACOBI2
!
!============================================================
!
!   diagonalisation trigonalisation puis diagonalisation
!
!============================================================
!
  SUBROUTINE QML_TRED2_EISPACK(A,N,NP,D,E)
      USE NumParameters_m
      IMPLICIT NONE

      integer          :: N,NP
      real(kind=Rk) :: A(NP,NP),D(NP),E(NP)

      !local variables
      integer          :: I,J,K,L
      real(kind=Rk) :: F,G,H,HH,SCALE

      IF(N.GT.1)THEN
        DO 18 I=N,2,-1
          L=I-1
          H=ZERO
          SCALE=ZERO
          IF(L.GT.1)THEN
            DO 11 K=1,L
              SCALE=SCALE+ABS(A(I,K))
11          CONTINUE
            IF(SCALE .EQ. ZERO)THEN
              E(I)=A(I,L)
            ELSE
              DO 12 K=1,L
                A(I,K)=A(I,K)/SCALE
                H=H+A(I,K)**2
12            CONTINUE
              F=A(I,L)
              G=-SIGN(SQRT(H),F)
              E(I)=SCALE*G
              H=H-F*G
              A(I,L)=F-G
              F=ZERO
              DO 15 J=1,L
                A(J,I)=A(I,J)/H
                G=ZERO
                DO 13 K=1,J
                  G=G+A(J,K)*A(I,K)
13              CONTINUE
                IF(L.GT.J)THEN
                  DO 14 K=J+1,L
                    G=G+A(K,J)*A(I,K)
14                CONTINUE
                ENDIF
                E(J)=G/H
                F=F+E(J)*A(I,J)
15            CONTINUE
              HH=F/(H+H)
              DO 17 J=1,L
                F=A(I,J)
                G=E(J)-HH*F
                E(J)=G
                DO 16 K=1,J
                  A(J,K)=A(J,K)-F*E(K)-G*A(I,K)
16              CONTINUE
17            CONTINUE
            ENDIF
          ELSE
            E(I)=A(I,L)
          ENDIF
          D(I)=H
18      CONTINUE
      ENDIF
      D(1)=ZERO
      E(1)=ZERO
      DO 23 I=1,N
        L=I-1
        IF(D(I).NE. ZERO)THEN
          DO 21 J=1,L
            G=ZERO
            DO 19 K=1,L
              G=G+A(I,K)*A(K,J)
19          CONTINUE
            DO 20 K=1,L
              A(K,J)=A(K,J)-G*A(K,I)
20          CONTINUE
21        CONTINUE
        ENDIF
        D(I)=A(I,I)
        A(I,I)=ONE
        IF(L.GE.1)THEN
          DO 22 J=1,L
            A(I,J)=ZERO
            A(J,I)=ZERO
22        CONTINUE
        ENDIF
23    CONTINUE
      RETURN
  END SUBROUTINE QML_TRED2_EISPACK

  SUBROUTINE QML_TQLI_EISPACK(D,E,N,NP,Z)
      USE NumParameters_m
      IMPLICIT NONE

      integer          :: N,NP
      real(kind=Rk) :: D(NP),E(NP),Z(NP,NP)

      !local variables
      integer          :: I,K,L,M,ITER
      real(kind=Rk) :: G,R,S,C,P,F,B,DD

      IF (N.GT.1) THEN
        DO 11 I=2,N
          E(I-1)=E(I)
11      CONTINUE
        E(N)=ZERO
        DO 15 L=1,N
          ITER=0
1         DO 12 M=L,N-1
            DD=ABS(D(M))+ABS(D(M+1))
            IF (ABS(E(M))+DD.EQ.DD) GO TO 2
12        CONTINUE
          M=N
2         IF(M.NE.L)THEN
            IF(ITER.EQ.30) STOP 'too many iterations'
            ITER=ITER+1
            G=(D(L+1)-D(L))/(TWO*E(L))
            R=SQRT(G**2+ONE)
            G=D(M)-D(L)+E(L)/(G+SIGN(R,G))
            S=ONE
            C=ONE
            P=ZERO
            DO 14 I=M-1,L,-1
              F=S*E(I)
              B=C*E(I)
              IF(ABS(F).GE.ABS(G))THEN
                C=G/F
                R=SQRT(C**2+ONE)
                E(I+1)=F*R
                S=ONE/R
                C=C*S
              ELSE
                S=F/G
                R=SQRT(S**2+ONE)
                E(I+1)=G*R
                C=ONE/R
                S=S*C
              ENDIF
              G=D(I+1)-P
              R=(D(I)-G)*S+TWO*C*B
              P=S*R
              D(I+1)=G+P
              G=C*R-B
              DO 13 K=1,N
                F=Z(K,I+1)
                Z(K,I+1)=S*Z(K,I)+C*F
                Z(K,I)=C*Z(K,I)-S*F
13            CONTINUE
14          CONTINUE
            D(L)=D(L)-P
            E(L)=G
            E(M)=ZERO
            GO TO 1
          ENDIF
15      CONTINUE
      ENDIF
      RETURN
  END SUBROUTINE QML_TQLI_EISPACK

!
!============================================================
!
!   Sort the eigenvalues and the eigenvectors
!
!============================================================
!
  SUBROUTINE QML_sort_tab(nb_niv,ene,max_niv)
      USE NumParameters_m
      IMPLICIT NONE

      integer nb_niv,max_niv
      real(kind=Rk) ene(max_niv)
      real(kind=Rk) a

        integer i,j,k

      DO i=1,nb_niv
      DO j=i+1,nb_niv
       IF (ene(i) .GT. ene(j)) THEN
!             permutation
          a=ene(i)
          ene(i)=ene(j)
          ene(j)=a
        END IF
      END DO
      END DO

  end subroutine QML_sort_tab

  SUBROUTINE QML_sort(ene,psi)
      USE NumParameters_m
      IMPLICIT NONE

      real(kind=Rk), intent(inout) :: ene(:),psi(:,:)

      real(kind=Rk) :: a
      integer          :: i,j,k

      DO i=1,size(ene)
      DO j=i+1,size(ene)
       IF (ene(i) > ene(j)) THEN
!	      permutation
          a=ene(i)
          ene(i)=ene(j)
          ene(j)=a
          DO k=1,size(psi,dim=1)
            a=psi(k,i)
            psi(k,i)=psi(k,j)
            psi(k,j)=a
          END DO
        END IF
      END DO
      END DO

  END SUBROUTINE QML_sort
  SUBROUTINE QML_sort_abs(ene,psi)
      USE NumParameters_m
      IMPLICIT NONE

      real(kind=Rk), intent(inout) :: ene(:),psi(:,:)

      real(kind=Rk) :: a
      integer          :: i,j,k

        DO i=1,size(ene)
          DO j=i+1,size(ene)
            IF (abs(ene(i)) > abs(ene(j))) THEN
!             permutation
              a=ene(i)
              ene(i)=ene(j)
              ene(j)=a
              DO k=1,size(psi,dim=1)
                a=psi(k,i)
                psi(k,i)=psi(k,j)
                psi(k,j)=a
              END DO
            END IF
          END DO
        END DO

  end subroutine QML_sort_abs
!
!============================================================
!
!   Change the phase of Vec(:,i) shuch its largest coeficient is positive
!
!============================================================
!
  SUBROUTINE QML_Unique_phase(Vec)
      USE NumParameters_m
      IMPLICIT NONE

      real(kind=Rk), intent(inout) :: Vec(:,:)

      integer          :: i,jloc

      DO i=lbound(Vec,dim=2),ubound(Vec,dim=2)
        jloc           = maxloc(abs(Vec(:,i)),dim=1)
        IF (abs(Vec(jloc,i)) < ONETENTH**6 ) CYCLE
        IF (Vec(jloc,i) < ZERO) Vec(:,i) = -Vec(:,i)
      END DO

      END SUBROUTINE QML_Unique_phase
!=====================================================================
!
!   c_new(:,i) =  cos(th) c(:,i) + sin(th) c(:,j)
!   c_new(:,j) = -sin(th) c(:,j) + cos(th) c(:,j)
!
!    the angle is obtained such ...
!
!      it is working only if 2 vectors are degenerated !!!!
!
!=====================================================================
  SUBROUTINE QML_rota_denerated(v,c)
      USE NumParameters_m
      IMPLICIT NONE

      real (kind=Rk), intent(in)    :: v(:)
      real (kind=Rk), intent(inout) :: c(:,:)

      integer           :: i,j,k,kloc
      real (kind=Rk) :: ai,aj,norm,cc,ss

      real (kind=Rk), parameter :: epsi = ONETENTH**10

!---------------------------------------------------------------------
      logical, parameter :: debug = .FALSE.
      !logical, parameter :: debug = .TRUE.
!---------------------------------------------------------------------
      IF (debug) THEN
      write(out_unitp,*) 'BEGINNING QML_rota_denerated'
      write(out_unitp,*) 'v',v
      !write(out_unitp,*) 'c',c
      END IF
!---------------------------------------------------------------------
      DO i=1,size(v)-1

        j = i+1
        IF ( abs(v(i)-v(j)) < epsi) THEN
          !write(6,*) 'i,j',i,j
          !write(6,*) 'vec i',c(:,i)
          !write(6,*) 'vec j',c(:,j)

          kloc = maxloc((c(:,i)**2+c(:,j)**2),dim=1)

          cc   =  c(kloc,i)
          ss   = -c(kloc,j)
          !write(6,*) i,j,'cos sin',kloc,cc,ss
          norm = sqrt(cc*cc+ss*ss)
          cc   = cc/norm
          ss   = ss/norm
          !write(6,*) i,j,'cos sin',cc,ss
          IF (abs(cc) < epsi .OR. abs(ss) < epsi) CYCLE

          DO k=1,size(c,dim=1)
           ai = c(k,i)
           aj = c(k,j)

           c(k,i) =  cc * ai + ss * aj
           c(k,j) = -ss * ai + cc * aj

          END DO

        END IF
      END DO

!---------------------------------------------------------------------
      IF (debug) THEN
      write(out_unitp,*) 'new c',c
      write(out_unitp,*) 'END QML_rota_denerated'
      END IF
!---------------------------------------------------------------------

  end subroutine QML_rota_denerated

!============================================================
!
!      *******       Extension to complex symmetrical matrices of
!      *******       the <Tql2> Eispack routine, implemented by
!      *******       Claude Leforestier.
!
!
!     on input-
!        n is the order of the matrix,
!        d contains the diagonal elements of the input matrix,
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary,
!        z should have been initialized to the identity matrix.
!
!      on output-
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1,
!        e has been destroyed,
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues,
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after nbiter iterations.
!
!============================================================
!
  Subroutine QML_cTql2(nZ,n,D,E,Z,ierr)
      USE NumParameters_m
      IMPLICIT NONE

      Integer :: i,j,k,l,m,n,ii,Nbiter,nm,mml,nZ,ierr
      Data Nbiter/60/
      complex(kind=Rk) :: D(n),E(n),Z(nZ,n)
      real (kind=Rk) :: machep,norm1,norm2,rsign
      complex(kind=Rk) :: b,c,f,g,p,r,s
!     complex(kind=Rk) :: b,c,f,g,p,r,s,zero,one,two
!     Data zero/(0.,0.)/,one/(1.,0.)/,two/(2.,0.)/,Nbiter/60/

      machep=10.d-16
      ierr=0
!     initialize z to e one.
      do i=2,n
         e(i-1)=e(i)
      enddo
      e(n)=zero
      do 240 l=1,n
      j=0
!     ********** look for small sub-diagonal element **********
  105 do 110 m=l,n
      if(m.eq.n) goto 120
      norm1=abs(real(e(m),kind=Rk))+abs(aimag(e(m)))
      norm2=abs(real(d(m),kind=Rk))+abs(aimag(d(m))) +               &
            abs(real(d(m+1),kind=Rk))+abs(aimag(d(m+1)))
      if(norm1.le.machep*norm2) goto 120
  110 continue
  120 p=d(l)
      if(m.eq.l) goto 240
      if(j.eq.nbiter) goto 1000
      j=j+1
!     ********** form shift **********
      g=(d(l+1)-p)/(TWO*e(l))
      r=sqrt(g*g+ONE)
      rsign=1.
      if(real(g,kind=Rk).lt.0.) rsign=-ONE
      g=d(m)-p+e(l)/(g+rsign*r)
      s=ONE
      c=ONE
      p=ZERO
      mml=m-l
!     ********** for i=m-1 step -1 until l do -- **********
      do 200 ii=1,mml
      i=m-ii
      f=s*e(i)
      b=c*e(i)
      norm1=f*conjg(f)
      norm2=g*conjg(g)
      if(norm1.lt.norm2) goto 150
      c=g/f
      r=sqrt(c*c+ONE)
      e(i+1)=f*r
      s=ONE/r
      c=c*s
      go to 160
  150 s=f/g
      r=sqrt(s*s+ONE)
      e(i+1)=g*r
      c=ONE/r
      s=s*c
  160 g=d(i+1)-p
      r=(d(i)-g)*s+TWO*c*b
      p=s*r
      d(i+1)=g+p
      g=c*r-b
!     ********** form vector **********
      do k=1,n
      f=z(k,i+1)
      z(k,i+1)=s*z(k,i)+c*f
      z(k,i)=c*z(k,i)-s*f
      enddo
  200 continue
      d(l)=d(l)-p
      e(l)=g
      e(m)=ZERO
      go to 105
  240 continue
!     ********** order eigenvalues and eigenvectors **********
      do 300 ii=2,n
      i=ii-1
      k=i
      p=d(i)
      do 260 j=ii,n
      if(real(d(j),kind=Rk).ge.real(p,kind=Rk)) goto 260
      k=j
      p=d(j)
  260 continue
      if(k.eq.i) goto 300
      d(k)=d(i)
      d(i)=p
      do m=1,n
         p=z(m,i)
         z(m,i)=z(m,k)
         z(m,k)=p
      enddo
  300 continue
      goto 1001
!     ********** set error -- no convergence to an
!                eigenvalue after Nbiter iterations **********
 1000 write (out_unitp,1010) l
 1010 format(//10x,'$$$ <Cmtql2> return code :',i5,' $$$')
      stop
 1001 Return
  end subroutine QML_cTql2

  Subroutine QML_cTred2(nm,n,A,d,e,Z)
      USE NumParameters_m
      IMPLICIT NONE

      INTEGER I,II,J,JP1,K,L,N,NM
      complex(kind=Rk) A(nm,n),Z(nm,n),d(n),e(n)                     &
                ,f,g,h,hh
      real (kind=Rk) :: scale,rsign
!     real (kind=Rk) :: one,scale,rsign,zero
!     Data zero/0./,one/1./

      do i=1,n
         do j=1,i
            Z(i,j)=A(i,j)
         enddo
      enddo
!
!     FOR I=N STEP -1 UNTIL 2 DO --
      do ii=2,n
         I=N+2-II
         L=I-1
         H=ZERO
         SCALE=ZERO
         IF(L.LT.2) GOTO 130
!     SCALE ROW (ALGOL TOL THEN NOT NEEDED)
         DO 120 K=1,L
  120    SCALE=SCALE+ABS(Z(I,K))
         IF(SCALE.NE.ZERO) GOTO 140
  130    E(I)=Z(I,L)
         GOTO 290
  140    DO 150 K=1,L
         Z(I,K)=Z(I,K)/SCALE
         H=H+Z(I,K)*Z(I,K)
  150 CONTINUE
         F=Z(I,L)
         rsign=ONE
         if( real(F,kind=Rk).lt.0.) rsign=-ONE
         G=-rsign*SQRT(H)
         E(I)=SCALE*G
         H=H-F*G
         Z(I,L)=F-G
         F=ZERO
         DO 240 J=1,L
         Z(J,I)=Z(I,J)/(SCALE*H)
         G=ZERO
!     FORM ELEMENT OF A*U
         DO 180 K=1,J
  180    G=G+Z(J,K)*Z(I,K)
         JP1=J+1
         IF(L.LT.JP1) GOTO 220
         DO 200 K=JP1,L
  200    G=G+Z(K,J)*Z(I,K)
!     FORM ELEMENT OF PP
  220    E(J)=G/H
         F=F+E(J)*Z(I,J)
  240    CONTINUE
         HH=F/(H+H)
!     FORM REDUCED A
         DO 260 J=1,L
         F=Z(I,J)
         G=E(J)-HH*F
         E(J)=G
         DO 260 K=1,J
         Z(J,K)=Z(J,K)-F*E(K)-G*Z(I,K)
  260 CONTINUE
         DO 280 K=1,L
  280    Z(I,K)=SCALE*Z(I,K)
  290    D(I) = H
      enddo
  320 D(1)=ZERO
      E(1)=ZERO
!     ACCUMULATION OF TRANSFORMATION MATRICES
      DO 500 I=1,N
      L=I-1
      IF(abs(D(I)).EQ.ZERO) GOTO 380
      DO 360 J=1,L
      G=ZERO
      DO 340 K=1,L
  340 G=G+Z(I,K)*Z(K,J)
      DO 360 K=1,L
      Z(K,J)=Z(K,J)-G*Z(K,I)
  360 CONTINUE
  380 D(I)=Z(I,I)
      Z(I,I)=ONE
      IF(L.LT.1) GOTO 500
      DO 400 J=1,L
      Z(I,J)=ZERO
      Z(J,I)=ZERO
  400 CONTINUE
  500 CONTINUE
      RETURN
  end subroutine QML_cTred2

  SUBROUTINE QML_Lanczos(A,n_vect,D,V,epsi,max_it)
      USE NumParameters_m
      USE UtilLib_m
      IMPLICIT NONE

      integer,          intent(in)    :: n_vect
      real(kind=Rk), intent(in)    :: A(:,:)
      real(kind=Rk), intent(inout) :: V(:,:),D(:)
      real(kind=Rk), intent(in)    :: epsi
      integer,          intent(in)    :: max_it

      real(kind=Rk), allocatable :: Krylov_vectors(:,:)
      real(kind=Rk), allocatable :: M_Krylov(:,:)
      real(kind=Rk), allocatable :: V_Krylov(:,:)
      real(kind=Rk), allocatable :: E0_Krylov(:)
      real(kind=Rk), allocatable :: E1_Krylov(:)
      real(kind=Rk)              :: y,maxdiff

      integer :: i,it,n_size

      ! Begin Lanczos scheme
      n_size = size(A,dim=1)
      write(6,*) 'shape(A)',shape(A)
      write(6,*) 'shape(V)',shape(V)
      write(6,*) 'shape(D)',shape(D)
      write(6,*) 'n_size',n_size
      write(6,*) 'n_vect',n_vect
      write(6,*) 'max_it',max_it
      write(6,*) 'epsi',epsi

      allocate(Krylov_vectors(n_size,0:max_it))
      Krylov_vectors(:,:) = ZERO
      CALL random_number(Krylov_vectors(1:n_vect,0))
      Krylov_vectors(:,0) = Krylov_vectors(:,0) /                               &
                      sqrt(dot_product(Krylov_vectors(:,0),Krylov_vectors(:,0)))
      write(6,*) 'Krylov_vectors (guess)',Krylov_vectors(:,0)

      allocate(M_Krylov(max_it,max_it))
      allocate(V_Krylov(max_it,max_it))
      allocate(E0_Krylov(max_it))
      allocate(E1_Krylov(max_it))
      maxdiff = huge(ONE)

      DO it=1,max_it

         Krylov_vectors(:,it) = matmul(A,Krylov_vectors(:,it-1))

         DO i=0,it-1
            M_Krylov(i+1, it) = dot_product(Krylov_vectors(:,i),Krylov_vectors(:,it))
            M_Krylov(it, i+1) = M_Krylov(i+1,it)
         END DO
         CALL Write_RMat(M_Krylov(1:it,1:it),out_unitp,5)

         ! Orthogonalize vectors
         DO i=0,it-1
            y = dot_product(Krylov_vectors(:,i),Krylov_vectors(:,it))
            Krylov_vectors(:,it) = Krylov_vectors(:,it) - y * Krylov_vectors(:,i)
         END DO
         ! Normalize vector
          Krylov_vectors(:,it) =   Krylov_vectors(:,it) /                      &
                  sqrt(dot_product(Krylov_vectors(:,it),Krylov_vectors(:,it)))

         IF (it >= n_vect) THEN
            CALL diagonalization(M_Krylov(1:it,1:it),E1_Krylov(1:it),V_Krylov(1:it,1:it),it,3,1,.FALSE.)
            write(6,*) 'it eig',it,E1_Krylov(1:n_vect)
         END IF
         IF (it > n_vect) THEN
            maxdiff = maxval(abs(E1_Krylov(1:n_vect) - E0_Krylov(1:n_vect)))
            E0_Krylov(1:n_vect) = E1_Krylov(1:n_vect)
         ELSE
            maxdiff = huge(ONE)
         END IF
         write(6,*) 'it maxdiff,epsi,exit?',it,maxdiff,epsi,(maxdiff < epsi)

         IF (maxdiff < epsi) EXIT

      END DO
stop
  end subroutine QML_Lanczos

END MODULE diago_m


      SUBROUTINE DMPINT (A,NA,B,NB)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-15 CLL Edited to use M77CON.
C>> 1994-11-11 DMPINT  Krogh   Declared all vars.
C>> 1987-12-09 DMPINT Lawson  Initial code.
C
C     INDEFINITE INTEGRATION OF A POLYNOMIAL REPRESENTED BY COEFFS
C     RELATIVE TO THE MONOMIAL BASIS INCLUDING A LINEAR TRANSFORMATION
C     OF THE ARGUMENT.
C     C.L.LAWSON, JP, 1973 DEC 6
C
C     (A(I),I=1,2)       SCALE FACTORS
C     (A(I+2),I=1,NA+1)  COEFS OF POLY
C     NA                 DEGREE OF POLY
C     (B(I),I=1,2)       OUTPUT..  SCALE FACTORS
C     (B(I+2),I=1,NB+1   OUTPUT..  COEFS OF INTEGRATED
C                                  POLY
C     NB                 OUTPUT..  DEGREE OF POLY
C
c     ------------------------------------------------------------------
c--D replaces "?": ?MPINT
c     ------------------------------------------------------------------
      INTEGER I, NA, NAP3, NB
      DOUBLE PRECISION A(*), B(*), DIV
c     ------------------------------------------------------------------
      IF (NA .LT. 0) THEN
        CALL IERM1('DMPINT',1,0,'REQUIRE NA .GE. 0','NA',NA,'.')
      ELSE
        B(1)=A(1)
        B(2)=A(2)
        NAP3=NA+3
        NB=  NAP3-2
        B(3)=0.D0
        DIV=0.D0
        DO 30 I=3,NAP3
          DIV=DIV+1.D0
   30     B(I+1)=B(2)*A(I)/DIV
      END IF
      RETURN
      END


      SUBROUTINE SOLVE (N,A,IP,B,NDIM)
C
C     SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT
C     LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH
C     OF WHICH ARE STORED IN A.  THE RHS VECTOR B IS INPUT AND THE
C     SOLUTION IS RETURNED THROUGH VECTOR B.
C
      COMPLEX A,B,Y,SUM
      INTEGER PI
      COMMON /SCRATM/ Y(600)
      DIMENSION A(NDIM,NDIM), IP(NDIM), B(NDIM)
C
C     FORWARD SUBSTITUTION
C
      DO 3 I=1,N
      PI=IP(I)
      Y(I)=B(PI)
      B(PI)=B(I)
      IP1=I+1
      IF (IP1.GT.N) GO TO 2
      DO 1 J=IP1,N
      B(J)=B(J)-A(J,I)*Y(I)
1     CONTINUE
2     CONTINUE
3     CONTINUE
C
C     BACKWARD SUBSTITUTION
C
      DO 6 K=1,N
      I=N-K+1
      SUM=(0.,0.)
      IP1=I+1
      IF (IP1.GT.N) GO TO 5
      DO 4 J=IP1,N
      SUM=SUM+A(I,J)*B(J)
4     CONTINUE
5     CONTINUE
      B(I)=(Y(I)-SUM)/A(I,I)
6     CONTINUE
      RETURN
      END


!  ------------------- BEGIN WIND_EXP ---------------------------
      function  wind_exp( t, te, eps_w, eta_w, new_mr)
!
!     apply Sargoni and Hart (1974) window, with parameters
!     tw, eps (fraction of tw to reach peak), and
!     eta ( fraction of peak ampl. at tw).  See Boore (BSSA, 1983,
!     p. 1869).  Note that t can be larger than tw.

! Dates:
!         05/30/95 - Initially written by Dave Boore, based on a routine
!                    by G. Atkinson but with significant structural
!                    changes and the taper to be a raised cosine taper
!         12/06/95 - Removed the taper and simplified the parameters in the
!                    calling list.  Also added a switch so that the window
!                    shape coefficients are only computed once.  This assumes
!                    that the shape coefficients will be the same for
!                    any run of the program... a good assumption.
!         12/28/95 - Used new_mr, set from driver, to control computation
!                    of b,c,a; before I used "firstcall", set in this
!                    subprogram, but this gave an error if the driver
!                    looped over multiple values of m and r.
!         01/27/01 - Modified time series window computation (changed variable
!                    names, use normalized time)

      real wind_exp
      logical new_mr
      save a, b, c

      if (new_mr) then
        b = -eps_w * alog(eta_w)/
     :      (1. + eps_w*(alog(eps_w)-1.))
        c = b/eps_w
        a = (exp(1.0)/eps_w)**b
        new_mr = .false.
      end if

      wind_exp = 0.
      if( t .lt. 0.0) return
!
!     Apply Sargoni and Hart window.
!
      wind_exp = a*(t/te)**b * exp(-c*(t/te))

      return
      end
!------------------- END WIND_EXP ---------------------------


SUBROUTINE geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
! Used in p73
! This subroutine forms the coordinates and connectivity for a
! rectangular mesh of rt. angled triangular elements (3, 6, 10 or 15-node)
! or quadrilateral elements (4, 8 or 9-node) counting in the
! x- or y-dir.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x_coords(:),y_coords(:)
 REAL(iwp),INTENT(OUT)::coord(:,:)
 CHARACTER(LEN=15),INTENT(IN)::element
 CHARACTER(LEN=1),INTENT(IN)::dir
 INTEGER,INTENT(IN)::iel
 INTEGER,INTENT(OUT)::num(:)
 INTEGER::ip,iq,jel,fac1,nod,nxe,nye
 REAL(iwp)::pt5=0.5_iwp,two=2.0_iwp,d3=3.0_iwp
 nxe=UBOUND(x_coords,1)-1
 nod=UBOUND(num,1)
 IF(element=='triangle')THEN
   nye=(UBOUND(y_coords,1)-1)*2
   IF(dir=='x'.OR.dir=='r')THEN
     jel=2*nxe*((iel-1)/(2*nxe))
     ip=(iel-jel+1)/2
     iq=2*((iel-1)/(2*nxe)+1)-1+((iel/2)*2)/iel
   ELSE
     jel=(iel-1)/nye
     ip=jel+1
     iq=iel-nye*jel
   END IF
   SELECT CASE(nod)
   CASE(3)
     IF(MOD(iq,2)/=0)THEN
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=(nxe+1)*(iq-1)/2+ip
         num(2)=num(1)+1
         num(3)=(nxe+1)*(iq+1)/2+ip
       ELSE
         num(1)=(ip-1)*(nye+2)/2+(iq+1)/2
         num(2)=num(1)+(nye+2)/2
         num(3)=num(1)+1
       END IF
!
       coord(1,1)=x_coords(ip)
       coord(1,2)=y_coords((iq+1)/2)
       coord(2,1)=x_coords(ip+1)
       coord(2,2)=y_coords((iq+1)/2)
       coord(3,1)=x_coords(ip)
       coord(3,2)=y_coords((iq+3)/2)
     ELSE
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=(nxe+1)*iq/2+ip+1
         num(2)=num(1)-1
         num(3)=(nxe+1)*(iq-2)/2+ip+1
       ELSE
         num(1)=ip*(nye+2)/2+(iq+2)/2
         num(2)=(ip-1)*(nye+2)/2+(iq+1)/2+1
         num(3)=num(1)-1
       END IF
!
       coord(1,1)=x_coords(ip+1)
       coord(1,2)=y_coords((iq+2)/2)
       coord(2,1)=x_coords(ip)
       coord(2,2)=y_coords((iq+2)/2)
       coord(3,1)=x_coords(ip+1)
       coord(3,2)=y_coords(iq/2)
     END IF
   CASE(6)
     IF(MOD(iq,2)/=0)THEN
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=(iq-1)*(2*nxe+1)+2*ip-1
         num(2)=num(1)+1
         num(3)=num(1)+2
         num(4)=(iq-1)*(2*nxe+1)+2*nxe+2*ip+1
         num(5)=(iq+1)*(2*nxe+1)+2*ip-1
         num(6)=num(4)-1
       ELSE
         num(1)=2*(nye+1)*(ip-1)+iq
         num(2)=2*(nye+1)*(ip-1)+nye+1+iq
         num(3)=2*(nye+1)*ip+iq
         num(4)=num(2)+1
         num(5)=num(1)+2
         num(6)=num(1)+1
       END IF
!
       coord(1,1)=x_coords(ip)
       coord(1,2)=y_coords((iq+1)/2)
       coord(3,1)=x_coords(ip+1)
       coord(3,2)=y_coords((iq+1)/2)
       coord(5,1)=x_coords(ip)
       coord(5,2)=y_coords((iq+3)/2)
     ELSE
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=iq*(2*nxe+1)+2*ip+1
         num(2)=num(1)-1
         num(3)=num(1)-2
         num(4)=(iq-2)*(2*nxe+1)+2*nxe+2*ip+1
         num(5)=(iq-2)*(2*nxe+1)+2*ip+1
         num(6)=num(4)+1
       ELSE
         num(1)=2*(nye+1)*ip+iq+1
         num(2)=2*(nye+1)*(ip-1)+nye+iq+2
         num(3)=2*(nye+1)*(ip-1)+iq+1
         num(4)=num(2)-1
         num(5)=num(1)-2
         num(6)=num(1)-1
       END IF
!
       coord(1,1)=x_coords(ip+1)
       coord(1,2)=y_coords((iq+2)/2)
       coord(3,1)=x_coords(ip)
       coord(3,2)=y_coords((iq+2)/2)
       coord(5,1)=x_coords(ip+1)
       coord(5,2)=y_coords(iq/2)
     END IF
     coord(2,:)=pt5*(coord(1,:)+coord(3,:))
     coord(4,:)=pt5*(coord(3,:)+coord(5,:))
     coord(6,:)=pt5*(coord(5,:)+coord(1,:))
   CASE(10)
     IF(MOD(iq,2)/=0)THEN
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=(iq-1)/2*(3*nxe+1)*3+3*ip-2
         num(2)=num(1)+1
         num(3)=num(1)+2
         num(4)=num(1)+3
         num(5)=(iq-1)/2*(3*nxe+1)*3+3*nxe+1+3*ip
         num(6)=(iq-1)/2*(3*nxe+1)*3+6*nxe+2+3*ip-1
         num(7)=(iq-1)/2*(3*nxe+1)*3+9*nxe+3+3*ip-2
         num(8)=num(6)-1
         num(9)=num(5)-2
         num(10)=num(9)+1
       ELSE
         num(1)=(9*(nye-2)/2+12)*(ip-1)+3*(iq-1)/2+1
         num(2)=(9*(nye-2)/2+12)*(ip-1)+3*(nye-2)/2+4+3*(iq-1)/2+1
         num(3)=(9*(nye-2)/2+12)*(ip-1)+3*(nye-2)+8+3*(iq-1)/2+1
         num(4)=(9*(nye-2)/2+12)*(ip-1)+9*(nye-2)/2+12+3*(iq-1)/2+1
         num(5)=num(3)+1
         num(6)=num(2)+2
         num(7)=num(1)+3
         num(8)=num(1)+2
         num(9)=num(1)+1
         num(10)=num(2)+1
       END IF
!
       coord(1,1)=x_coords(ip)
       coord(2,1)=x_coords(ip)+(x_coords(ip+1)-x_coords(ip))/d3
       coord(3,1)=x_coords(ip)+two*(x_coords(ip+1)-x_coords(ip))/d3
       coord(4,1)=x_coords(ip+1)
       coord(4,2)=y_coords((iq+1)/2)
       coord(5,2)=y_coords((iq+1)/2)+                                     &
         (y_coords((iq+3)/2)-y_coords((iq+1)/2))/d3
       coord(6,2)=y_coords((iq+1)/2)+                                     &
         two*(y_coords((iq+3)/2)-y_coords((iq+1)/2))/d3
       coord(7,2)=y_coords((iq+3)/2)
     ELSE
       IF(dir=='x'.OR.dir=='r')THEN
         num(1)=(iq-2)/2*(3*nxe+1)*3+9*nxe+3+3*ip+1
         num(2)=num(1)-1
         num(3)=num(1)-2
         num(4)=num(1)-3
         num(5)=(iq-2)/2*(3*nxe+1)*3+6*nxe+2+3*ip-1
         num(6)=(iq-2)/2*(3*nxe+1)*3+3*nxe+1+3*ip
         num(7)=(iq-2)/2*(3*nxe+1)*3+3*ip+1
         num(8)=num(6)+1
         num(9)=num(5)+2
         num(10)=num(9)-1
       ELSE
         num(1)=(9*(nye-2)/2+12)*(ip-1)+9*(nye-2)/2+12+3*iq/2+1
         num(2)=(9*(nye-2)/2+12)*(ip-1)+3*(nye-2)+8+3*iq/2+1
         num(3)=(9*(nye-2)/2+12)*(ip-1)+3*(nye-2)/2+4+3*iq/2+1
         num(4)=(9*(nye-2)/2+12)*(ip-1)+3*iq/2+1
         num(5)=num(3)-1
         num(6)=num(2)-2
         num(7)=num(1)-3
         num(8)=num(1)-2
         num(9)=num(1)-1
         num(10)=num(2)-1
       END IF
!
       coord(1,1)=x_coords(ip+1)
       coord(2,1)=x_coords(ip+1)-(x_coords(ip+1)-x_coords(ip))/d3
       coord(3,1)=x_coords(ip+1)-two*(x_coords(ip+1)-x_coords(ip))/d3
       coord(4,1)=x_coords(ip)
       coord(4,2)=y_coords((iq+2)/2)
       coord(5,2)=y_coords((iq+2)/2)-(y_coords((iq+2)/2)-y_coords(iq/2))/d3
       coord(6,2)=y_coords((iq+2)/2)-                                     &
         two*(y_coords((iq+2)/2)-y_coords(iq/2))/d3
       coord(7,2) =y_coords(iq/2)
     END IF
     coord(5,1)=coord(3,1)
     coord(6,1)=coord(2,1)
     coord(7,1)=coord(1,1)
     coord(8,1)=coord(1,1)
     coord(9,1)=coord(1,1)
     coord(10,1)=coord(2,1)
     coord(1,2)=coord(4,2)
     coord(2,2)=coord(4,2)
     coord(3,2)=coord(4,2)
     coord(8,2)=coord(6,2)
     coord(9,2)=coord(5,2)
     coord(10,2)=coord(5,2)
   CASE(15)
     IF(MOD(iq,2)/=0)THEN
       IF(dir=='x'.OR.dir=='r')THEN
       fac1=4*(4*nxe+1)*(iq-1)/2
         num(1)=fac1+4*ip-3
         num(2)=num(1)+1
         num(3)=num(1)+2
         num(4)=num(1)+3
         num(5)=num(1)+4
         num(6)=fac1+ 4*nxe+1+4*ip
         num(7)=fac1+ 8*nxe+1+4*ip
         num(8)=fac1+12*nxe+1+4*ip
         num(9)=fac1+16*nxe+1+4*ip
         num(10)=num(8)-1
         num(11)=num(7)-2
         num(12)=num(6)-3
         num(13)=num(12)+1
         num(14)=num(12)+2
         num(15)=num(11)+1
       ELSE
         fac1=4*(2*nye+1)*(ip-1)+2*iq-1
         num(1)=fac1
         num(2)=fac1+2*nye+1
         num(3)=fac1+4*nye+2
         num(4)=fac1+6*nye+3
         num(5)=fac1+8*nye+4
         num(6)=fac1+6*nye+4
         num(7)=fac1+4*nye+4
         num(8)=fac1+2*nye+4
         num(9)=fac1+4
         num(10)=fac1+3
         num(11)=fac1+2
         num(12)=fac1+1
         num(13)=fac1+2*nye+2
         num(14)=fac1+4*nye+3
         num(15)=fac1+2*nye+3
       END IF
!
       coord(1,1)=x_coords(ip)
       coord(1,2)=y_coords((iq+1)/2)
       coord(5,1)=x_coords(ip+1)
       coord(5,2)=y_coords((iq+1)/2)
       coord(9,1)=x_coords(ip)
       coord(9,2)=y_coords((iq+3)/2)
     ELSE
       IF(dir=='x'.OR.dir=='r')THEN
         fac1=4*(4*nxe+1)*(iq-2)/2
         num(1)=fac1+16*nxe+5+4*ip
         num(2)=num(1)-1
         num(3)=num(1)-2
         num(4)=num(1)-3
         num(5)=num(1)-4
         num(6)=fac1+12*nxe+1+4*ip
         num(7)=fac1+8*nxe+1+4*ip
         num(8)=fac1+4*nxe+1+4*ip
         num(9)=fac1+4*ip+1
         num(10)=num(8)+1
         num(11)=num(7)+2
         num(12)=num(6)+3
         num(13)=num(12)-1
         num(14)=num(12)-2
         num(15)=num(11)-1
       ELSE
         fac1=4*(2*nye+1)*(ip-1)+2*iq+8*nye+5
         num(1)=fac1
         num(2)=fac1-2*nye-1
         num(3)=fac1-4*nye-2
         num(4)=fac1-6*nye-3
         num(5)=fac1-8*nye-4
         num(6)=fac1-6*nye-4
         num(7)=fac1-4*nye-4
         num(8)=fac1-2*nye-4
         num(9)=fac1-4
         num(10)=fac1-3
         num(11)=fac1-2
         num(12)=fac1-1
         num(13)=fac1-2*nye-2
         num(14)=fac1-4*nye-3
         num(15)=fac1-2*nye-3
       END IF
!
       coord(1,1)=x_coords(ip+1)
       coord(1,2)=y_coords((iq+2)/2)
       coord(5,1)=x_coords(ip)
       coord(5,2)=y_coords((iq+2)/2)
       coord(9,1)=x_coords(ip+1)
       coord(9,2)=y_coords(iq/2)
     END IF
     coord(3,:)=pt5*(coord(1,:)+coord(5,:))
     coord(7,:)=pt5*(coord(5,:)+coord(9,:))
     coord(11,:)=pt5*(coord(9,:)+coord(1,:))
     coord(2,:)=pt5*(coord(1,:)+coord(3,:))
     coord(4,:)=pt5*(coord(3,:)+coord(5,:))
     coord(6,:)=pt5*(coord(5,:)+coord(7,:))
     coord(8,:)=pt5*(coord(7,:)+coord(9,:))
     coord(10,:)=pt5*(coord(9,:)+coord(11,:))
     coord(12,:)=pt5*(coord(11,:)+coord(1,:))
     coord(15,:)=pt5*(coord(7,:)+coord(11,:))
     coord(14,:)=pt5*(coord(3,:)+coord(7,:))
     coord(13,:)=pt5*(coord(2,:)+coord(15,:))
   CASE DEFAULT
     WRITE(11,'(a)')"Wrong number of nodes for triangular element"
     STOP
   END SELECT
 ELSE
   nye=UBOUND(y_coords,1)-1
   IF(dir=='x'.OR.dir=='r')THEN
     iq=(iel-1)/nxe+1
     ip=iel-(iq-1)*nxe
   ELSE
     ip=(iel-1)/nye+1
     iq=iel-(ip-1)*nye
   END IF
   SELECT CASE(nod)
   CASE(4)
     IF(dir=='x'.OR.dir=='r')THEN
       num(1)=iq*(nxe+1)+ip
       num(2)=(iq-1)*(nxe+1)+ip
       num(3)=num(2)+1
       num(4)=num(1)+1
     ELSE
       num(1)=(ip-1)*(nye+1)+iq+1
       num(2)=num(1)-1
       num(3)=ip*(nye+1)+iq
       num(4)=num(3)+1
     END IF
!
     coord(1:2,1)=x_coords(ip)
     coord(3:4,1)=x_coords(ip+1)
     coord(1,2)=y_coords(iq+1)
     coord(2:3,2)=y_coords(iq)
     coord(4,2)=coord(1,2)
   CASE(5)
     IF(dir=='x'.OR.dir=='r')THEN
       num(1)=iq*(2*nxe+1)+ip
       num(2)=(iq-1)*(2*nxe+1)+ip
       num(3)=num(2)+1
       num(4)=num(1)+1
       num(5)=iq*(2*nxe+1)+ip-nxe
     ELSE
       num(1)=(ip-1)*(2*nye+1)+iq+1
       num(2)=num(1)-1
       num(3)=ip*(2*nye+1)+iq
       num(4)=num(3)+1
       num(5)=ip*(2*nye+1)+iq-nye
     END IF
!
     coord(1:2,1)=x_coords(ip)
     coord(3:4,1)=x_coords(ip+1)
     coord(1,2)=y_coords(iq+1)
     coord(2:3,2)=y_coords(iq)
     coord(4,2)=coord(1,2)
     coord(5,:)=0.25_iwp*(coord(1,:)+coord(2,:)+coord(3,:)+coord(4,:))
   CASE(8)
     IF(dir=='x'.OR.dir=='r')THEN
       num(1)=iq*(3*nxe+2)+2*ip-1
       num(2)=iq*(3*nxe+2)+ip-nxe-1
       num(3)=(iq-1)*(3*nxe+2)+2*ip-1
       num(4)=num(3)+1
       num(5)=num(4)+1
       num(6)=num(2)+1
       num(7)=num(1)+2
       num(8)=num(1)+1
     ELSE
       num(1)=(ip-1)*(3*nye+2)+2*iq+1
       num(2)=num(1)-1
       num(3)=num(1)-2
       num(4)=(ip-1)*(3*nye+2)+2*nye+iq+1
       num(5)=ip*(3*nye+2)+2*iq-1
       num(6)=num(5)+1
       num(7)=num(5)+2
       num(8)=num(4)+1
     END IF
!
     coord(1:3,1)=x_coords(ip)
     coord(5:7,1)=x_coords(ip+1)
     coord(4,1)=pt5*(coord(3,1)+coord(5,1))
     coord(8,1)=pt5*(coord(7,1)+coord(1,1))
     coord(1,2)=y_coords(iq+1)
     coord(7:8,2)=y_coords(iq+1)
     coord(3:5,2)=y_coords(iq)
     coord(2,2)=pt5*(coord(1,2)+coord(3,2))
     coord(6,2)=pt5*(coord(5,2)+coord(7,2))
   CASE(9)
     IF(dir=='x'.OR.dir=='r')THEN
       num(1)=iq*(4*nxe+2)+2*ip-1
       num(2)=iq*(4*nxe+2)+2*ip-nxe-4
       num(3)= (iq-1)*(4*nxe+2)+2*ip-1
       num(4)=num(3)+1
       num(5)=num(4)+1
       num(6)=num(2)+2
       num(7)=num(1)+2
       num(8)=num(1)+1
       num(9)=num(2)+1
     ELSE
       num(1)=(ip-1)*2*(2*nye+1)+2*iq+1
       num(2)=num(1)-1
       num(3)=num(1)-2
       num(4)=(ip-1)*2*(2*nye+1)+2*nye+2*iq
       num(5)=ip*2*(2*nye+1)+2*iq-1
       num(6)=num(5)+1
       num(7)=num(5)+2
       num(8)=num(4)+2
       num(9)=num(4)+1
     END IF
!
     coord(1:3,1)=x_coords(ip)
     coord(5:7,1)=x_coords(ip+1)
     coord(4,1)=pt5*(coord(3,1)+coord(5,1))
     coord(8,1)=pt5*(coord(7,1)+coord(1,1))
     coord(1,2)=y_coords(iq+1)
     coord(7:8,2)=y_coords(iq+1)
     coord(3:5,2)=y_coords(iq)
     coord(2,2)=pt5*(coord(1,2)+coord(3,2))
     coord(6,2)=pt5*(coord(5,2)+coord(7,2))
     coord(9,:)=pt5*(coord(4,:)+coord(8,:))
   CASE DEFAULT
     WRITE(11,'(a)')"Wrong number of nodes for quadrilateral element"
     STOP
   END SELECT
 END IF
RETURN
END SUBROUTINE geom_rect


  SUBROUTINE saturate_ice_points(t,p,thresh,sh_m,rh_m)

  ! Subroutine to saturate grid boxes with respect to ice

    IMPLICIT NONE

    ! Inputs:

    REAL, INTENT(IN)    :: t      ! Temperature (K)
    REAL, INTENT(IN)    :: p      ! Pressure (Pa)
    REAL, INTENT(IN)    :: thresh ! Saturation factor
              ! Set thresh to 1.0 to convert cloud ice up to
              ! ice saturation

    ! Outputs:

    REAL, INTENT(OUT)   :: sh_m   ! Adjusted specific humidity
    REAL, INTENT(OUT)   :: rh_m   ! Adjusted RH (%)

    ! Locals

    REAL :: shsat,mr,mrsat,mrmax,tc,esi,esw,e
    REAL, EXTERNAL :: ssh2,es,esice

    tc = t - 273.15

    ! Determine ice satuaration vapor pressure
    esi = esice(tc)

    ! Determine water saturation vapor pressure
    esw = es(tc)

    ! Compute the e needed to reach thresh saturation wrt ice
    e = thresh * esi

    ! Compute rh wrt liquid for this new e
    rh_m = e/esw * 100.
    ! Compute saturated sh by seting e = esi in the
    ! typical formula for q

    sh_m = (0.622 * esi) / ( p - 0.378 * esi)

    RETURN
  END SUBROUTINE saturate_ice_points


module local_routines
    !! Define initial and boundary conditions

    use global_mod, only: dp, ip, charlen, wall_elevation, pi, gravity
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use read_raster_mod, only: read_gdal_raster
    use which_mod, only: which
    use file_io_mod, only: count_file_lines
    use linear_interpolator_mod, only: linear_interpolator_type
    implicit none

    type :: boundary_information_type
        !! Hold some data used by the boundary condition. We can set this from
        !! inside the main program.
        real(dp) :: offshore_elev
        real(dp) :: boundary_wave_period
    end type

    type(boundary_information_type), public :: boundary_information
        !! The main program will modify this type to set up the boundary condition

    contains

    pure function boundary_function(domain, t, i, j) result(stage_uh_vh_elev)
        !! Make a function to evaluate the boundary at the domain. We will use
        !! this in conjunction with a flather type radiation condition

        type(domain_type), intent(in):: domain
        real(dp), intent(in):: t
        integer(ip), intent(in) :: i, j
        real(dp):: stage_uh_vh_elev(4), wavelength, waveperiod, theta

        ! Specify a wave, corresponding to the far-field condition
        waveperiod = boundary_information%boundary_wave_period
        wavelength = (sqrt(-gravity*boundary_information%offshore_elev)*waveperiod)

        ! Make the wave come from the east
        theta = max((t/waveperiod  + (domain%x(i)-domain%x(domain%nx(1)))/wavelength), 0.0_dp)
        stage_uh_vh_elev(STG) = 1.0_dp * sin(2*pi* theta)
        stage_uh_vh_elev(UH) = -wavelength/waveperiod * stage_uh_vh_elev(STG)
        stage_uh_vh_elev(VH) = 0.0_dp
        stage_uh_vh_elev(ELV) = boundary_information%offshore_elev

    end function

    subroutine set_initial_conditions_circular_island(domain, offshore_depth, island_radius, slope_radius)
        !! Setup initial conditions + locations of gauges

        class(domain_type), target, intent(inout):: domain
        real(dp), intent(in) :: offshore_depth, island_radius, slope_radius

        ! Local variables
        real(dp) :: x, y, elev, slope, radius, theta
        real(dp), allocatable :: gauges(:,:)
        integer(ip) :: i, j

        ! Stage, UH, VH
        domain%U(:,:,[STG, UH, VH]) = 0.0_dp

        ! Set elevation
        slope = offshore_depth/(slope_radius - island_radius)
        do j = 1, domain%nx(2)
            do i = 1, domain%nx(1)
                x = domain%x(i)
                y = domain%y(j)
                radius = sqrt(x*x + y*y)
                elev = -offshore_depth + max(slope_radius - radius, 0.0_dp) *  slope
                domain%U(i,j,ELV) = elev
            end do
        end do
        ! No negative depth!
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV))

        ! Set the tide gauges
        allocate(gauges(2, 150))

        ! Gauges around the island (slightly increase the radius to avoid points on dry cells)
        do i = 1, 50
            theta = 2*pi/50.0_dp * (i-1)
            gauges(1:2,i) = (island_radius + domain%dx(1)) *  [cos(theta), sin(theta)]
        end do

        ! Gauges a bit further offshore
        do i = 1, 50
            theta = 2*pi/50.0_dp * (i-1)
            gauges(1:2, i+50) = (island_radius + (slope_radius - island_radius)/2.0_dp) *  [cos(theta), sin(theta)]
        end do

        ! Gauges yet further offshore
        do i = 1, 50
            theta = 2*pi/50.0_dp * (i-1)
            gauges(1:2, i+100) = (slope_radius) *  [cos(theta), sin(theta)]
        end do

        call domain%setup_point_gauges(gauges)

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program circular_island
    !! Plane wave scattering around a circular conical island.
    !! This case has an analytical solution, due to:
    !! Zhang and Zhu (1994) New solutions for the propagation of long waves over
    !! variable depth. Journal of fluid mechanics 278: 391-406

    use global_mod, only: ip, dp, minimum_allowed_depth, default_linear_timestepping_method
    use domain_mod, only: domain_type
    use boundary_mod, only: boundary_stage_transmissive_normal_momentum, flather_boundary
    use linear_interpolator_mod, only: linear_interpolator_type
    use local_routines
    implicit none

    integer(ip):: j
    real(dp):: last_write_time, rain_rate
    type(domain_type):: domain

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 50.0_dp
    real(dp), parameter :: final_time = 200000.0_dp

    ! Domain info
    character(charlen) :: timestepping_method = default_linear_timestepping_method

    !! length/width
    real(dp), dimension(2) :: global_lw, global_ll
    integer(ip), dimension(2) :: global_nx

    ! Local variables
    real(dp) :: timestep
    real(dp) :: offshore_depth, island_radius, slope_radius, dx
    real(dp) :: boundary_wave_period
    character(charlen):: test_case, bc_file
    real(dp):: tank_bases(4), tank_slopes(4)
    integer(ip) :: full_write_step

    ! Write the stage raster time-series less often than we write at gauges, to avoid
    ! overly large files.
    integer(ip), parameter :: frequency_full_write_steps = 60
    logical, parameter :: never_write_grid_time_slices = .false.

    ! Zero the max stage record after this much time has elapsed. The
    ! idea is to allow the transients to pass, then reset the max stage,
    ! so it ultimately only records the 'stationary' part of the run
    real(dp), parameter :: reset_max_stage_at_time = 120000.0_dp

    ! Resolution
    dx = 2000.00_dp

    ! Large scale domain. Wave comes from east side
    global_lw = [2000.0_dp , 3000.0_dp]*1e+03
    global_ll = -global_lw/2.0_dp
    global_nx = nint(global_lw/dx)

    ! Geometry
    island_radius = 40000.0_dp
    slope_radius = 160000.0_dp
    offshore_depth = 300.0_dp

    ! Incoming wave
    ! wavelength = 2 x slope_radius
    boundary_wave_period = slope_radius * 2.0_dp /sqrt(9.8_dp * offshore_depth) !12.0_dp * 60.0_dp

    domain%timestepping_method = timestepping_method

    ! Allocate domain -- must have set timestepping method BEFORE this
    call domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! Call local routine to set initial conditions
    call set_initial_conditions_circular_island(domain, offshore_depth, island_radius, slope_radius)

    ! Get the boundary data and make an interpolation function f(t) for gauge 4
    domain%boundary_function => boundary_function
    domain%boundary_subroutine => flather_boundary
    boundary_information%offshore_elev = -offshore_depth
    boundary_information%boundary_wave_period = boundary_wave_period

    ! Linear requires a fixed timestep
    if (.not. domain%adaptive_timestepping) then
        timestep = domain%stationary_timestep_max()
    end if

    ! Trick to get the code to write out just after the first timestep
    last_write_time = domain%time - approximate_writeout_frequency

    full_write_step = 0
    ! Evolve the code
    do while (.true.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            ! Reset the peak stage record once during the simulation, so the final
            ! result reflects the 'stationary' model solution
            if((domain%time >= reset_max_stage_at_time) .and. &
               (last_write_time <= reset_max_stage_at_time)) then
                domain%max_U(:,:,1) = -huge(1.0_dp)
            end if

            last_write_time = last_write_time + approximate_writeout_frequency

            ! This avoids any artefacts in the numerical update of the model
            ! which should be overwritten by the boundary condition
            call domain%update_boundary()

            full_write_step = full_write_step + 1
            if(mod(full_write_step, frequency_full_write_steps) == 0) then
                call domain%write_to_output_files(time_only=never_write_grid_time_slices)
                call domain%print()
                print*, 'Mass balance: ', domain%mass_balance_interior()
            end if

            call domain%write_gauge_time_series()

        end if

        if (domain%time > final_time) exit

        if (.not. domain%adaptive_timestepping) then
            call domain%evolve_one_step(timestep = timestep)
        else
            call domain%evolve_one_step()
        end if

    end do

    call domain%write_max_quantities()

    ! Print timing info
    call domain%timer%print()

    call domain%finalise()

end program


!>
!! Provides routines to update fluxes based on a first order upwind discretization.
MODULE upwind

USE omp_lib,       only : omp_get_thread_num
USE fluxes,        only : param, FluxI, FluxJ, FluxK

IMPLICIT NONE

#include <preprocessor.f90>

PRIVATE
PUBLIC :: UpwindFluxes

CONTAINS

    !> Updates the fluxes in x, y and z direction for the provided solution. Note that the fluxes are not returned here.
    !> @param[in] Q Solution
    SUBROUTINE UpwindFluxes(Q)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), &
                                            INTENT(IN)  :: Q

        ! Now update interface values of horizontal and vertical flux
        CALL UpdateFluxI(Q)
        CALL UpdateFluxJ(Q)
        CALL UpdateFluxK(Q)

    END SUBROUTINE UpwindFluxes

    !> Updates the horizontal fluxes in x direction using first order upwinding
    !> @param[in] Q Solution
    SUBROUTINE UpdateFluxI(Q)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), &
                        INTENT(IN) :: Q

        DOUBLE PRECISION :: Uadv
        INTEGER          :: i, j, k, thread_nr
#if(linear==0)
        DOUBLE PRECISION :: switch
#endif

        thread_nr = omp_get_thread_num()

        DO k=param%k_start, param%k_end
            DO j=param%j_start,param%j_end
                DO i=param%i_start,param%i_end+1

#if(linear==1)
                    ! Linear advection with uadv = 1
                    Uadv = 1.0_8
                    FluxI(i,j,k,thread_nr) =  0.5_8*Uadv*( Q(i-1,j,k) + Q(i,j,k) ) - 0.5_8*ABS(Uadv)*( Q(i,j,k) - Q(i-1,j,k) )

#elif(linear==0)
                    ! Nonlinear advection
                    Uadv = 0.5*(Q(i-1,j,k)+Q(i,j,k))

                    ! It is switch=0 if Uadv<0 and switch=1 if Uadv>0
                    switch = 0.5*(SIGN(1.0_8,Uadv)+1.0)

                    FluxI(i,j,k,thread_nr) = (1.0-switch)*0.5*Q(i,j,k)*Q(i,j,k) + switch*0.5*Q(i-1,j,k)*Q(i-1,j,k)
#else
                    WRITE(*,*) 'Found value other than 0 or 1 for preprocessor flag <linear>. Now exiting...'
                    STOP
#endif

               END DO
            END DO
        END DO

    END SUBROUTINE UpdateFluxI

    !> Updates the horizontal fluxes in y direction using first order upwinding
    !> @param[in] Q Solution
    SUBROUTINE UpdateFluxJ(Q)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), &
                        INTENT(IN) :: Q

        DOUBLE PRECISION :: Uadv
        INTEGER :: i, j, k, thread_nr
#if(linear==0)
        DOUBLE PRECISION :: switch
#endif

        thread_nr = omp_get_thread_num()

        DO k=param%k_start, param%k_end
            DO j=param%j_start, param%j_end+1
                DO i=param%i_start, param%i_end
#if(linear==1)
                    Uadv = 1.0_8
                    FluxJ(i,j,k,thread_nr) = 0.5_8*Uadv*( Q(i,j-1,k) + Q(i,j,k) ) - 0.5_8*ABS(Uadv)*( Q(i,j,k) - Q(i,j-1,k) )
#elif(linear==0)
                    Uadv = 0.5*(Q(i,j-1,k)+Q(i,j,k))
                    switch = 0.5*(SIGN(1.0_8,Uadv)+1.0)
                    FluxJ(i,j,k,thread_nr) = (1.0-switch)*0.5*Q(i,j,k)**2 + switch*0.5*Q(i,j-1,k)**2
#else
                    WRITE(*,*) 'Found value other than 0 or 1 for preprocessor flag <linear>. Now exiting...'
                    STOP
#endif

                END DO
            END DO
        END DO

    END SUBROUTINE UpdateFluxJ

    !> Updates the horizontal fluxes in z direction using first order upwinding
    !> @param[in] Q Solution
    SUBROUTINE UpdateFluxK(Q)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), &
                        INTENT(IN) :: Q

        DOUBLE PRECISION :: Uadv
        INTEGER :: i, j, k, thread_nr
#if(linear==0)
        DOUBLE PRECISION :: switch
#endif

        thread_nr = omp_get_thread_num()

        DO k=param%k_start, param%k_end+1
            DO j=param%j_start, param%j_end
                DO i=param%i_start, param%i_end

#if(linear==1)
                    Uadv = 1.0_8
                    FluxK(i,j,k,thread_nr) = 0.5_8*Uadv*( Q(i,j,k-1) + Q(i,j,k) ) - 0.5_8*ABS(Uadv)*( Q(i,j,k) - Q(i,j,k-1) )
#elif(linear==0)
                    Uadv = 0.5*(Q(i,j,k-1)+Q(i,j,k))
                    switch = 0.5*(SIGN(1.0_8,Uadv)+1.0)
                    FluxK(i,j,k,thread_nr) = (1.0-switch)*0.5*Q(i,j,k)**2 + switch*0.5*Q(i,j,k-1)**2
#else
                    WRITE(*,*) 'Found value other than 0 or 1 for preprocessor flag <linear>. Now exiting...'
                    STOP
#endif
                END DO
            END DO
        END DO

    END SUBROUTINE UpdateFluxK

END MODULE upwind


*DECK RST
      SUBROUTINE RST (NM, N, W, E, MATZ, Z, IERR)
C***BEGIN PROLOGUE  RST
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5
C***TYPE      SINGLE PRECISION (RST-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC TRIDIAGONAL matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        W contains the diagonal elements of the real symmetric
C          tridiagonal matrix.  W is a one-dimensional REAL array,
C          dimensioned W(N).
C
C        E contains the subdiagonal elements of the matrix in its last
C          N-1 positions.  E(1) is arbitrary.  E is a one-dimensional
C          REAL array, dimensioned E(N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are orthonormal.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  IMTQL1, IMTQL2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RST
C
      INTEGER I,J,N,NM,IERR,MATZ
      REAL W(*),E(*),Z(NM,*)
C
C***FIRST EXECUTABLE STATEMENT  RST
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  IMTQL1(N,W,E,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 DO 40 I = 1, N
C
         DO 30 J = 1, N
            Z(J,I) = 0.0E0
   30    CONTINUE
C
         Z(I,I) = 1.0E0
   40 CONTINUE
C
      CALL  IMTQL2(NM,N,W,E,Z,IERR)
   50 RETURN
      END


MODULE arrays

  IMPLICIT NONE

CONTAINS

  FUNCTION array_in(n,x) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in) :: x(n)
    INTEGER :: y
    y = SUM(x)
  END FUNCTION array_in

  SUBROUTINE array_out(nx,ny,x,y)
    INTEGER, INTENT(in) :: nx,ny
    INTEGER, INTENT(out) :: x(nx)
    INTEGER, DIMENSION(ny), INTENT(out) :: y
    x = 20
    y = 30
  END SUBROUTINE  array_out

  FUNCTION inner_prod(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in), dimension(n) :: a, b
    INTEGER :: y
    y = DOT_PRODUCT(a,b)
  END FUNCTION inner_prod

  ! Test assumed size
  FUNCTION inner_prod_2(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in), DIMENSION(*) :: a
    INTEGER, INTENT(in) :: b(*)
    INTEGER :: y
    y = DOT_PRODUCT(a(1:n),b(1:n))
  END FUNCTION inner_prod_2

END MODULE arrays


      subroutine csomm (dr,dp,dq,dpas,da,m,np)
c Modified to use complex p and q.  SIZ 4/91
c integration by the method of simpson of (dp+dq)*dr**m from
c 0 to r=dr(np)
c dpas=exponential step;
c for r in the neighborhood of zero (dp+dq)=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      double precision d1, db, dd
      complex*16 dp(*),dq(*),da,dc
      mm=m+1
      d1=dble(da+mm)
      da=0.d0
      db=0.d0
      do i=1,np
         dl=dr(i)**mm
         if (i.eq.1.or.i.eq.np) go to 10
         dl=dl+dl
         if ((i-2*(i/2)).eq.0) dl=dl+dl
 10      dc=dp(i)*dl
         da=da+dc
         dc=dq(i)*dl
         da=da+dc

      enddo
      da=dpas*da/3
      dd=exp(dpas)-1.d0
      db=d1*(d1+1.d0)*dd*exp((d1-1.d0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dd=(dr(1)**mm)*(1.d0+1.d0/(dd*(d1+1.d0)))/d1
      da=da+dd*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompGibbsMagneticSoln.f90
    !> \brief   Compute magnetic contributions to the Gibbs energy terms for a solution phase.
    !> \author  M.H.A. Piro
    !> \date    March 7, 2013
    !> \sa      CompExcessGibbsEnergy.f90
    !
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer        Description of change
    !    ----          ----------        ---------------------
    !    03/07/2013    M.H.A. Piro       Original code
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the magnetic contribution to the standard molar
    !! Gibbs energy of a solution species.  This contribution is given by
    !! \f$ \Delta g_{mag} = RT ln(B_o + 1) g(\tau ) \f$, where \f$ B_o \f$ is the average magnetic moment per
    !! atom, \f$ \tau \f$  is the absolute temperature divided by the critical temperature (i.e., the Curie
    !! temperature for ferromagnetic materials or the Neel temperature for antiferromagnetic materials) and
    !! \f$ g \f$ is a function of \f$ \tau \f$, given by:
    !! \f$ g(\tau ) = 1 - \left( \frac{79\tau^-1}{140p} + \frac{474}{497}(\frac{1}{p} - 1)(\frac{\tau ^3}{6}
    !!   + \frac{\tau ^9}{135} \frac{\tau ^15}{600}   )  \right) /D, \tau \leq 1 \f$
    !! and \f$ g(\tau ) = - \left( \frac{\tau ^{-5}}{10} + \frac{\tau ^{-15}}{315} + \frac{\tau ^{-25}}{1500}
    !!   \right) /D, \tau > 1 \f$, where \f$ D = \frac{518}{1125} + \frac{11692}{15975} \left( \frac{1}{p} -1
    !!   \right) \f$.
    !!
    !
    ! References:
    ! ===========
    !
    !> \details The following references explain the magnetic contribution to the Gibbs energy term that is
    !! used in this subroutine:
    !!
    !!   M. Hillert and M. Jarl, "A Model for Alloying Effects in Ferromagnetic Alloys," CALPHAD, 2, 3
    !!   (1978) 227-238.
    !!
    !!   A.T. Dinsdale, "SGTE Data for Pure Elements," CALPHAD, 15, 4 (1991) 317-425.
    !!
    !!   H.L. Lukas, S.G. Fries and B. Sundman, "Computational Thermodynamics: The Calphad Method," Cambridge
    !!   University Press, New York (2007).
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in]   iSolnPhaseIndex   An integer scalar representing the absolute solution phase index.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompGibbsMagneticSoln(iSolnPhaseIndex)

    USE ModuleThermo
    USE ModuleThermoIO

    implicit none

    integer :: i, iFirst, iLast, iSolnPhaseIndex
    real(8) :: B, D, p, invpmone, tau, Tcritical, g, StructureFactor
    real(8) :: dTemp, dTempA, dTempB, dTempC, dTempD

    ! Initialize variables:
    Tcritical = 0D0
    B         = 0D0

    ! Store the first and last species indices:
    iFirst = nSpeciesPhase(iSolnPhaseIndex-1) + 1
    iLast  = nSpeciesPhase(iSolnPhaseIndex)

    ! Note: the structure factor and p factor are the same for all constituents in the phase.
    StructureFactor = dCoeffGibbsMagnetic(iFirst,3)
    p               = dCoeffGibbsMagnetic(iFirst,4)
    invpmone        = 1D0/p - 1D0

    ! The critical temperature can either be the Curie temperature for ferromagnetic materials or the Neel
    ! temperature for antiferromagnetic materials.  For a solution phase, this is a linear function of the
    ! mole fractions of solution phase constituents:
    do i = iFirst, iLast
        Tcritical = Tcritical + dMolFraction(i) * dCoeffGibbsMagnetic(i,1)
        B         = B + dMolFraction(i) * dCoeffGibbsMagnetic(i,2)
    end do

    ! ChemSage files store the critical temperature for antiferromagnetic materials
    ! (i.e., the Neel temperature) as a negative real value divided by the structure factor.
    if (Tcritical < 0D0) then
        Tcritical = -Tcritical * StructureFactor
        B         = -B * StructureFactor
    end if

    ! Only proceed if the critical temperature is not zero:
    IF_Proceed: if (Tcritical /= 0D0) then

        ! Compute model parameters:
        tau = dTemperature / Tcritical
        D   = (518D0/1125D0) + (11692D0/15975D0) * invpmone

        ! The magnetic model of Hillert and Jarl is empirical and depends on tau:
        IF_Tau: if (tau > 1D0) then
            dTempA = tau**(-5)                  ! tau^(-5)
            dTempB = dTempA**(3)                ! tau^(-15)
            dTempC = dTempA * dTempA * dTempB   ! tau^(-25)
            dTempD = (1D0 / (D * Tcritical)) * (dTempA / 2D0 + dTempB / 21D0 + dTempC / 60D0)
            g      = -(dTempA/10D0 + dTempB/315D0 + dTempC/1500D0) / D

            ! Loop through species in this phase and update the chemical potential:
            do i = iFirst, iLast
                dTemp = (Tcritical - dCoeffGibbsMagnetic(i,1)) * dTempD
                dTemp = g * ((dCoeffGibbsMagnetic(i,2) - B) / (1D0 + B)) + DLOG(1D0 + B) * (dTemp + g)
                dMagGibbsEnergy(i) = dTemp
            end do
        else
            dTempA = tau**(3)                   ! tau^(3)
            dTempB = dTempA**(3)                ! tau^(9)
            dTempC = dTempA * dTempA * dTempB   ! tau^(15)
            dTempD = (-79D0 / (140D0 * p * dTemperature))
            dTempD = dTempD + (474D0/(497D0*Tcritical)) * invpmone * (dTempA / 2D0 + dTempB / 15D0 + dTempC / 40D0)
            dTempD = dTempD / D
            g      = 1D0 - (79D0/(140D0*p*tau) + (474D0/497D0)*invpmone*(dTempA/6D0 + dTempB/135D0 + dTempC/600D0)) / D

            ! Loop through species in this phase and update the chemical potential:
            do i = iFirst, iLast
                dTemp = (dCoeffGibbsMagnetic(i,1) - Tcritical) * dTempD
                dTemp = g * ((dCoeffGibbsMagnetic(i,2) - B) / (1D0 + B)) + DLOG(1D0 + B) * (dTemp + g)
                dMagGibbsEnergy(i) = dTemp
            end do

        end if IF_Tau

    end if IF_Proceed

    return

end subroutine CompGibbsMagneticSoln


program Example
  implicit none

  real :: ra(5,10)
  integer :: ia(5,10)
  integer :: i, j

  call random_number(ra)
  ia = int(ra * 20.0) + 1

outer: do i = 1, size(ia, 1)
         do j = 1, size(ia, 2)
           write(*, "(i3)", advance="no") ia(i,j)
           if (ia(i,j) == 20) exit outer
         end do
         write(*,*)
       end do outer

end program Example


function add_integer(num1, num2)
  implicit none
  integer, intent(in) :: num1
  integer, intent(in) :: num2
  integer :: add_integer

  add_integer = num1 + num2
  return
end function

function add_real(num1, num2)
  implicit none
  real, intent(in) :: num1
  real, intent(in) :: num2
  real :: add_real

  add_real = num1 + num2
  return
end function

function subtract_integer(num1, num2)
  implicit none
  integer, intent(in) :: num1
  integer, intent(in) :: num2
  integer :: subtract_integer

  subtract_integer = num1 - num2
  return
end function

function subtract_real(num1, num2)
  implicit none
  real, intent(in) :: num1
  real, intent(in) :: num2
  real :: subtract_real

  subtract_real = num1 - num2
  return
end function

function multiply_integer(num1, num2)
  implicit none
  integer, intent(in) :: num1
  integer, intent(in) :: num2
  integer :: multiply_integer

  multiply_integer = num1 * num2
  return
end function

function multiply_real(num1, num2)
  implicit none
  real, intent(in) :: num1
  real, intent(in) :: num2
  real :: multiply_real

  multiply_real = num1 * num2
  return
end function

function is_positive_int(num)
  implicit none
  integer, intent(in) :: num
  logical :: is_positive_int

  is_positive_int = num > 0
  return
end function

function is_zero_int(num)
  implicit none
  integer, intent(in) :: num
  logical :: is_zero_int

  is_zero_int = num == 0
  return
end function

function is_negative_int(num)
  implicit none
  integer, intent(in) :: num
  logical :: is_negative_int

  is_negative_int = num < 0
  return
end function

function is_single_digit_int(num)
  implicit none
  integer, intent(in) :: num
  logical :: is_single_digit_int

  is_single_digit_int = num > -10 .and. num < 10
  return
end function

function is_not_single_digit_int(num)
  implicit none
  integer, intent(in) :: num
  logical :: is_not_single_digit_int

  is_not_single_digit_int = num <= -10 .or. num >= 10
  return
end function