! CRSMatrix_Class.f90
!
! Author : Joseph Schoonover
! E-mail : jschoonover@lanl.gov, schoonover.numerics@gmail.com
!
! Copyright 2017 Joseph Schoonover, Los Alamos National Laboratory
!
! Redistribution and use in source and binary forms, with or without
! modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
! list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors
! may be used to endorse or promote products derived from this
!  software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY,  OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
! BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE  OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! ////////////////////////////////////////////////////////////////////////////////////////////////

MODULE CRSMatrix_Class
!
! This module contains a data-structure and associated routines for working with sparse matrices.
! We use the "Compressed Row Storage" model for handling sparse matrix operations. In this model,
! the elements of a matrix are stored in a single dimension array of real values. The indices
! for the start and end of each row are stored in a 2-D integer array and the columns of each
! nonzero entry are stored. As an example, consider the tri-diagonal matrix
!
! ______________________________
! Column : 1  2  3  4  5  6  7  | row |
! ______________________________|     |
!         -2  1  0  0  0  0  0  |  1  |
!          1 -2  1  0  0  0  0  |  2  |
!          0  1 -2  1  0  0  0  |  3  |
!          0  0  1 -2  1  0  0  |  4  |
!          0  0  0  1 -2  1  0  |  5  |
!          0  0  0  0  1 -2  1  |  6  |
!          0  0  0  0  0  1 -2  |  7  |
!
!  There are 7 + 6 + 6 = 19 elements in this 7x7 tri-diagonal matrix.
!  In the CRS structure, the matrix data would be stored as
!
!  A(1) = -2, A(2) = 1,
!  A(3) = 1,  A(4) = -2, A(5) = 1,
!  A(6) = 1,  A(7) = -2, A(8) = 1,
!   ........
!  A(18) = 1, A(19) = -2
!
!  The first row contains elements 1 and 2, second row contains elements (3,4,5), etc. We would
!  store the start and end of the rows as follows :
!
!  rowBounds(1,1) = 1, rowBounds(1,2) = 2
!  rowBounds(2,1) = 3, rowBounds(2,2) = 5
!  rowBounds(3,1) = 6, rowBounds(3,2) = 8
!   ........
!  rowBounds(7,1) = 18, rowBounds(7,2) = 19
!
!  * Notice that the first index of "rowBounds" varies from 1 to the number of rows.
!
!  Finally, the column needs to be stored for each non-zero element.
!
!  col(1) = 1, col(2) = 2
!  col(3) = 1, col(4) = 2, col(5) = 3
!  col(6) = 2, col(7) = 3, col(8) = 4
!   .......
!  col(18) = 6, col(19) = 7
!
! ================================================================================================ !

 USE ConstantsDictionary
 USE CommonRoutines

 IMPLICIT NONE

   TYPE CRSMatrix
      INTEGER                         :: nRows, nCols, nElems
      REAL(prec), ALLOCATABLE         :: A(:)
      INTEGER, ALLOCATABLE            :: rowBounds(:,:), col(:)

      CONTAINS

      PROCEDURE :: Build => Build_CRSMatrix
      PROCEDURE :: Reset => Reset_CRSMatrix
      PROCEDURE :: Trash => Trash_CRSMatrix

      PROCEDURE :: GetDataForRowAndCol => GetDataForRowAndCol_CRSMatrix
      PROCEDURE :: MatVecMul           => MatVecMul_CRSMatrix
      PROCEDURE :: DenseToSparse       => DenseToSparse_CRSMatrix
      PROCEDURE :: SubSample           => SubSample_CRSMatrix

!      PROCEDURE :: ReadHeader  => ReadHeader_CRSMatrix
      PROCEDURE :: WriteHeader             => WriteHeader_CRSMatrix
      PROCEDURE :: ReadSparseConnectivity  => ReadSparseConnectivity_CRSMatrix
      PROCEDURE :: WriteSparseConnectivity => WriteSparseConnectivity_CRSMatrix
      PROCEDURE :: ReadMatrixData          => ReadMatrixData_CRSMatrix
      PROCEDURE :: WriteMatrixData         => WriteMatrixData_CRSMatrix

   END TYPE CRSMatrix

 CONTAINS
!
!
!==================================================================================================!
!------------------------------- Manual Constructors/Destructors ----------------------------------!
!==================================================================================================!
!
!
 SUBROUTINE Build_CRSMatrix( myMatrix, nRows, nCols, nElems )
 ! S/R Build
 !
 !
 ! =============================================================================================== !
  IMPLICIT NONE
  CLASS( CRSMatrix ), INTENT(out) :: myMatrix
  INTEGER, INTENT(in)             :: nRows, nCols, nElems

     myMatrix % nRows = nRows
     myMatrix % nCols = nCols
     myMatrix % nElems = nElems

     ALLOCATE( myMatrix % A(1:nElems), &
               myMatrix % rowBounds(1:2,1:nRows), &
               myMatrix % col(1:nElems) )

     myMatrix % A         = 0.0_prec
     myMatrix % rowBounds = 0
     myMatrix % col       = 0

 END SUBROUTINE Build_CRSMatrix
!
 SUBROUTINE Reset_CRSMatrix( myMatrix )
 ! S/R Reset
 !
 !
 ! =============================================================================================== !
  IMPLICIT NONE
  CLASS( CRSMatrix ), INTENT(inout) :: myMatrix

     myMatrix % A         = 0.0_prec
     myMatrix % rowBounds = 0
     myMatrix % col       = 0

 END SUBROUTINE Reset_CRSMatrix
!
 SUBROUTINE Trash_CRSMatrix( myMatrix )
 ! S/R Trash
 !
 !
 ! =============================================================================================== !
  IMPLICIT NONE
  CLASS( CRSMatrix ), INTENT(inout) :: myMatrix

     DEALLOCATE( myMatrix % rowBounds, myMatrix % col, myMatrix % A )

 END SUBROUTINE Trash_CRSMatrix
!
!
!==================================================================================================!
!--------------------------------- Type Specific Routines  ----------------------------------------!
!==================================================================================================!
!
!
 FUNCTION GetDataForRowAndCol_CRSMatrix( myMatrix, i, j ) RESULT( outData )
 ! S/R GetDataForRowAndCol
 !
 ! =============================================================================================== !
   CLASS( CRSMatrix ) :: myMatrix
   REAL(prec)         :: outData
   INTEGER            :: i, j
   ! LOCAL
   INTEGER :: rstart, rEnd, k, col
   INTEGER :: localCol(1:myMatrix % nElems)

      outData = 0.0_prec

      localCol = myMatrix % col

      rstart = myMatrix % rowBounds(1,i)
      rEnd = myMatrix % rowBounds(2,i)

      k = rstart
      col = 0
      DO WHILE( col /= j .AND. k <= rEnd )
         col = localCol(k)
         k = k + 1
      ENDDO

      IF( k <= rEnd )THEN
         outData = myMatrix % A(k)
      ENDIF

 END FUNCTION GetDataForRowAndCol_CRSMatrix
!
!
!
 FUNCTION MatVecMul_CRSMatrix( myMatrix, x ) RESULT( Ax )
 ! FUNCTION MatVecMul
 !
 !    Performs matrix-vector multiply with the sparse matrix and a vector (stored as 1-D array).
 !
 ! =============================================================================================== !
 ! DECLARATIONS
   IMPLICIT NONE
   CLASS( CRSMatrix ) :: myMatrix
   REAL(prec)         :: x(1:myMatrix % nCols)
   REAL(prec)         :: Ax(1:myMatrix % nRows)
   ! Local
   INTEGER    :: iel, row
   REAL(prec) :: rowsum

      ! For each row of the matrix, a vector-product must be computed; recall that a matrix-vector
      ! product can be written :
      !                          (Ax)_i = sum_{j}( A_{i,j}x_{j} )
      ! This is equivalent to
      !                          (Ax)_i = sum_{j,A_{i,j} /= 0.0}( A_{i,j}x_{j} )
      ! where the sum is taken over non-zero elements. To achieve this, we cycle over the rows and
      ! find the non-zero columns (j) and store those input vector values.

      ! Then, we cycle over the rows and compute the sums over each row.

      !$OMP DO PRIVATE(rowSum)
      DO row = 1, myMatrix % nRows

         rowsum = 0.0_prec
         DO iel = myMatrix % rowBounds(1,row), myMatrix % rowBounds(2,row)
            rowSum = rowSum + myMatrix % A(iel)*x(myMatrix % col(iel))
         ENDDO
         Ax(row) = rowSum

      ENDDO
      !$OMP END DO

 END FUNCTION MatVecMul_CRSMatrix
!
!
!
 SUBROUTINE DenseToSparse_CRSMatrix( myMatrix, dmatrix, nRows, nCols )
 ! S/R DenseToSparse
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(out) :: myMatrix
   INTEGER, INTENT(in)             :: nRows, nCols
   REAL(prec), INTENT(in)          :: dMatrix(1:nRows,1:nCols)
   ! Local
   INTEGER    :: row, col, nEl, r1, r2
   REAL(prec) :: aij

      ! First, count the number of non-zero entries.
      nEl = 0
      DO col = 1, nCols
         DO row = 1, nRows

            aij = dMatrix(row,col)

            IF( .NOT.( AlmostEqual(aij, ZERO) ) )THEN
               nEl = nEl+1
            ENDIF

         ENDDO
      ENDDO
      PRINT*, nEl
      CALL myMatrix % Build( nRows, nCols, nEl )

      nEl = 0
      r1 = 0
      DO row = 1, nRows
         DO col = 1, nCols

            aij = dMatrix(row,col)

            IF( .NOT.( AlmostEqual(aij, ZERO) ) )THEN
               nEl = nEl+1
               myMatrix % A(nEl)   = aij
               myMatrix % col(nEl) = col
               ! Check to see if we've changed rows
               r2 = row
               IF( r2 /= r1 )THEN
                  myMatrix % rowBounds(1,row) = nEl
               ENDIF
               r1 = r2
            ENDIF

         ENDDO
      ENDDO

      DO row = 2, nRows
         myMatrix % rowBounds(2,row-1) = myMatrix % rowBounds(1,row)-1
      ENDDO
      myMatrix % rowBounds(2,nRows) = nEl

 END SUBROUTINE DenseToSparse_CRSMatrix
!
!
 SUBROUTINE SubSample_CRSMatrix( inputMatrix, subMatrix, dofMap, inverseDOFMap, nDOF, nMaxElem )
! This subroutine constructs a sparse matrix that contains only rows and
! columns specified in the "dofMap" - it "subsamples" the matrix.
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(in)   :: inputMatrix
   TYPE( CRSMatrix ), INTENT(inout) :: subMatrix
   INTEGER, INTENT(in)              :: nDOF, nMaxElem
   INTEGER, INTENT(in)              :: dofMap(1:nDOF)
   INTEGER, INTENT(in)              :: inverseDOFMap(1:inputMatrix % nRows)
   ! Local
   INTEGER :: regionMask(1:inputMatrix % nRows)
   INTEGER :: i, j, iEl, row, col, nInRow, e1, e2, jlocal
   REAL(prec) :: rowdata(1:20)

      IF( .NOT. ALLOCATED( subMatrix % A ) )THEN
         ! Allocate space for the submatrix
         ALLOCATE( subMatrix % A(1:nMaxElem), &
                   subMatrix % rowBounds(1:2,1:nDOF), &
                   subMatrix % col(1:nMaxElem) )
         subMatrix % nRows  = nDOF
         subMatrix % nCols  = nDOF
         subMatrix % nElems = nMaxElem
      ENDIF
      ! To subsample, the sparse matrix, we first need to determine the number
      ! of non-zero elements contained within the dofMap
      !  The "dofMap" tells us which rows to keep. We can cycle over each row of
      !  the sparse matrix and check a regional mask to determine if the column
      !  value should be kept.
      ! The region mask can be constructed using the dofMap. First all of the
      ! entries of the region mask are set to zero.
      regionMask = 0
      ! Then, we cycle through the dofMap to "turn on" points only set in the
      ! dofMap.
      DO i = 1, nDOF
         regionMask( dofMap(i) ) = 1
      ENDDO

      rowdata = 0.0_prec
      ! Now we fill in the submatrix data
      iEl = 0
      subMatrix % rowBounds(1,1) = 1
      DO i = 1, nDOF
         e1     = inputMatrix % rowBounds(1,dofMap(i))
         e2     = inputMatrix % rowBounds(2,dofMap(i))
         nInRow = e2-e1 + 1

         rowdata(1:nInRow) = inputMatrix % A(e1:e2)

         jlocal = 0
         DO j = e1, e2
            jlocal = jlocal + 1
            IF( regionMask(inputMatrix % col(j)) == 1 )THEN
               iEl = iEl + 1
               subMatrix % A(iEl)   = rowdata( jlocal )
               subMatrix % col(iEl) = inverseDOFMap( inputMatrix % col(j) ) ! returns the "regional" degree of freedom for the global degree of freedom
            ENDIF
         ENDDO

         subMatrix % rowBounds( 2, inverseDOFMap( dofMap(i) ) ) = iEl
         IF( inverseDOFMap( dofMap(i) ) + 1 <= nDOF )THEN
            subMatrix % rowBounds( 1, inverseDOFMap( dofMap(i) )+1 ) = iEl+1
         ENDIF

      ENDDO

 END SUBROUTINE SubSample_CRSMatrix
!
!
!==================================================================================================!
!-------------------------------------- File I/O Routines  ----------------------------------------!
!==================================================================================================!
!
!
 SUBROUTINE ReadHeader( fileBase, nRow, nCol, nElems )
 ! S/R ReadHeader
 !
 !
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CHARACTER(*), INTENT(in)          :: fileBase
   INTEGER, INTENT(out)              :: nRow, nCol, nElems
   ! Local
   INTEGER :: fUnit

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.head', &
            FORM = 'FORMATTED', &
            ACCESS = 'SEQUENTIAL', &
            STATUS = 'OLD', &
            ACTION = 'READ' )

      READ( fUnit, * ) nrow, ncol, nElems

      CLOSE( fUnit )

 END SUBROUTINE ReadHeader
!
 SUBROUTINE WriteHeader_CRSMatrix( myMatrix, fileBase )
 ! S/R WriteHeader
 !
 !
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(inout) :: myMatrix
   CHARACTER(*), INTENT(in)          :: fileBase
   ! Local
   INTEGER :: fUnit

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.head', &
            FORM = 'FORMATTED', &
            ACCESS = 'SEQUENTIAL', &
            STATUS = 'REPLACE', &
            ACTION = 'WRITE' )

      WRITE( fUnit, * ) myMatrix % nRows, myMatrix % nCols, myMatrix % nElems

      CLOSE( fUnit )

 END SUBROUTINE WriteHeader_CRSMatrix
!
 SUBROUTINE ReadSparseConnectivity_CRSMatrix( myMatrix, fileBase )
 ! S/R ReadSparseConnectivity
 !
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(inout) :: myMatrix
   CHARACTER(*), INTENT(in)          :: fileBase
   ! Local
   INTEGER :: i
   INTEGER :: recID
   INTEGER :: fUnit

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.conn', &
            FORM = 'UNFORMATTED', &
            ACCESS = 'DIRECT', &
            STATUS = 'OLD', &
            ACTION = 'READ', &
            RECL = 4 )

      recID  = 1

      DO i = 1, myMatrix % nRows
         READ( fUnit, REC = recID ) myMatrix %  rowBounds(1,i)
         recID = recID + 1
         READ( fUnit, REC = recID ) myMatrix %  rowBounds(2,i)
         recID = recID + 1
      ENDDO

      DO i = 1, myMatrix % nElems
         READ( fUnit, REC=recID ) myMatrix % col(i)
         recID = recID + 1
      ENDDO

      CLOSE( fUnit )

      !DO i = 1, myMatrix % nRows-1
      !   myMatrix % rowBounds(i,2) = myMatrix % rowBounds(i+1,1)-1
      !ENDDO

 END SUBROUTINE ReadSparseConnectivity_CRSMatrix
!
 SUBROUTINE WriteSparseConnectivity_CRSMatrix( myMatrix, fileBase )
 ! S/R WriteSparseConnectivity
 !
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(inout) :: myMatrix
   CHARACTER(*), INTENT(in)          :: fileBase
   ! Local
   INTEGER :: i
   INTEGER :: recID
   INTEGER :: fUnit

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.conn', &
            FORM = 'UNFORMATTED', &
            ACCESS = 'DIRECT', &
            STATUS = 'REPLACE', &
            ACTION = 'WRITE', &
            RECL = 4 )

      recID  = 1

      DO i = 1, myMatrix % nRows
         WRITE( fUnit, REC = recID ) myMatrix %  rowBounds(1,i)
         recID = recID + 1
         WRITE( fUnit, REC = recID ) myMatrix %  rowBounds(2,i)
         recID = recID + 1
      ENDDO

      DO i = 1, myMatrix % nElems
         WRITE( fUnit, REC=recID ) myMatrix % col(i)
         recID = recID + 1
      ENDDO

      CLOSE( fUnit )

 END SUBROUTINE WriteSparseConnectivity_CRSMatrix
!
 SUBROUTINE ReadMatrixData_CRSMatrix( myMatrix, fileBase )
 ! S/R ReadMatrixData
 !
 !    This subroutine reads the "fileBase.data" file that contains the matrix element data. As a
 !    prerequisite to calling this routine, the "% nElems" attribute needs to be filled in and
 !    memory for the "% A" attribute should be allocated.
 !
 !    Usage :
 !       CALL myMatrix % ReadMatrixData( fileBase )
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(inout) :: myMatrix
   CHARACTER(*), INTENT(in)          :: fileBase
   ! Local
   INTEGER :: ioerr, nChunks, recLength, nRealPerChunk
   INTEGER :: fUnit, dataLength, s1, s2, i
   INTEGER :: row, iEl
   REAL(prec), ALLOCATABLE :: localIOarray(:)

       dataLength = myMatrix % nElems
       IF( prec==SP )THEN

         ! Make sure that datalength is an integer multiple of nInt4PerChunk
         nChunks    = (datalength/nReal4PerChunk)
         IF( nChunks*nReal4PerChunk < datalength )THEN
            nChunks = nChunks+1
         ENDIF
         dataLength   = nChunks*nReal4PerChunk
         recLength    = nReal4PerChunk*prec
         nRealPerChunk = nReal4PerChunk

      ELSEIF( prec == DP )THEN

         ! Make sure that datalength is an integer multiple of nInt4PerChunk
         nChunks    = (datalength/nReal8PerChunk)
         IF( nChunks*nReal8PerChunk < datalength )THEN
            nChunks = nChunks+1
         ENDIF
         dataLength = nChunks*nReal8PerChunk
         recLength  = nReal8PerChunk*prec
         nRealPerChunk = nReal8PerChunk

      ELSE
         STOP
      ENDIF

      ALLOCATE( localIOarray(1:datalength) )
      localIOarray = 0.0_prec
      !localIOarray(1:myMatrix % nElems) = myMatrix % A(1:myMatrix % nElems)

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.data', &
            FORM = 'UNFORMATTED', &
            ACCESS = 'DIRECT', &
            STATUS = 'OLD', &
            ACTION = 'READ', &
            RECL = recLength )

      DO i = 1, nChunks
         s1 = 1  + (nRealPerChunk)*(i-1)
         s2 = s1 + nRealPerChunk - 1
         READ( fUnit, REC=i, IOSTAT = ioerr ) localIOarray(s1:s2)
      ENDDO
      CLOSE( fUnit )

      myMatrix % A = 0.0_prec
      myMatrix % A(1:myMatrix % nElems) = localIOarray(1:myMatrix % nElems)

!      DO row = 1, myMatrix % nRows
!
!         DO iel = myMatrix % rowBounds(1,row), myMatrix % rowBounds(2,row)
!            IF( ABS( myMatrix % A(iel) ) > 4.0_prec*10.0_prec**(-4) )THEN
!              PRINT*, myMatrix % A(iel), row, myMatrix % col(iel)
!            ENDIF
!         ENDDO
!
!      ENDDO

      DEALLOCATE( localIOarray )

 END SUBROUTINE ReadMatrixData_CRSMatrix
!
 SUBROUTINE WriteMatrixData_CRSMatrix( myMatrix, fileBase )
 ! S/R WriteMatrixData
 !
 !    Usage :
 !       CALL myMatrix % WriteMatrixData( fileBase )
 !
 ! =============================================================================================== !
   IMPLICIT NONE
   CLASS( CRSMatrix ), INTENT(in) :: myMatrix
   CHARACTER(*), INTENT(in)       :: fileBase
   ! Local
   INTEGER :: ioerr, nChunks, recLength, nRealPerChunk
   INTEGER :: fUnit, dataLength, s1, s2, i
   REAL(prec), ALLOCATABLE :: localIOarray(:)

       dataLength = myMatrix % nElems
       IF( prec==SP )THEN

         ! Make sure that datalength is an integer multiple of nInt4PerChunk
         nChunks    = (datalength/nReal4PerChunk)
         IF( nChunks*nReal4PerChunk < datalength )THEN
            nChunks = nChunks+1
         ENDIF
         dataLength   = nChunks*nReal4PerChunk
         recLength    = nReal4PerChunk*prec
         nRealPerChunk = nReal4PerChunk

      ELSEIF( prec == DP )THEN

         ! Make sure that datalength is an integer multiple of nInt4PerChunk
         nChunks    = (datalength/nReal8PerChunk)
         IF( nChunks*nReal8PerChunk < datalength )THEN
            nChunks = nChunks+1
         ENDIF
         dataLength = nChunks*nReal8PerChunk
         recLength  = nReal8PerChunk*prec
         nRealPerChunk = nReal8PerChunk

      ELSE
         STOP
      ENDIF

      ALLOCATE( localIOarray(1:datalength) )
      localIOarray = 0.0_prec
      localIOarray(1:myMatrix % nElems) = myMatrix % A(1:myMatrix % nElems)

      OPEN( UNIT = NewUnit(fUnit), &
            FILE = TRIM(fileBase)//'.data', &
            FORM = 'UNFORMATTED', &
            ACCESS = 'DIRECT', &
            STATUS = 'REPLACE', &
            ACTION = 'WRITE', &
            RECL = recLength )

      DO i = 1, nChunks
         s1 = 1  + (nRealPerChunk)*(i-1)
         s2 = s1 + nRealPerChunk - 1
         WRITE( fUnit, REC=i, IOSTAT = ioerr ) localIOarray(s1:s2)
      ENDDO
      CLOSE( fUnit )

      DEALLOCATE( localIOarray )

 END SUBROUTINE WriteMatrixData_CRSMatrix
!
!
!==================================================================================================!
!------------------------------------ File I/O Routines  ------------------------------------------!
!==================================================================================================!
!
!
END MODULE CRSMatrix_Class


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! 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 and documentation.

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

! End MIT license text.

      SUBROUTINE SYM_MAT_DECOMP_LAPACK ( CALLING_SUBR, MATIN_NAME, MATIN_SET, NROWS, NTERMS, I_MATIN, J_MATIN, MATIN, PRT_ERRS,    &
                                         MATIN_DIAG_RAT, EQUIL_MATIN, CALC_COND_NUM, DEB_PRT, EQUED, MATIN_SDIA, K_INORM, RCOND,   &
                                         EQUIL_SCALE_FACS, INFO )

! Decomposes a symmetric band matrix into triangular factors. The input matrix, MATIN, is stored in CRS sparse format and is
! converted, in this subr, to band matrix ABAND (stored in module LAPACK_DPB_MATRICES) needed for the LAPACK routines that do the
! actual work

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, LINKNO
      USE TIMDAT, ONLY                :  HOUR, MINUTE, SEC, SFRAC, STIME, TSEC
      USE CONSTANTS_1, ONLY           :  ZERO, ONE, ONEPP6
      USE PARAMS, ONLY                :  BAILOUT, EPSIL, MAXRATIO, SUPINFO
      USE LAPACK_DPB_MATRICES, ONLY   :  ABAND, LAPACK_S
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG, NDEBUG
      USE MACHINE_PARAMS, ONLY        :  MACH_LARGE_NUM
      USE LAPACK_LIN_EQN_DPB
      USE SUBR_BEGEND_LEVELS, ONLY    :  SYM_MAT_DECOMP_LAPACK_BEGEND

      USE SYM_MAT_DECOMP_LAPACK_USE_IFs

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'SYM_MAT_DECOMP_LAPACK'

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: CALLED_SUBR = ' ' ! Name of a called subr (for output error purposes)
      CHARACTER(LEN=*) , INTENT(IN)   :: CALC_COND_NUM     ! If "Y" calc RCOND (reciprocal of condition number of MATIN)
      CHARACTER(LEN=*) , INTENT(IN)   :: CALLING_SUBR      ! The subr that called this subr (used for output error purposes)
      CHARACTER(LEN=*) , INTENT(IN)   :: EQUIL_MATIN       ! If "Y" attempt to equilibrate MATIN (if it needs it)
      CHARACTER(1*BYTE), INTENT(OUT)  :: EQUED             ! 'Y' if MATIN was equilibrated in subr EQUILIBRATE (called herein)
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_DIAG_RAT    ! If "Y" calculate max ratio of matrix diagonal to factor diagonal
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_NAME        ! Name of matrix to be decomposed
      CHARACTER(LEN=*) , INTENT(IN)   :: MATIN_SET         ! Set designator for the input matrix. If it corresponds to a MYSTRAN
!                                                            displ set (e.g. 'L ' set) then error messages about singulatities
!                                                            can reference the grid/comp that is singular (otherwise the row/col
!                                                            where the singularity occurs is referenced). If it is not a MYSTRAN
!                                                            set designator it should be blank
      CHARACTER(LEN=*) , INTENT(IN)   :: PRT_ERRS          ! If not 'N', print singularity errors

      CHARACTER( 1*BYTE), PARAMETER   :: INORM    = 'I'    ! Indicates to calculate the infinity norm via LAPACK function DLANSB
      CHARACTER(54*BYTE)              :: MODNAM            ! Name to write to screen to describe module being run
      CHARACTER( 1*BYTE)              :: NONPOS_DEF        ! Indicates matrix was nonpositive definite
      CHARACTER( 1*BYTE)              :: QUIT_ON_POS_INFO  ! Indicator of whether to quit if output value of INFO is found to be > 0
      CHARACTER( 1*BYTE), PARAMETER   :: UPLO     = 'U'    ! Indicates upper triang part of matrix is stored

      INTEGER(LONG), INTENT(IN)       :: DEB_PRT(2)        ! Debug numbers to say whether to write ABAND and/or its decomp to file
      INTEGER(LONG), INTENT(IN)       :: NROWS             ! Number of rows in sparse matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: NTERMS            ! Number of nonzeros in sparse matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: I_MATIN(NROWS+1)  ! Indicators of number of nonzero terms in rows of matrix MATIN
      INTEGER(LONG), INTENT(IN)       :: J_MATIN(NTERMS)   ! Col numberts of nonzero terms in matrix MATIN

      INTEGER(LONG), INTENT(INOUT)    :: INFO              ! Output from LAPACK routine to do factorization of ABAND
                                                           !   0:  successful exit
                                                           ! < 0:  if INFO = -i, the i-th argument had an illegal value
                                                           ! > 0:  if INFO = i, the leading minor of order i is not pos def
                                                           !       and the factorization (in DPBTRS) could not be completed.

      INTEGER(LONG), INTENT(OUT)      :: MATIN_SDIA        ! No. of superdiags in the MATIN upper triangle
      INTEGER(LONG)                   :: COMPV             ! Component number (1-6) of a grid DOF
      INTEGER(LONG)                   :: GRIDV             ! Grid number
      INTEGER(LONG)                   :: I                 ! DO loop index
      INTEGER(LONG)                   :: IIMAX             ! Row/Col in MATIN where max diagonal term occurs
      INTEGER(LONG)                   :: IIMIN             ! Row/Col in MATIN where min diagonal term occurs
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = SYM_MAT_DECOMP_LAPACK_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: MATIN(NTERMS)     ! A small number to compare real zero
      REAL(DOUBLE) , INTENT(OUT)      :: RCOND             ! Recrip of cond no. of MATIN. Determined in  subr COND_NUM
      REAL(DOUBLE) , INTENT(OUT)      :: K_INORM           ! Inf norm of MATIN matrix (det in  subr COND_NUM)
      REAL(DOUBLE)                    :: EPS1              ! A small number to compare real zero

      REAL(DOUBLE) , INTENT(OUT)      :: EQUIL_SCALE_FACS(NROWS)
                                                           ! LAPACK_S values to return to calling subr

      REAL(DOUBLE)                    :: MATIN_DIAG(NROWS) ! Diagonal terms from MATIN matrix
      REAL(DOUBLE)                    :: KRATIO            ! Ratio: MAXKII/MINKII
      REAL(DOUBLE)                    :: MAXKII            ! Maximum diagonal term in MATIN
      REAL(DOUBLE)                    :: MAXIMAX_RATIO     ! Largest of the ratios of matrix diagonal to factor diagonal
      REAL(DOUBLE)                    :: MB_TO_ALLOCATE    ! MB of memory to allocate
      REAL(DOUBLE)                    :: MINKII            ! Minimum diagonal term in MATIN
      REAL(DOUBLE)                    :: FAC_DIAG          ! Diagonal term in the tringular factor of MATIN
!xx   REAL(DOUBLE)                    :: SCOND             ! Ratio of min to max scaling factors, LAPACK_S(i), if MATIN is equil'ed.
      REAL(DOUBLE)                    :: RATIO             ! Ratio of matrix diagonal to factor diagonal

      INTRINSIC                       :: DABS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Deallocate ABAND in case it is already allocated

      CALL DEALLOCATE_LAPACK_MAT ( 'ABAND' )

! We will abort if errors occur and if INFO, on input, is not -1

      QUIT_ON_POS_INFO = 'Y'
      IF (INFO == -1) THEN
         QUIT_ON_POS_INFO = 'N'
      ENDIF

      EPS1 = EPSIL(1)

! Determine bandwidth of matrix

      CALL OURTIM
      MODNAM = 'CALC BANDWIDTH OF MATRIX ' // MATIN_NAME(1:)
      WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
      CALL BANDSIZ ( NROWS, NTERMS, I_MATIN, J_MATIN, MATIN_SDIA )
      MB_TO_ALLOCATE = (REAL(DOUBLE))*(REAL(MATIN_SDIA+1))*(REAL(NROWS))/ONEPP6
      WRITE(SC1,3094) MATIN_NAME, MATIN_SDIA+1, MB_TO_ALLOCATE
      WRITE(ERR,3002) MATIN_NAME, MATIN_SDIA+1
      IF (SUPINFO == 'N') THEN
         WRITE(F06,3002) MATIN_NAME, MATIN_SDIA+1
      ENDIF
      IF (MB_TO_ALLOCATE <= ONE) THEN
         WRITE(ERR,3003) MATIN_NAME, MB_TO_ALLOCATE
         IF (SUPINFO == 'N') THEN
            WRITE(F06,3003) MATIN_NAME, MB_TO_ALLOCATE
         ENDIF
      ELSE
         WRITE(ERR,3004) MATIN_NAME, MB_TO_ALLOCATE
         IF (SUPINFO == 'N') THEN
            WRITE(F06,3004) MATIN_NAME, MB_TO_ALLOCATE
         ENDIF
      ENDIF

! Allocate array ABAND (matrix in band form for LAPACK)

      CALL OURTIM
      MODNAM = 'ALLOCATE ARRAYS FOR LAPACK BAND FORM OF ' // MATIN_NAME(1:)
      WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
      CALL ALLOCATE_LAPACK_MAT ( 'ABAND', MATIN_SDIA+1, NROWS, SUBR_NAME )
      CALL ALLOCATE_LAPACK_MAT ( 'LAPACK_S', NROWS, 1, SUBR_NAME )

! Put MATIN matrix into ABAND form required by LAPACK band matrix.

      CALL OURTIM
      MODNAM = 'PUT INTO LAPACK BAND FORM: MATRIX ' // MATIN_NAME(1:)
      WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
      CALL BANDGEN_LAPACK_DPB ( MATIN_NAME, NROWS, MATIN_SDIA, NTERMS, I_MATIN, J_MATIN, MATIN, ABAND, SUBR_NAME )

! Output ABAND, if requested

      IF ((DEB_PRT(1) > 0) .AND. (DEB_PRT(1) <= NDEBUG)) THEN
         IF ((DEBUG(DEB_PRT(1)) == 1) .OR. (DEBUG(DEB_PRT(1)) == 3)) THEN
            CALL WRITE_MATRIX_BY_ROWS ( 'LAPACK BAND FORM FOR MATRIX ' // MATIN_NAME(1:), ABAND, MATIN_SDIA+1, NROWS, F06 )
         ENDIF
      ENDIF

! Calc the infinity norm of the matrix using the LAPACK function DLANSB. K_INORM is needed later for estimates
! of errors in the solution. Use array S for workspace in the calculation.

      IF (CALC_COND_NUM == 'Y') THEN
         CALL OURTIM
         MODNAM = 'CALC INFINITY NORM OF MATRIX ' // MATIN_NAME(1:)
         WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
   !xx   WRITE(SC1, * )
         K_INORM = DLANSB ( INORM, UPLO, NROWS, MATIN_SDIA, ABAND, MATIN_SDIA+1, LAPACK_S )
         WRITE(F06,3005) MATIN_NAME, K_INORM
      ENDIF

! Get max & min diagonals from the original matrix. Code assumes all diag terms positive

      IF (MATIN_DIAG_RAT == 'Y') THEN
         CALL OURTIM
         MODNAM = 'GET MAX/MIN DIAGONALS OF MATRIX ' // MATIN_NAME(1:)
         WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC

         MAXKII = ZERO
         IIMAX  = 0
         DO I=1,NROWS
            IF (ABAND(MATIN_SDIA+1,I) > MAXKII) THEN
               MAXKII = ABAND(MATIN_SDIA+1,I)
               IIMAX  = I
            ENDIF
         ENDDO
         WRITE(F06,3006) MATIN_NAME, MAXKII,IIMAX

         MINKII = MAXKII
         IIMIN  = IIMAX
         DO I=1,NROWS
            IF (ABAND(MATIN_SDIA+1,I) < MINKII) THEN
               MINKII = ABAND(MATIN_SDIA+1,I)
               IIMIN  = I
            ENDIF
         ENDDO
         WRITE(F06,3007) MATIN_NAME, MINKII,IIMIN

         IF (DABS(MINKII) > EPS1) THEN
            KRATIO = MAXKII/MINKII
            WRITE(F06,3008) MATIN_NAME, KRATIO
         ENDIF
      ENDIF

      EQUED = 'N'
! Equilibrate matrix, if user requested it via input arg EQUIL_MATIN
! TEMPORARILY REMOVE THIS CODE. IT WAS CAUSING ERRORS - FAILURES DUE TO RATIO OF MATRIX DIAG TO FACTOR DIAG WHEN EQUILIBRATED
!     IF (EQUIL_MATIN == 'Y') THEN
!        CALL OURTIM
!        MODNAM = 'EQUILIBRATING (IF NEEDED) MATRIX ' // MATIN_NAME(1:)
!        WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
!        CALL EQUILIBRATE( MATIN_NAME, MATIN_SET, NROWS, MATIN_SDIA, ABAND, LAPACK_S, EQUED, SCOND )
!     ENDIF

! Set equilibrate scale factors to return to calling subr. We do this since we need to deallocate LAPACK_S here since this
! subr (SYM_MAT_DECOMP_LAPACK) is called other times in MYSTRAN.

      DO I=1,NROWS
         EQUIL_SCALE_FACS(I) = LAPACK_S(I)
      ENDDO

! Deallocate LAPACK_S

      CALL DEALLOCATE_LAPACK_MAT ( 'LAPACK_S' )

! Get max & min diagonals from the equilibrated matrix. Code assumes all diag terms positive

      IF ((EQUED == 'Y') .AND. (MATIN_DIAG_RAT == 'Y')) THEN
         CALL OURTIM
         MODNAM = 'GET MAX/MIN DIAGONALS OF EQUILIBRATED MATRIX' // MATIN_NAME(1:)
         WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC

         MAXKII = ZERO
         IIMAX  = 0
         DO I=1,NROWS
            IF (ABAND(MATIN_SDIA+1,I) > MAXKII) THEN
               MAXKII = ABAND(MATIN_SDIA+1,I)
               IIMAX  = I
            ENDIF
         ENDDO
         WRITE(F06,3009) MATIN_NAME, MAXKII,IIMAX

         MINKII = MAXKII
         IIMIN  = 0
         DO I=1,NROWS
            IF (ABAND(MATIN_SDIA+1,I) < MINKII) THEN
               MINKII = ABAND(MATIN_SDIA+1,I)
               IIMIN  = I
            ENDIF
         ENDDO
         WRITE(F06,3010) MATIN_NAME, MINKII,IIMIN

         IF (DABS(MINKII) > EPS1) THEN
            KRATIO = MAXKII/MINKII
            WRITE(F06,3011) MATIN_NAME, KRATIO
         ENDIF

         IF ((DEB_PRT(1) > 0) .AND. (DEB_PRT(1) <= NDEBUG)) THEN
            IF ((DEBUG(DEB_PRT(1)) == 2) .OR. (DEBUG(DEB_PRT(1)) == 3)) THEN
               CALL WRITE_MATRIX_BY_ROWS ('LAPACK BAND FORM FOR EQUILIBRATED MATRIX' // MATIN_NAME(1:), ABAND, MATIN_SDIA+1,       &
                                           NROWS, F06)
            ENDIF
         ENDIF

      ENDIF

! Perform factorization of matrix. ABAND is the original matrix going into the decomp routine and is the upper triangular factor on
! exit.

      CALL OURTIM
      MODNAM = 'LAPACK TRIANGULAR FACTORIZATION OF MATRIX ' // MATIN_NAME(1:)
      WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
      CALL DPBTRF ( UPLO, NROWS, MATIN_SDIA, ABAND, MATIN_SDIA+1, INFO )

      CALLED_SUBR = 'DPBTRF'
      IF (INFO == 0) THEN

         FACTORED_MATRIX(1:) = ' '
         FACTORED_MATRIX     = MATIN_NAME

      ELSE IF (INFO < 0) THEN                              ! LAPACK subr XERBLA should have reported error on an illegal argument
!                                                            in calling a LAPACK subr, so we should not have gotten here
         WRITE(ERR,993) SUBR_NAME, CALLED_SUBR, CALLING_SUBR
         WRITE(F06,993) SUBR_NAME, CALLED_SUBR, CALLING_SUBR
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )                            ! Coding error, so quit

      ELSE IF (INFO > 0) THEN                              ! Leading minor of MATIN not positive definite

         CALL GET_GRID_AND_COMP ( MATIN_SET, INFO, GRIDV, COMPV  )

         IF (PRT_ERRS /= 'N') THEN
            WRITE(ERR,981) MATIN_NAME, CALLED_SUBR, INFO
            WRITE(F06,981) MATIN_NAME, CALLED_SUBR, INFO
            IF ((GRIDV > 0) .AND. (COMPV > 0)) THEN
               WRITE(ERR,9811) GRIDV, COMPV, CALLING_SUBR
               WRITE(F06,9811) GRIDV, COMPV, CALLING_SUBR
            ELSE
               WRITE(ERR,9812) INFO, CALLING_SUBR
               WRITE(F06,9812) INFO, CALLING_SUBR
            ENDIF
         ENDIF

      ENDIF

! Output ABAND (factor of MATIN now), if requested

      IF ((DEB_PRT(2) > 0) .AND. (DEB_PRT(2) <= NDEBUG)) THEN
         IF (DEBUG(DEB_PRT(2)) == 1) THEN
            CALL WRITE_MATRIX_BY_ROWS('TRIANGULAR FACTOR IN LAPACK BAND FORM FOR MATRIX ' // MATIN_NAME(1:), ABAND, MATIN_SDIA+1,  &
                                       NROWS, F06)
         ENDIF
      ENDIF

! Calculate and print ratios of diag to factor diag (if they are zero or negative or > MAXRATIO).

      CALL OURTIM
      MODNAM = 'CALC MAX RATIO OF MATRIX DIAGONAL TO FACTOR DIAGONAL'
      WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC

      DO I=1,NROWS                                         ! First, get diagonal terms from MATIN
         WRITE(SC1,12345,ADVANCE='NO') I, NROWS, CR13
         IF (I_MATIN(I) == I_MATIN(I+1)) THEN
            MATIN_DIAG(I) = ZERO
         ELSE
            MATIN_DIAG(I) = MATIN(I_MATIN(I))
         ENDIF
      ENDDO
      WRITE(SC1,*) CR13

      MAXIMAX_RATIO = -MACH_LARGE_NUM                                  ! Calc ratio of MATIN diag to factor diag
      NONPOS_DEF    = 'N'
      DO I=1,NROWS

         CALL GET_GRID_AND_COMP ( MATIN_SET, I, GRIDV, COMPV  )

         WRITE(SC1,22345,ADVANCE='NO') I, NROWS, CR13
         FAC_DIAG = ABAND(MATIN_SDIA+1,I)

         IF (FAC_DIAG <= EPS1) THEN                        ! Zero or negative factor diagonal. (MATIN is nonpositive definite)

            NONPOS_DEF = 'Y'
            IF (PRT_ERRS /= 'N') THEN
               WRITE(ERR,982) MATIN_NAME, FAC_DIAG
               WRITE(F06,982) MATIN_NAME, FAC_DIAG
               IF ((GRIDV > 0) .AND. (COMPV > 0)) THEN
                  WRITE(ERR,9811) GRIDV, COMPV, CALLING_SUBR
                  WRITE(F06,9811) GRIDV, COMPV, CALLING_SUBR
               ELSE
                  WRITE(ERR,9812) I, CALLING_SUBR
                  WRITE(F06,9812) I, CALLING_SUBR
               ENDIF
            ENDIF

         ELSE

            RATIO = MATIN_DIAG(I)/FAC_DIAG
!                                                          Ratio is greater than param MAXRATIO
            IF ((DABS(RATIO) > MAXRATIO) .AND. (PRT_ERRS /= 'N')) THEN
               WRITE(ERR,983) MATIN_NAME, RATIO, MAXRATIO
               WRITE(F06,983) MATIN_NAME, RATIO, MAXRATIO
               IF ((GRIDV > 0) .AND. (COMPV > 0)) THEN
                  WRITE(ERR,9811) GRIDV, COMPV, CALLING_SUBR
                  WRITE(F06,9811) GRIDV, COMPV, CALLING_SUBR
               ELSE
                  WRITE(ERR,9811) I, CALLING_SUBR
                  WRITE(F06,9811) I, CALLING_SUBR
               ENDIF
            ENDIF

            IF (RATIO > MAXIMAX_RATIO) THEN                ! This is the largest of the ratios
               MAXIMAX_RATIO = MATIN_DIAG(I)/ABAND(MATIN_SDIA+1,I)
               IIMAX = I
            ENDIF

         ENDIF

      ENDDO
      WRITE(SC1,*) CR13

      IF (NONPOS_DEF == 'N') THEN

         WRITE(ERR,984) MATIN_NAME, MAXIMAX_RATIO
         WRITE(F06,984) MATIN_NAME, MAXIMAX_RATIO
         CALL GET_GRID_AND_COMP ( MATIN_SET, IIMAX, GRIDV, COMPV  )
         IF ((GRIDV > 0) .AND. (COMPV > 0)) THEN
            WRITE(ERR,9811) GRIDV, COMPV, CALLING_SUBR
            WRITE(F06,9811) GRIDV, COMPV, CALLING_SUBR
         ELSE
            WRITE(ERR,9812) IIMAX, CALLING_SUBR
            WRITE(F06,9812) IIMAX, CALLING_SUBR
         ENDIF

      ENDIF

      IF ((DABS(MAXIMAX_RATIO) > MAXRATIO) .OR. (NONPOS_DEF == 'Y') .OR. (INFO > 0)) THEN
                                                           ! If BAILOUT >= 0 then quit. Otherwise, continue processing.
         IF ((BAILOUT >= 0) .AND. (QUIT_ON_POS_INFO == 'Y')) THEN
            FATAL_ERR = FATAL_ERR + 1
            WRITE(ERR,99999) BAILOUT
            WRITE(F06,99999) BAILOUT
            CALL OUTA_HERE ( 'Y' )
         ENDIF

      ENDIF

! If CALC_COND_NUM = 'Y', then calc the reciprocal of the condition number of the matrix. This is done in
! subr COND_NUM using LAPACK subroutine DPBCON and is used for a better estimate of solution errors later.

      RCOND = ZERO
      IF (CALC_COND_NUM == 'Y') THEN
         CALL OURTIM
         MODNAM = 'CALC RECIP OF COND NUM OF MATRIX ' // MATIN_NAME(1:)
         WRITE(SC1,3092) LINKNO,MODNAM,HOUR,MINUTE,SEC,SFRAC
         CALL COND_NUM ( MATIN_NAME, NROWS, MATIN_SDIA, K_INORM, ABAND, RCOND )
      ENDIF

!***********************************************************************************************************************************
  981 FORMAT(' *ERROR   981: THE FACTORIZATION OF THE MATRIX ',A,' COULD NOT BE COMPLETED BY LAPACK SUBR ',A                       &
                    ,/,14X,' THE LEADING MINOR OF ORDER ',I12,' IS NOT POSITIVE DEFINITE')

  982 FORMAT(' *ERROR   982: MATRIX ',A,' IS NONPOSITIVE DEFINITE. A DIAGONAL TERM IS ZERO OR NEGATIVE = ',1ES14.6)

  983 FORMAT(' *ERROR   983: MATRIX ',A,' HAS AN ABSOLUTE VALUE OF THE RATIO OF MATRIX DIAG TO FACTOR DIAG = ',1ES10.2,            &
                           ' (GREATER THAN BULK DATA PARAM MAXRATIO = ',1ES10.2,')'                                                &
                    ,/,14X,' THIS WILL ONLY BE A FATAL ERROR IF PARAM BAILOUT > 0')

  984 FORMAT(' *INFORMATION: THE MAXIMUM ABSOLUTE VALUE OF THE RATIO OF MATRIX DIAGONAL TO FACTOR DIAG FOR MATRIX ',A,' = ',1ES14.6)

 9811 FORMAT('               THIS IS FOR ROW AND COL IN THE MATRIX FOR GRID POINT ',I8,' COMP ',I3,'. THE CALLING SUBR WAS: ',A,/)

 9812 FORMAT('               THIS IS FOR ROW AND COL ',I8,' IN THE MATRIX. THE CALLING SUBR WAS: ',A,/)

  993 FORMAT(' *ERROR   993: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' LAPACK SUBR XERBLA SHOULD HAVE REPORTED AN ERROR ON AN ILLEGAL ARGUMENT IN A CALL TO LAPACK SUBR: '   &
                    ,/,15X,A,/,' (OR A SUBR CALLED BY IT) AND THEN ABORTED. THE CALLING SUBR WAS: ',A)

 3002 FORMAT(' *INFORMATION: BANDWIDTH OF MATRIX ',A11,'                                        = ',I13,' (BW)',/)

 3003 FORMAT(' *INFORMATION: MEMORY REQUIRED FOR TRIANGULAR DECOMPOSITION OF MATRIX   ',A11,'   = ',F13.6,' MB ',                  &
                           '(8*NDOF*BW)',/,14X,' (using LAPACK band matrix algorithm)',/)

 3004 FORMAT(' *INFORMATION: MEMORY REQUIRED FOR TRIANGULAR DECOMPOSITION OF MATRIX   ',A11,'   = ',F13.3,' MB ',                  &
                           '(8*NDOF*BW)',/,14X,' (using LAPACK band matrix algorithm)',/)

 3005 FORMAT(' *INFORMATION: INFINITY NORM OF MATRIX ',A11,'                                    = ',1ES13.6,/)

 3006 FORMAT(' *INFORMATION: MAXIMUM DIAGONAL TERM IN MATRIX ',A11,'                            = ',1ES13.6,                       &
                           ' Occurs in row/col no. ',I8)

 3007 FORMAT(' *INFORMATION: MINIMUM DIAGONAL TERM IN MATRIX ',A11,'                            = ',1ES13.6,                       &
                           ' Occurs in row/col no. ',I8)

 3008 FORMAT(' *INFORMATION: RATIO OF MAX TO MIN DIAGONALS IN MATRIX ',A11,'                    = ',1ES13.6,/)

 3009 FORMAT(' *INFORMATION: MAXIMUM DIAGONAL TERM IN THE EQUILIBRATED MATRIX ',A11,'           = ',1ES13.6,                       &
                           ' Occurs in row/col no. ',I8)

 3010 FORMAT(' *INFORMATION: MINIMUM DIAGONAL TERM IN THE EQUILIBRATED MATRIX ',A11,'           = ',1ES13.6,                       &
                           ' Occurs in row/col no. ',I8)

 3011 FORMAT(' *INFORMATION: RATIO OF MAX TO MIN DIAGONALS IN THE EQUILIBRATED MATRIX ',A11,'   = ',1ES13.6,/)

 3092 FORMAT(1X,I2,'/',A54,8X,2X,I2,':',I2,':',I2,'.',I3)

 3094 FORMAT(5X,' Bandwidth of ',A,'  = ',I8,' and requires ',F10.3,' MB of memory')

12345 FORMAT(5X,'Getting diagonal of matrix, row ',I8,' of ',I8,A)

22345 FORMAT(5X,'Calc ratios of matrix diag to factor diag: row ',I8,' of ',I8,A)

99999 FORMAT(/,' PROCESSING TERMINATED DUE TO ABOVE MESSAGES AND BULK DATA PARAMETER BAILOUT = ',I7)

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

!***********************************************************************************************************************************

      END SUBROUTINE SYM_MAT_DECOMP_LAPACK


MODULE FUN_xyPERPCW
!!#### PURPOSE
!! Construct a perpendicular vector by 90 degrees
!! Clockwise (CW) rotation.

!!#### METHOD
!! use "PERP" function with fix-up for x=0 and y>0.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0      !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0      !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyPERPCCW,ONLY: xyPERPCCW_U,xyPERPCCW_V !!((03-A-FUN_xyPERPCCW.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyPERPCW_V
 MODULE PROCEDURE xyPERPCW_V_Rsp
 MODULE PROCEDURE xyPERPCW_V_Rdp
END INTERFACE

INTERFACE xyPERPCW_U
 MODULE PROCEDURE xyPERPCW_U_Rsp
 MODULE PROCEDURE xyPERPCW_U_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyPERPCW_V
PUBLIC :: xyPERPCW_U

CONTAINS

PURE FUNCTION xyPERPCW_V_Rsp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "04-A-FUN_xyPERPCW_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_V_Rdp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "04-A-FUN_xyPERPCW_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_U_Rsp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "04-A-FUN_xyPERPCW_U.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_U.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPERPCW_U_Rdp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp   !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "04-A-FUN_xyPERPCW_U.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyPERPCW_U.f90.bdy"
!!--end--
END FUNCTION

END MODULE


program main
      implicit none
      integer i
      logical m3, m5
      do i=1,100
        m3 = mod(i, 3) == 0
        m5 = mod(i, 5) == 0
        if (m3 .and. m5) then
          print "(a8)", "FizzBuzz"
        else if (m3) then
          print "(a4)", "Fizz"
        else if (m5) then
          print "(a4)", "Buzz"
        else if (i<10) then
          print '(i1)', i
        else
          print '(i2)', i
        end if
      end do
end program


c     Dr. Wolfe's wonderful Choleksy Decomposition program
      subroutine chol(a,n)
      real a(n,n)
      do 10 k = 1,n
         a(k,k) = sqrt(a(k,k))
         do 20 i = k+1,n
            a(i,k) = a(i,k) / a(k,k)
            do 30 j = k+1,i
               a(i,j) = a(i,j) - a(i,k)*a(j,k)
 30         continue
 20      continue
 10   continue
      end


!!
! basic sorting example
! includes random integer generation
! includes elapsed time of the sorting algorithm
! includes sorting algorithms: bubble, selection, insertion, quick
! executes the sorting algorithms in order and prints out time taken for the sorting in ms
!!
program sorting
    implicit none

    ! constants
    integer :: max_number = 1000

    ! declaring variables
    integer :: sorting_array(100000)
    !integer :: i
    integer :: start(8)
    real :: time_used

    ! fill with pseudo random numbers of type integer (otherwise random_number is better)
    call fill_random(size(sorting_array), max_number, sorting_array)
    ! save time before sorting
    call date_and_time(values=start)

    ! execute bubble sort
    call bubble_sort(size(sorting_array), sorting_array)
    ! update the time
    call elapsed_time(time_used, start)
    print *, 'bubble sort: ', time_used

    ! randomize again
    call fill_random(size(sorting_array), max_number, sorting_array)
    call date_and_time(values=start)

    ! execute selection sort
    call selection_sort(size(sorting_array), sorting_array)
    ! update the time
    call elapsed_time(time_used, start)
    print *, 'selection sort: ', time_used

    ! randomize again
    call fill_random(size(sorting_array), max_number, sorting_array)
    call date_and_time(values=start)

    ! execute insertion sort
    call insertion_sort(size(sorting_array), sorting_array)
    ! update the time
    call elapsed_time(time_used, start)
    print *, 'insertion sort: ', time_used

    ! randomize again
    call fill_random(size(sorting_array), max_number, sorting_array)
    call date_and_time(values=start)

    ! execute quick sort
    call quick_sort(size(sorting_array), sorting_array, 0, size(sorting_array))
    ! update the time
    call elapsed_time(time_used, start)
    print *, 'quick sort: ', time_used
end program

! Subroutine to fill an integer array with random numbers
! msize     : integer, input, size of the array - this many random integers will be put into the array
! mnumber   : integer, input, maximum number - this is the maximum number a "random" number can have
! array     : integer array, input / output, array to fill with numbers
!!
subroutine fill_random(msize, mnumber, array)
    implicit none
    ! variables
    integer, intent(in) :: msize
    integer, intent(in) :: mnumber
    integer, intent(out) :: array(msize)
    integer :: i

    ! iterate through the array and fill with random integers capped at mnumber
    do i = 1, msize
        array(i) = modulo(irand(), mnumber+1)
    end do
end subroutine fill_random

! Subroutine to calculate elapsed time between two calls of date_and_time()
! time_seconds  : variable for output, time in milliseconds
! start         : integer(8) - input array from a previous date_and_time()-call
!!
subroutine elapsed_time(time_mseconds, start)
    implicit none
    ! variables
    integer :: now(8), difference(8)
    integer, intent(in) :: start(8)
    real, intent(out) :: time_mseconds

    ! get current date and  time
    call date_and_time(values=now)

    ! calculate the difference in seconds
    difference = now - start
    ! 6 = minutes, 7 = seconds, 8 = milliseconds
    time_mseconds = difference(6) * 60000 + difference(7) * 1000 + difference(8)
end subroutine elapsed_time

! Bubble Sort implementation
! msize     : integer, input, size of the array
! array     : integer(msize), input / output
!!
subroutine bubble_sort(msize, array)
    implicit none
    ! variables
    integer, intent(in) :: msize
    integer, intent(inout) :: array(msize)
    logical :: swap
    integer :: i
    integer :: temp

    ! logical is initialized as F by default, set to T
    swap = .true.

    ! sorting loop
    do
        ! if we didnt swap, we exit
        if(swap .eqv. .false.) exit

        ! set swap to false
        swap = .false.

        ! iterate the array and swap if required
        do i = 1, msize
            if(array(i) > array(i + 1)) then
                temp = array(i)
                array(i) = array(i + 1)
                array(i + 1) = temp
                ! if we swapped, set the variable to true
                swap = .true.
            end if
        end do
    end do
end subroutine bubble_sort

! Selection Sort implementation
! msize     : integer, input, size of the array
! array     : integer(msize), input / output
!!
subroutine selection_sort(msize, array)
    implicit none
    ! variables
    integer, intent(in) :: msize
    integer, intent(inout) :: array(msize)
    integer :: lowest_index, i, j, temp

    ! iterate the array
    do i = 1, msize
        ! assume the first element is the lowest element
        lowest_index = i
        ! iterate the unsorted items
        do j = i + 1, msize
            if (array(j) < array(lowest_index)) then
                lowest_index = j
            end if
        end do
        ! swap values
        temp = array(i)
        array(i) = array(lowest_index)
        array(lowest_index) = temp
    end do
end subroutine selection_sort

! Insertion Sort implementation
! msize     : integer, input, size of the array
! array     : integer(msize), input / output
!!
subroutine insertion_sort(msize, array)
    implicit none
    ! variables
    integer, intent(in) :: msize
    integer, intent(inout) :: array(msize)
    integer :: prev_index, i, insert

    do i = 1, msize
        ! current item to insert
        insert = array(i)
        ! previous index
        prev_index = i - 1
        ! if the item is larger, move everything forward
        do while ((prev_index > 0) .and. (array(prev_index) > insert))
            array(prev_index + 1) = array(prev_index)
            prev_index = prev_index - 1
        end do
        ! insert the item
        array(prev_index + 1) = insert
    end do
end subroutine insertion_sort

! Quick Sort algorithm
! implementation inspired by https://gist.github.com/t-nissie/479f0f16966925fa29ea
! (and greatly improved because of that - thanks!)
! msize     : integer, input, size of the array
! array     : integer(msize), input / output
! first     : integer, input - first element of the array (1 for the first call)
! last      : integer, input - last element of the array (size(array) for the first call)
!!
recursive subroutine quick_sort(msize, array, first, last)
    implicit none
    ! variables
    integer, intent(inout) :: array(msize)
    integer, intent(in) :: first, last, msize
    integer :: pivot, temp, i, j

    ! save first, last values
    i = first
    j = last

    ! calculate the pivot
    pivot = array( (i + j) / 2)

    do
        do while (array(i) < pivot)
            i = i + 1
        end do

        do while (array(j) > pivot)
            j = j - 1
        end do

        if(i >= j) exit

        ! swap the items
        temp = array(i)
        array(i) = array(j)
        array(j) = temp

        ! increment / decrement
        i = i + 1
        j = j - 1
    end do

    ! recursive calls
    if(first < i - 1) call quick_sort(msize, array, first, i - 1)
    if(j + 1 < last) call quick_sort(msize, array, j + 1, last)

end subroutine quick_sort


module divergence_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use spherepack_interfaces, only: &
        scalar_synthesis, &
        vector_synthesis

    use scalar_synthesis_routines, only: &
        ScalarSynthesisUtility, &
        shsec, shses, shsgc, shsgs

    use vector_synthesis_routines, only: &
        VectorSynthesisUtility, &
        vhses, vhsec, vhsgc, vhsgs

    use type_ScalarHarmonic, only: &
        ScalarHarmonic

    use type_VectorHarmonic, only: &
        VectorHarmonic

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: divec, dives, divgc, divgs
    public :: idivec, idives, idivgc, idivgs
    public :: divergence_lower_utility_routine
    public :: invert_divergence_lower_utility_routine

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: SQRT2 = sqrt(TWO)

    ! Declare interfaces for submodule implementation
    interface
        module subroutine divgs(nlat, nlon, isym, nt, divg, idiv, jdiv, br, bi, mdb, ndb, &
            wshsgs, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: divg(idiv, jdiv, nt)
            integer(ip), intent(in)  :: idiv
            integer(ip), intent(in)  :: jdiv
            real(wp),    intent(in)  :: br(mdb, ndb, nt)
            real(wp),    intent(in)  :: bi(mdb, ndb, nt)
            integer(ip), intent(in)  :: mdb
            integer(ip), intent(in)  :: ndb
            real(wp),    intent(in)  :: wshsgs(:)
            integer(ip), intent(out) :: ierror
        end subroutine divgs

        module subroutine divgc(nlat, nlon, isym, nt, dv, idv, jdv, br, bi, mdb, ndb, &
            wshsgc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: dv(idv, jdv, nt)
            integer(ip), intent(in)  :: idv
            integer(ip), intent(in)  :: jdv
            real(wp),    intent(in)  :: br(mdb, ndb, nt)
            real(wp),    intent(in)  :: bi(mdb, ndb, nt)
            integer(ip), intent(in)  :: mdb
            integer(ip), intent(in)  :: ndb
            real(wp),    intent(in)  :: wshsgc(:)
            integer(ip), intent(out) :: ierror
        end subroutine divgc

        module subroutine dives(nlat, nlon, isym, nt, dv, idv, jdv, br, bi, mdb, ndb, &
            wshses, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: dv(idv, jdv, nt)
            integer(ip), intent(in)  :: idv
            integer(ip), intent(in)  :: jdv
            real(wp),    intent(in)  :: br(mdb, ndb, nt)
            real(wp),    intent(in)  :: bi(mdb, ndb, nt)
            integer(ip), intent(in)  :: mdb
            integer(ip), intent(in)  :: ndb
            real(wp),    intent(in)  :: wshses(:)
            integer(ip), intent(out) :: ierror
        end subroutine dives

        module subroutine divec(nlat, nlon, isym, nt, dv, idv, jdv, br, bi, mdb, ndb, &
            wshsec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: dv(idv, jdv, nt)
            integer(ip), intent(in)  :: idv
            integer(ip), intent(in)  :: jdv
            real(wp),    intent(in)  :: br(mdb, ndb, nt)
            real(wp),    intent(in)  :: bi(mdb, ndb, nt)
            integer(ip), intent(in)  :: mdb
            integer(ip), intent(in)  :: ndb
            real(wp),    intent(in)  :: wshsec(:)
            integer(ip), intent(out) :: ierror
        end subroutine divec

        module subroutine idivec(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsec, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsec(:)
            real(wp),    intent(out) :: pertrb(nt)
            integer(ip), intent(out) :: ierror
        end subroutine idivec

        module subroutine idives(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhses, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhses(:)
            real(wp),    intent(out) :: pertrb(nt)
            integer(ip), intent(out) :: ierror
        end subroutine idives

        module subroutine idivgc(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsgc, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsgc(:)
            real(wp),    intent(out) :: pertrb(nt)
            integer(ip), intent(out) :: ierror
        end subroutine idivgc

        module subroutine idivgs(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsgs, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsgs(:)
            real(wp),    intent(out) :: pertrb(nt)
            integer(ip), intent(out) :: ierror
        end subroutine idivgs
    end interface

contains

    pure subroutine compute_coefficient_multipliers(sqnn)

        ! Dummy arguments
        real(wp), intent(out) :: sqnn(:)

        ! Local variables
        integer(ip) :: n

        sqnn = [(sqrt(real(n - 1, kind=wp) * (real(n - 1, kind=wp) + ONE)), n=1, size(sqnn))]

    end subroutine compute_coefficient_multipliers

    pure function get_perturbation(a, k) &
        result(return_value)

        ! Dummy arguments
        real(wp),    intent(in) :: a(:, :, :)
        integer(ip), intent(in) :: k
        real(wp)                :: return_value

        return_value = a(1, 1, k)/(TWO * SQRT2)

    end function get_perturbation

    pure subroutine perform_setup_for_divergence(nlon, a, b, br, bi, sqnn)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: a(:, :, :)
        real(wp),    intent(out) :: b(:, :, :)
        real(wp),    intent(in)  :: br(:, :, :)
        real(wp),    intent(in)  :: bi(:, :, :)
        real(wp),    intent(out) :: sqnn(:)

        ! Local variables
        integer(ip) :: k, n, m, mmax

        associate (&
            nlat => size(sqnn), &
            nt => size(a, dim=3) &
            )

            ! Set coefficient multiplyers
            call compute_coefficient_multipliers(sqnn)

            ! Compute divergence scalar coefficients for each vector field
            do k=1, nt
                a(:, :, k) = ZERO
                b(:, :, k) = ZERO

                ! Compute m=0 coefficients
                do n=2, nlat
                    a(1, n, k) = -sqnn(n)*br(1, n, k)
                    b(1, n, k) = -sqnn(n)*bi(1, n, k)
                end do

                ! Compute m > 0 coefficients using vector spherepack value for mmax
                mmax = min(nlat, (nlon + 1)/2)
                do m=2, mmax
                    do n=m, nlat
                        a(m, n, k) = -sqnn(n)*br(m, n, k)
                        b(m, n, k) = -sqnn(n)*bi(m, n, k)
                    end do
                end do
            end do
        end associate

    end subroutine perform_setup_for_divergence

    pure subroutine perform_setup_for_inversion(isym, ityp, a, b, sqnn, pertrb, br, bi)

        ! Dummy arguments
        integer(ip), intent(in)  :: isym
        integer(ip), intent(out) :: ityp
        real(wp),    intent(in)  :: a(:, :, :)
        real(wp),    intent(in)  :: b(:, :, :)
        real(wp),    intent(out) :: sqnn(:)
        real(wp),    intent(out) :: pertrb(:)
        real(wp),    intent(out) :: br(:, :, :)
        real(wp),    intent(out) :: bi(:, :, :)

        ! Local variables
        integer(ip) :: k, n, m

        associate (&
            mmax => size(br, dim=1), &
            nlat => size(br, dim=2), &
            nt => size(br, dim=3) &
            )

            ! Preset coefficient multiplyers in vector
            call compute_coefficient_multipliers(sqnn)

            ! Preset br, bi to 0.0
            br = ZERO
            bi = ZERO

            ! Compute multiple vector fields coefficients
            do k=1, nt

                ! Set divergence field perturbation adjustment
                pertrb(k) = get_perturbation(a, k)

                ! Compute m=0 coefficients
                do n=2, nlat
                    br(1, n, k) = -a(1, n, k)/sqnn(n)
                    bi(1, n, k) = -b(1, n, k)/sqnn(n)
                end do

                ! Compute m > 0 coefficients
                do m=2, mmax
                    do n=m, nlat
                        br(m, n, k) = -a(m, n, k)/sqnn(n)
                        bi(m, n, k) = -b(m, n, k)/sqnn(n)
                    end do
                end do
            end do

            ! Set ityp for vector synthesis with curl=0
            select case (isym)
                case (0)
                    ityp = 1
                case (1)
                    ityp = 4
                case (2)
                    ityp = 7
            end select
        end associate

    end subroutine perform_setup_for_inversion

    subroutine divergence_lower_utility_routine(nlat, nlon, isym, nt, dv, &
        idv, jdv, br, bi, wavetable, synth_routine, error_flag)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: nlon
        integer(ip), intent(in)     :: isym
        integer(ip), intent(in)     :: nt
        real(wp),    intent(out)    :: dv(idv, jdv, nt)
        integer(ip), intent(in)     :: idv
        integer(ip), intent(in)     :: jdv
        real(wp),    intent(in)     :: br(:,:,:)
        real(wp),    intent(in)     :: bi(:,:,:)
        real(wp),    intent(in)     :: wavetable(:)
        procedure(scalar_synthesis) :: synth_routine
        integer(ip), intent(out)    :: error_flag

        block
            real(wp)             :: sqnn(nlat)
            type(ScalarHarmonic) :: harmonic

            ! Allocate memory
            harmonic = ScalarHarmonic(nlat, nlon, nt)

            associate( &
                a => harmonic%real_component, &
                b => harmonic%imaginary_component, &
                mab => harmonic%ORDER_M &
                )

                call perform_setup_for_divergence(nlon, a, b, br, bi, sqnn)

                ! Synthesize a, b into divg
                call synth_routine(nlat, nlon, isym, nt, dv, idv, jdv, a, b, &
                    mab, nlat, wavetable, error_flag)
            end associate

            ! Release memory
            call harmonic%destroy()
        end block

    end subroutine divergence_lower_utility_routine

    subroutine invert_divergence_lower_utility_routine(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, &
        wavetable, pertrb, synth_routine, error_flag)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: nlon
        integer(ip), intent(in)     :: isym
        integer(ip), intent(in)     :: nt
        real(wp),    intent(out)    :: v(idvw, jdvw, nt)
        real(wp),    intent(out)    :: w(idvw, jdvw, nt)
        integer(ip), intent(in)     :: idvw
        integer(ip), intent(in)     :: jdvw
        real(wp),    intent(in)     :: a(:,:,:)
        real(wp),    intent(in)     :: b(:,:,:)
        real(wp),    intent(in)     :: wavetable(:)
        real(wp),    intent(out)    :: pertrb(:)
        procedure(vector_synthesis) :: synth_routine
        integer(ip), intent(out)    :: error_flag

        block
            integer(ip)          :: ityp
            real(wp)             :: sqnn(nlat)
            type(VectorHarmonic) :: harmonic

            ! Allocate memory
            harmonic = VectorHarmonic(nlat, nlon, nt)

            associate( &
                br => harmonic%polar%real_component, &
                bi => harmonic%polar%imaginary_component, &
                cr => harmonic%azimuthal%real_component, &
                ci => harmonic%azimuthal%imaginary_component, &
                mdab => harmonic%ORDER_M, &
                ndab => harmonic%DEGREE_N &
                )

                call perform_setup_for_inversion(isym, ityp, a, b, sqnn, pertrb, br, bi)

                ! Vector synthesize br, bi into irrotational (v, w)
                call synth_routine(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
                    mdab, ndab, wavetable, error_flag)

                ! Release memory
                call harmonic%destroy()
            end associate
        end block

    end subroutine invert_divergence_lower_utility_routine

end module divergence_routines


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   pp3 :    A continuous dynamical system with period doubling
!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

  F(1)= U(1)*(1-U(1)) - PAR(4)*U(1)*U(2)
  F(2)=-PAR(2)*U(2)   + PAR(4)*U(1)*U(2) - PAR(5)*U(2)*U(3) &
       - PAR(1)*(1-EXP(-PAR(6)*U(2)))
  F(3)=-PAR(3)*U(3)   + PAR(5)*U(2)*U(3)

END SUBROUTINE FUNC
!----------------------------------------------------------------------

SUBROUTINE STPNT(NDIM,U,PAR,T)
!--------- -----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: T

  U = (/ 1.0, 0.0, 0.0 /)

  PAR(:6) = (/ 0.0, 0.25, 0.5, 4.0, 3.0, 5.0 /)

END SUBROUTINE STPNT
!----------------------------------------------------------------------

SUBROUTINE PVLS(NDIM,U,PAR)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
  DOUBLE PRECISION GETP

  DOUBLE PRECISION r1, r2, r3

! Set PAR(9) equal to the L2-norm of U
  r1=GETP('NRM',1,U)
  r2=GETP('NRM',2,U)
  r3=GETP('NRM',3,U)

  PAR(9)=SQRT(r1**2 + r2**2 + r3**2)

END SUBROUTINE PVLS

SUBROUTINE BCND
END SUBROUTINE BCND

SUBROUTINE ICND
END SUBROUTINE ICND

SUBROUTINE FOPT
END SUBROUTINE FOPT
!----------------------------------------------------------------------


use IOClass
use ArrayClass
implicit none

! K-net data analysis
type(IO_) :: f
character(:),allocatable :: file_path
character(:),allocatable :: Station_Name

real(real64),allocatable :: accel_wave(:,:),hz(:)
complex(complex64),allocatable :: wave(:),spectre(:)
integer(int32) :: frame = 1024*16
real(real64) :: min_hz,max_hz
real(real64) :: dt

Station_Name = "MYG016"

! Please chane this path
file_path = "../Data/Earthquake/20220316/Knet/20220316233600.knt/"+Station_Name+"2203162336.EW"

accel_wave = f%import(format=KNT_ASCII,name=file_path)

call f%open(Station_Name+".txt","w")
call f%write(accel_wave)
call f%close()
call f%plot(option="with lines")

! FFT
wave = accel_wave(:,2)
spectre = fft(wave(1:frame) )

dt = (accel_wave(frame,1) - accel_wave(1,1))/dble(frame)*2
max_hz = 1.0d0/dt
min_hz = 1.0d0/dt/dble(frame)
hz = linspace([min_hz,max_hz],frame/2)
print *, dt, max_hz,min_hz

call f%open(Station_Name+"_FFT.txt","w")
call f%write(hz(1:frame/2),abs(spectre(1:frame/2) ) )
call f%close()
call f%plot(option="with lines; set logscale; replot")

end


program shallow

!> @mainpage BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE
!! PREFORMANCE OF CURRENT SUPERCOMPUTERS. THE MODEL IS
!! BASED OF THE PAPER - THE DYNAMICS OF FINITE-DIFFERENCE
!! MODELS OF THE SHALLOW-WATER EQUATIONS, BY ROBERT SADOURNY
!! J. ATM. SCIENCES, VOL 32, NO 4, APRIL 1975.
!!
!! CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR
!! ATMOSPHERIC RESEARCH, BOULDER, CO,  OCTOBER 1984.
!! Modified by Juliana Rew, NCAR, January 2006
!
!     In this version, shallow4.f, initial and calculated values
!     of U, V, and P are written to a netCDF file
!     for later use in visualizing the results. The netCDF data
!     management library is freely available from
!     http://www.unidata.ucar.edu/software/netcdf
!     This code is still serial but has been brought up to modern
!     Fortran constructs and uses portable intrinsic Fortran 90 timing routines
!     This can be compiled on the IBM SP using:
!     xlf90 -qmaxmem=-1 -g -o shallow4 -qfixed=132 -qsclk=micro \
!     -I/usr/local/include shallow4.f -L/usr/local/lib32/r4i4 -l netcdf
!     where the -L and -I point to local installation of netCDF
!
!     Changes from shallow4.f (Annette Osprey, January 2010):
!     - Converted to free-form fortran 90.
!     - Some tidying up of old commented-out code.
!     - Explicit type declarations.
!     - Variables n, m, itmax and mprint read in from namelist.
!     - Dynamic array allocation.
!     - Only write to netcdf at mprint timesteps.
!     - Don't write wrap-around points to NetCDF file.
!     - Use 8-byte reals.
!
!     This version heavily modified as part of the GOcean-2D project
!     with the mantra "all computation must occur in a kernel."
!     Andrew Porter, April 2014

  use shallow_io_mod
  use dl_timer
  use gocean_mod, only: gocean_initialise, model_write_log, gocean_finalise
  use model_mod
  use grid_mod
  use field_mod
  use initial_conditions_mod
  use time_smooth_mod,  only: invoke_time_smooth
  use apply_bcs_mod,    only: invoke_apply_bcs
  use compute_cu_mod,   only: invoke_compute_cu
  use compute_cv_mod,   only: invoke_compute_cv
  use compute_z_mod,    only: invoke_compute_z
  use compute_h_mod,    only: invoke_compute_h
  use compute_unew_mod, only: invoke_compute_unew
  use compute_vnew_mod, only: invoke_compute_vnew
  use compute_pnew_mod, only: invoke_compute_pnew
  use time_step_mod,    only: invoke_time_step
  implicit none

  type(grid_type), target :: model_grid
  !> Pressure at {current,previous,next} time step
  type(r2d_field) :: p_fld, pold_fld, pnew_fld
  !> Velocity in x direction at {current,previous,next} time step
  type(r2d_field) :: u_fld, uold_fld, unew_fld
  !> Velocity in x direction at {current,previous,next} time step
  type(r2d_field) :: v_fld, vold_fld, vnew_fld
  !> Mass flux in x and y directions
  type(r2d_field) :: cu_fld, cv_fld
  !> Potential vorticity
  type(r2d_field) :: z_fld
  !> Surface height
  type(r2d_field) :: h_fld
  !> Stream function
  type(r2d_field) :: psi_fld

  !> Loop counter for time-stepping loop
  INTEGER :: ncycle

  !> Integer tags for timers
  INTEGER :: idxt0

  call gocean_initialise()

  ! Create the model grid
  model_grid = grid_type(GO_ARAKAWA_C,                           &
                         (/GO_BC_PERIODIC,GO_BC_PERIODIC,GO_BC_NONE/), &
                         GO_OFFSET_SW)

  !  ** Initialisations of model parameters (dt etc) **
  CALL model_init(model_grid)

  ! Create fields on this grid
  p_fld    = r2d_field(model_grid, GO_T_POINTS)
  pold_fld = r2d_field(model_grid, GO_T_POINTS)
  pnew_fld = r2d_field(model_grid, GO_T_POINTS)

  u_fld    = r2d_field(model_grid, GO_U_POINTS)
  uold_fld = r2d_field(model_grid, GO_U_POINTS)
  unew_fld = r2d_field(model_grid, GO_U_POINTS)

  v_fld    = r2d_field(model_grid, GO_V_POINTS)
  vold_fld = r2d_field(model_grid, GO_V_POINTS)
  vnew_fld = r2d_field(model_grid, GO_V_POINTS)

  cu_fld = r2d_field(model_grid, GO_U_POINTS)

  cv_fld = r2d_field(model_grid, GO_V_POINTS)

  z_fld = r2d_field(model_grid, GO_F_POINTS)

  h_fld = r2d_field(model_grid, GO_T_POINTS)

  psi_fld = r2d_field(model_grid, GO_F_POINTS)

  ! NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST
  ! CYCLE AFTER WHICH IT IS RESET TO DT+DT.
  tdt = dt

  !     INITIAL VALUES OF THE STREAM FUNCTION AND P

  call init_initial_condition_params(p_fld)
  call invoke_init_stream_fn_kernel(psi_fld)
  call init_pressure(p_fld)
  !CALL invoke_apply_bcs(psi_fld)
  !CALL invoke_apply_bcs(p_fld)

  !     INITIALIZE VELOCITIES

  call init_velocity_u(u_fld, psi_fld)
  call init_velocity_v(v_fld, psi_fld)

  !     PERIODIC CONTINUATION
  call invoke_apply_bcs(u_fld)
  call invoke_apply_bcs(v_fld)

  ! Generate and output checksums of initial fields
  CALL model_write_log("('psi initial CHECKSUM = ',E24.16)", &
                       field_checksum(psi_fld))
  CALL model_write_log("('P initial CHECKSUM = ',E24.16)", &
                         field_checksum(p_fld))
  CALL model_write_log("('U initial CHECKSUM = ',E24.16)",  &
                       field_checksum(u_fld))
  CALL model_write_log("('V initial CHECKSUM = ',E24.16)", &
                       field_checksum(v_fld))

  ! Initialise fields that will hold data at previous time step
  CALL copy_field(u_fld, uold_fld)
  CALL copy_field(v_fld, vold_fld)
  CALL copy_field(p_fld, pold_fld)

  ! Write intial values of p, u, and v into a netCDF file
  call ascii_write(0, 'psifld.dat', psi_fld%data,  &
                   psi_fld%internal%nx, psi_fld%internal%ny, &
                   psi_fld%internal%xstart, psi_fld%internal%ystart )
  call ascii_write(0,'zfld.dat'  ,z_fld%data, &
                   z_fld%internal%nx, z_fld%internal%ny, &
                   z_fld%internal%xstart, z_fld%internal%ystart)
  call ascii_write(0,'hfld.dat'  ,h_fld%data, &
                   h_fld%internal%nx, h_fld%internal%ny, &
                   h_fld%internal%xstart, h_fld%internal%ystart)
  CALL model_write(0, p_fld, u_fld, v_fld)

  !     Start timer
  CALL timer_start(idxt0, label='Time-stepping')

  !====================================
  ! Perform the first time step
  ncycle = 1
  CALL invoke_compute_cu(CU_fld, P_fld, U_fld)
  CALL invoke_compute_cv(CV_fld, P_fld, V_fld)
  CALL invoke_compute_z(z_fld, P_fld, U_fld, V_fld)
  CALL invoke_compute_h(h_fld, P_fld, U_fld, V_fld)

  CALL invoke_apply_bcs(cu_fld)
  CALL invoke_apply_bcs(cv_fld)
  CALL invoke_apply_bcs(h_fld)
  CALL invoke_apply_bcs(z_fld)

  CALL invoke_compute_unew(unew_fld, uold_fld,  z_fld, cv_fld, &
                           h_fld, tdt)
  CALL invoke_compute_vnew(vnew_fld, vold_fld,  z_fld, cu_fld, &
                           h_fld, tdt)
  CALL invoke_compute_pnew(pnew_fld, pold_fld, cu_fld, cv_fld, &
                           tdt)

  CALL invoke_apply_bcs(UNEW_fld)
  CALL invoke_apply_bcs(VNEW_fld)
  CALL invoke_apply_bcs(PNEW_fld)

  ! Set tdt to = 2*dt
  tdt = tdt + dt

  CALL copy_field(UNEW_fld, U_fld)
  CALL copy_field(VNEW_fld, V_fld)
  CALL copy_field(PNEW_fld, P_fld)

  call model_write(ncycle, p_fld, u_fld, v_fld)

  !====================================
  !  ** Start of time-stepping loop proper **
  DO ncycle=2,itmax

    call invoke_time_step(cu_fld, cv_fld, u_fld, unew_fld, uold_fld, &
                          v_fld, vnew_fld, vold_fld, &
                          p_fld, pnew_fld, pold_fld, &
                          h_fld, z_fld, tdt)

    call model_write(ncycle, p_fld, u_fld, v_fld)

  end do

  !  ** End of time loop **

  call timer_stop(idxt0)

  ! Output field checksums at end of run for correctness check
  call model_write_log("('P CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(pnew_fld))
  call model_write_log("('U CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(unew_fld))
  call model_write_log("('V CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(vnew_fld))

  call model_finalise()

  call gocean_finalise()

end program shallow


! THIS VERSION: GALAHAD 2.1 - 13/02/2008 AT 09:40 GMT.
PROGRAM GALAHAD_FILTRANE_EXAMPLE
  USE GALAHAD_NLPT_double      ! the problem type
  USE GALAHAD_FILTRANE_double  ! the FILTRANE solver
  USE GALAHAD_SYMBOLS
  IMPLICIT NONE
  INTEGER, PARAMETER                :: wp = KIND( 1.0D+0 )
  INTEGER,           PARAMETER      :: ispec = 55      ! SPECfile device number
  INTEGER,           PARAMETER      :: iout = 6        ! stdout and stderr
  REAL( KIND = wp ), PARAMETER      :: INFINITY = (10.0_wp)**19
  TYPE( NLPT_problem_type     )     :: problem
  TYPE( FILTRANE_control_type )     :: FILTRANE_control
  TYPE( FILTRANE_inform_type  )     :: FILTRANE_inform
  TYPE( FILTRANE_data_type    )     :: FILTRANE_data
  INTEGER                           :: J_size
  REAL( KIND = wp ), DIMENSION( 3 ) :: H1
! Set the problem up.
  problem%n        = 2
  ALLOCATE( problem%x( problem%n )  , problem%x_status( problem%n ),           &
            problem%x_l( problem%n ), problem%x_u( problem%n ),                &
            problem%g( problem%n )  , problem%z( problem%n )  )
  problem%m        = 2
  ALLOCATE( problem%equation( problem%m ),                                     &
            problem%c( problem%m ) , problem%c_l( problem%m ),                 &
            problem%c_u( problem%m), problem%y( problem%m ) )
  problem%J_ne     = 4
  J_size           = problem%J_ne + problem%n
  ALLOCATE( problem%J_val( J_size), problem%J_row( J_size ),                   &
            problem%J_col( J_size ) )
  problem%J_type   = GALAHAD_COORDINATE
  problem%infinity = INFINITY
  problem%x        = (/  1.0D0,  1.0D0 /)
  problem%x_l      = (/ -2.0D0, -2.0D0 /)
  problem%x_u      = (/  2.0D0,  2.0D0 /)
  problem%c_l      = (/  0.0D0,  0.0D0 /)
  problem%c_u      = (/  0.0D0,  0.0D0 /)
  problem%equation = (/ .TRUE., .TRUE. /)

! Initialize FILTRANE.
  CALL FILTRANE_initialize( FILTRANE_control, FILTRANE_inform, FILTRANE_data )
! Read the FILTRANE spec file (not necessary in this example, as the default
! settings are mostly suitable).
!  OPEN( ispec, file = 'FILTRANE.SPC', form = 'FORMATTED', status = 'OLD' )
!  CALL FILTRANE_read_specfile( ispec, FILTRANE_control, FILTRANE_inform )
!  CLOSE( ispec )
! Nevertheless... ask for some output:
  FILTRANE_control%print_level = GALAHAD_TRACE
! Now apply the solver in the reverse communication loop.
  DO
     CALL FILTRANE_solve( problem, FILTRANE_control, FILTRANE_inform,          &
                          FILTRANE_data )
     SELECT CASE ( FILTRANE_inform%status )
     CASE ( 1, 2 ) ! constraints values and Jacobian
        problem%c( 1 ) = 3.0D0 * problem%x( 1 ) ** 2 +                         &
                         2.0D0 * problem%x( 2 ) ** 3 +                         &
                         problem%x( 1 ) * problem%x( 2 )
        problem%c( 2 ) = problem%x( 1 ) + problem%x( 2 )
        problem%J_val( 1 ) = 6.0D0 * problem%x( 1 ) + problem%x( 2 )
        problem%J_val( 2 ) = 1.0D0
        problem%J_val( 3 ) = 6.0D0 * problem%x( 2 ) ** 2 + problem%x( 1 )
        problem%J_val( 4 ) = 1.0D0
        problem%J_row( 1 : 4 ) = (/ 1, 2, 1, 2 /)
        problem%J_col( 1 : 4 ) = (/ 1, 1, 2, 2 /)
     CASE ( 3 : 5 ) ! constraints values only
        problem%c( 1 ) = 3.0D0 * problem%x( 1 ) ** 2 +                         &
                         2.0D0 * problem%x( 2 ) ** 3 +                         &
                         problem%x( 1 ) * problem%x( 2 )
        problem%c( 2 ) = problem%x( 1 ) + problem%x( 2 )
     CASE ( 6 ) ! Jacobian only
        problem%J_val( 1 ) = 6.0D0 * problem%x( 1 )  + problem%x( 2 )
        problem%J_val( 2 ) = 1.0D0
        problem%J_val( 3 ) = 6.0D0 * problem%x( 2 ) ** 2 + problem%x( 1 )
        problem%J_val( 4 ) = 1.0D0
     CASE ( 15, 16 ) ! product times the Hessian of the Lagrangian
!       Note that H2, the Hessian of C2 is identically zero, since this
!       constraint is linear. Hence the terms in y(2)*H2 disappear.
        IF ( FILTRANE_data%RC_newx ) THEN
           H1( 1 ) = 6.0D0
           H1( 2 ) = 1.0D0
           H1( 3 ) = 12.0D0 * problem%x( 2 )
        END IF
        FILTRANE_data%RC_Mv( 1 ) =                                             &
                        problem%y( 1 ) * H1( 1 ) * FILTRANE_data%RC_v( 1 ) +   &
                        problem%y( 1 ) * H1( 2 ) * FILTRANE_data%RC_v( 2 )
        FILTRANE_data%RC_Mv( 2 ) =                                             &
                        problem%y( 1 ) * H1( 2 ) * FILTRANE_data%RC_v( 1 ) +   &
                        problem%y( 1 ) * H1( 3 ) * FILTRANE_data%RC_v( 2 )
     CASE DEFAULT
        EXIT
     END SELECT
  END DO ! end of the reverse communication loop
! Terminate FILTRANE.
  FILTRANE_control%print_level = GALAHAD_SILENT
  CALL FILTRANE_terminate( FILTRANE_control, FILTRANE_inform, FILTRANE_data )
! Output results.
  WRITE( iout, 1000 )
  WRITE( iout, 1001 )
  WRITE( iout, 1000 )
  WRITE( iout, 1002 ) problem%x( 1 )
  WRITE( iout, 1003 ) problem%x( 2 )
  WRITE( iout, 1000 )
  WRITE( iout, 1004 ) problem%c( 1 )
  WRITE( iout, 1005 ) problem%c( 2 )
  WRITE( iout, 1000 )
  WRITE( iout, 1006 ) FILTRANE_inform%status
  WRITE( iout, 1007 ) problem%f
  WRITE( iout, 1008 ) FILTRANE_inform%nbr_iterations,                          &
                      FILTRANE_inform%nbr_cg_iterations
  WRITE( iout, 1009 ) FILTRANE_inform%nbr_c_evaluations
  WRITE( iout, 1010 ) FILTRANE_inform%nbr_J_evaluations
! Cleanup the problem.
  CALL NLPT_cleanup( problem )
  STOP
! Formats
1000 FORMAT(/)
1001 FORMAT(' Problem : GALEXAMPLE')
1002 FORMAT(' X1 = ',1PE20.12)
1003 FORMAT(' X2 = ',1PE20.12)
1004 FORMAT(' C1 = ',1PE20.12)
1005 FORMAT(' C2 = ',1PE20.12)
1006 FORMAT(' Exit condition number    = ',i10)
1007 FORMAT(' Objective function value =',1PE20.12)
1008 FORMAT(' Number of iterations     = ',i10,/,                              &
            ' Number of CG iterations  = ',i10)
1009 FORMAT(' Number of constraints evaluations =',i6)
1010 FORMAT(' Number of Jacobian evaluations    =',i6)
END PROGRAM GALAHAD_FILTRANE_EXAMPLE


submodule(euler_interface_m) euler_prob_0053_m
    implicit none

contains

    module character(len=20) function euler0053()
        write (euler0053, "(i20)") ans(100)
    end function euler0053

    integer function ans(upper_bound)
        integer, intent(in) :: upper_bound
        integer :: count, n, r
        integer :: c(0:upper_bound, 0:upper_bound)
        integer, parameter :: b = 1000000

        count = 0
        do n = 1, upper_bound
            c(n, 0) = 1
            c(n, n) = 1

            do r = 1, n - 1
                c(n, r) = c(n - 1, r - 1) + c(n - 1, r)
                if (c(n, r) >= b) then
                    count = count + 1
                    c(n, r) = b
                end if
            end do

        end do

        ans = count
    end function ans
end submodule euler_prob_0053_m