!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! DESCRIPTION:
!> @brief
!> This module groups some useful mathematical function.
!>
!> @details
!>
!>    to compute the mean of an array:

!> @code
!>    dl_value=math_mean( dl_value, dd_fill )
!> @endcode
!>       - dl_value is 1D or 2D array
!>       - dd_fill is FillValue
!>
!>    to compute the median of an array:

!> @code
!>    dl_value=math_median( dl_value, dd_fill )
!> @endcode
!>       - dl_value is 1D or 2D array
!>       - dd_fill is FillValue
!>
!>    to compute the mean without extremum of an array:

!> @code
!>    dl_value=math_mwe( dl_value, id_next, dd_fill )
!> @endcode
!>       - dl_value is 1D or 2D array
!>       - id_next is the number of extremum to be removed
!>       - dd_fill is FillValue
!>
!>    to sort an 1D array:

!> @code
!>    CALL math_QsortC(dl_value)
!> @endcode
!>       - dl_value is 1D array
!>
!>    to correct phase angles to produce smoother phase:

!> @code
!>    CALL math_unwrap(dl_value, [dl_discont])
!> @endcode
!>       - dl_value is 1D array
!>       - dl_discont maximum discontinuity between values, default pi
!>
!>    to compute simple operation
!> @code
!>    dl_res=math_compute(cl_var)
!> @endcode
!>       - cl_var operation to compute (string of character)
!>       - dl_res result of the operation, real(dp)
!>
!>    to compute first derivative of 1D array:

!> @code
!>    dl_value(:)=math_deriv_1D( dd_value(:), dd_fill, [ld_discont] )
!> @endcode
!>       - dd_value is 1D array of variable
!>       - dd_fill is FillValue of variable
!>       - ld_discont is logical to take into account longitudinal
!>         East-West discontinuity [optional]
!>
!>    to compute first derivative of 2D array:

!> @code
!>    dl_value(:,:)=math_deriv_2D( dd_value(:,:), dd_fill, cd_dim,
!>                  [ld_discont] )
!> @endcode
!>       - dd_value is 2D array of variable
!>       - dd_fill is FillValue of variable
!>       - cd_dim is character to compute derivative on first (I) or
!>         second (J) dimension
!>       - ld_discont is logical to take into account longitudinal
!>         East-West discontinuity [optional]
!>
!>    to compute first derivative of 3D array:

!> @code
!>    dl_value(:,:,:)=math_deriv_3D( dd_value(:,:,:), dd_fill, cd_dim,
!>                    [ld_discont] )
!> @endcode
!>       - dd_value is 3D array of variable
!>       - dd_fill is FillValue of variable
!>       - cd_dim is character to compute derivative on first (I), second (J),
!>         or third (K) dimension
!>       - ld_discont is logical to take into account longitudinal East-West
!>         discontinuity [optional]
!>
!>
!> @author
!> J.Paul
!>
!> @date January, 2015 - Initial version
!>
!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE math

   USE kind                            ! F90 kind parameter
   USE global                          ! global variable
   USE phycst                          ! physical constant
   USE fct                             ! basic useful function
   IMPLICIT NONE
   ! NOTE_avoid_public_variables_if_possible

   ! function and subroutine
   PUBLIC :: math_mean      !< return mean of an array
   PUBLIC :: math_median    !< return median of an array
   PUBLIC :: math_mwe       !< return mean without extremum of an array
   PUBLIC :: math_QsortC    !< sort an 1D array
   PUBLIC :: math_unwrap    !< correct phase angles to produce smoother phase
   PUBLIC :: math_compute   !< compute simple operation
   PUBLIC :: math_deriv_1D  !< compute first derivative of 1D array
   PUBLIC :: math_deriv_2D  !< compute first derivative of 2D array
   PUBLIC :: math_deriv_3D  !< compute first derivative of 3D array
   PUBLIC :: math_ortho     !< compute orthodome distance
   PUBLIC :: math_euclid    !< compute euclidian distance

   PRIVATE :: math__Partition
   PRIVATE :: math__mean_1d
   PRIVATE :: math__mean_2d
   PRIVATE :: math__median_1d
   PRIVATE :: math__median_2d
   PRIVATE :: math__mwe_1d
   PRIVATE :: math__mwe_2d
   PRIVATE :: math__parentheses

   INTERFACE math_mean
      MODULE PROCEDURE math__mean_1d ! return mean of an array 1D
      MODULE PROCEDURE math__mean_2d ! return mean of an array 2D
   END INTERFACE math_mean

   INTERFACE math_median
      MODULE PROCEDURE math__median_1d ! return median of an array 1D
      MODULE PROCEDURE math__median_2d ! return median of an array 2D
   END INTERFACE math_median

   INTERFACE math_mwe
      MODULE PROCEDURE math__mwe_1d ! return mean without extremum of an array 1D
      MODULE PROCEDURE math__mwe_2d ! return mean without extremum of an array 2D
   END INTERFACE math_mwe

CONTAINS
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__mean_1d(dd_array, dd_fill) &
         & RESULT (df_mean)
   !-------------------------------------------------------------------
   !> @brief This function compute the mean of a 1D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  1D array
   !> @param[in] dd_fill   fillValue
   !> @return mean value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array
      REAL(dp),               INTENT(IN), OPTIONAL :: dd_fill

      ! function
      REAL(dp)                           :: df_mean

      ! local variable
      INTEGER(i4)  :: il_count
      REAL(dp)     :: dl_sum
      REAL(dp)     :: dl_count
      !----------------------------------------------------------------

      IF( PRESENT(dd_fill) )THEN
         il_count=COUNT(dd_array(:)/=dd_fill)
         IF( il_count > 0 )THEN
            dl_sum  =SUM ( dd_array(:), dd_array(:)/= dd_fill )
            dl_count=REAL( il_count, dp)

            df_mean=dl_sum/dl_count
         ELSE
            df_mean=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array(:))
         IF( il_count > 0 )THEN
            dl_sum  =SUM ( dd_array(:) )
            dl_count=REAL( il_count, dp)

            df_mean=dl_sum/dl_count
         ELSE
            df_mean=0
         ENDIF
      ENDIF

   END FUNCTION math__mean_1d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__mean_2d(dd_array, dd_fill) &
         & RESULT (df_mean)
   !-------------------------------------------------------------------
   !> @brief This function compute the mean of a 2D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  2D array
   !> @param[in] dd_fill   fillValue
   !> @return mean value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array
      REAL(dp),                 INTENT(IN), OPTIONAL :: dd_fill

      ! function
      REAL(dp)                             :: df_mean

      ! local variable
      INTEGER(i4)                         :: il_count

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list
      !----------------------------------------------------------------

      IF( PRESENT(dd_fill)  )THEN
         il_count=COUNT(dd_array(:,:)/=dd_fill)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill)
         ELSE
            df_mean=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.)
         ELSE
            df_mean=0
         ENDIF
      ENDIF

      IF( ALLOCATED(dl_list) )THEN
         df_mean=math_mean(dl_list(:))
         DEALLOCATE( dl_list )
      ENDIF

   END FUNCTION math__mean_2d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__median_1d(dd_array, dd_fill) &
         & RESULT (df_median)
   !-------------------------------------------------------------------
   !> @brief This function compute the median of a 1D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  1D array
   !> @param[in] dd_fill   fillValue
   !> @return median value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array
      REAL(dp),               INTENT(IN), OPTIONAL :: dd_fill

      ! function
      REAL(dp)                           :: df_median

      ! local variable
      INTEGER(i4)                         :: il_count

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list
      !----------------------------------------------------------------

      IF( PRESENT(dd_fill)  )THEN
         il_count=COUNT(dd_array(:)/=dd_fill)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:),dd_array(:)/=dd_fill)
         ELSE
            df_median=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array(:))
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=dd_array(:)
         ELSE
            df_median=0
         ENDIF
      ENDIF

      IF( ALLOCATED(dl_list) )THEN
         CALL math_QsortC(dl_list(:))

         IF( MOD(il_count,2) == 0 )THEN
            df_median=(dl_list(il_count/2+1)+dl_list(il_count/2))/2_dp
         ELSE
            df_median=dl_list(il_count/2+1)
         ENDIF

         DEALLOCATE(dl_list)
      ENDIF

   END FUNCTION math__median_1d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__median_2d(dd_array, dd_fill) &
         & RESULT (df_median)
   !-------------------------------------------------------------------
   !> @brief This function compute the median of a 2D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  2D array
   !> @param[in] dd_fill   fillValue
   !> @return median value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array
      REAL(dp),                 INTENT(IN), OPTIONAL :: dd_fill

      ! funtion
      REAL(dp)                             :: df_median

      ! local variable
      INTEGER(i4)                         :: il_count

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list
      !----------------------------------------------------------------

      IF( PRESENT(dd_fill)  )THEN
         il_count=COUNT(dd_array(:,:)/=dd_fill)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill)
         ELSE
            df_median=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array(:,:))
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.)
         ELSE
            df_median=0
         ENDIF
      ENDIF

      IF( ALLOCATED(dl_list) )THEN
         df_median=math_median(dl_list(:))
         DEALLOCATE(dl_list)
      ENDIF

   END FUNCTION math__median_2d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__mwe_1d(dd_array, id_next, dd_fill) &
         & RESULT (df_mwe)
   !-------------------------------------------------------------------
   !> @brief This function compute the mean without extremum of a 1D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  1D array
   !> @param[in] id_next   number of extremum to be removed
   !> @param[in] dd_fill   fillValue
   !> @return median value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:), INTENT(IN) :: dd_array
      INTEGER(i4)           , INTENT(IN), OPTIONAL :: id_next
      REAL(dp),               INTENT(IN), OPTIONAL :: dd_fill

      ! function
      REAL(dp)                           :: df_mwe

      ! local variable
      INTEGER(i4)                         :: il_next
      INTEGER(i4)                         :: il_count
      INTEGER(i4)                         :: il_size

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list
      !----------------------------------------------------------------

      il_next=2
      IF( PRESENT(id_next) ) il_next=id_next

      il_size=SIZE(dd_array(:))
      IF( PRESENT(dd_fill)  )THEN
         il_count=COUNT(dd_array(:)/=dd_fill)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:),dd_array(:)/=dd_fill)
         ELSE
            df_mwe=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array(:))
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=dd_array(:)
         ELSE
            df_mwe=0
         ENDIF
      ENDIF

      IF( ALLOCATED(dl_list) )THEN
         CALL math_QsortC(dl_list(:))

         IF( il_count == il_size )THEN
            ! no fillValue
            df_mwe=math_mean(dl_list(il_next+1:il_size-il_next))
         ELSEIF( il_count > il_size-2*il_next )THEN
            ! remove one extremum each side
            df_mwe=math_mean(dl_list(2:il_size-1))
         ELSE ! il_count <= il_size-2*il_next
            ! more than 2*il_next fillValue
            ! compute mean only
            df_mwe=math_mean(dl_list(:))
         ENDIF

         DEALLOCATE(dl_list)
      ENDIF

   END FUNCTION math__mwe_1d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math__mwe_2d(dd_array, id_next, dd_fill) &
         & RESULT (df_mwe)
   !-------------------------------------------------------------------
   !> @brief This function compute the mean without extremum of a 2D array.
   !>
   !> @author J.Paul
   !> @date January, 2015 - Initial Version
   !>
   !> @param[in] dd_array  2D array
   !> @param[in] id_next   number of extremum to be removed
   !> @param[in] dd_fill   fillValue
   !> @return median value, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_array
      INTEGER(i4)             , INTENT(IN), OPTIONAL :: id_next
      REAL(dp),                 INTENT(IN), OPTIONAL :: dd_fill

      ! function
      REAL(dp)                             :: df_mwe

      ! local variable
      INTEGER(i4)                         :: il_count

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_list
      !----------------------------------------------------------------

      IF( PRESENT(dd_fill)  )THEN
         il_count=COUNT(dd_array(:,:)/=dd_fill)
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:),dd_array(:,:)/=dd_fill)

            df_mwe=math_mwe(dl_list(:), id_next)
         ELSE
            df_mwe=dd_fill
         ENDIF
      ELSE
         il_count=SIZE(dd_array(:,:))
         IF( il_count > 0 )THEN
            ALLOCATE( dl_list(il_count) )
            dl_list(:)=PACK(dd_array(:,:), MASK=.TRUE.)

            df_mwe=math_mwe(dl_list(:), id_next)
         ELSE
            df_mwe=0
         ENDIF
      ENDIF

      IF( ALLOCATED(dl_list) ) DEALLOCATE(dl_list)

   END FUNCTION math__mwe_2d
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE RECURSIVE SUBROUTINE math_QsortC(dd_array)
   !-------------------------------------------------------------------
   !> @brief This subroutine sort a 1D array.
   !>
   !> @details
   !> Recursive Fortran 95 quicksort routine
   !> sorts real numbers into ascending numerical order
   !> Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
   !> Based on algorithm from Cormen et al., Introduction to Algorithms,
   !> 1997 printing
   !>
   !> @author J.Paul
   !> @date January, 2015 - Rewrite with SIREN coding rules
   !>
   !> @param[inout] dd_array  1D array
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), DIMENSION(:), INTENT(INOUT) :: dd_array

      ! local variable
      INTEGER(i4) :: il_iq
      !----------------------------------------------------------------

      IF( SIZE(dd_array(:)) > 1 )THEN
         CALL math__Partition(dd_array, il_iq)
         CALL math_QsortC(dd_array(:il_iq-1))
         CALL math_QsortC(dd_array(il_iq:))
      ENDIF

   END SUBROUTINE math_QsortC
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE SUBROUTINE math__Partition(dd_array, id_marker)
   !-------------------------------------------------------------------
   !> @brief This subroutine partition a 1D array.
   !>
   !> @details
   !> Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
   !> Based on algorithm from Cormen et al., Introduction to Algorithms,
   !> 1997 printing
   !>
   !> @author J.Paul
   !> @date January, 2015 - Rewrite with SIREN coding rules
   !> @date November, 2017
   !> - use the correct loop index to look for element bigger than pivot point.
   !>
   !> @param[inout] dd_array  1D array
   !> @param[in] id_marker
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)   , DIMENSION(:), INTENT(INOUT) :: dd_array
      INTEGER(i4),               INTENT(  OUT) :: id_marker

      ! local variable
      REAL(dp)    :: dl_temp
      REAL(dp)    :: dl_x     ! pivot point

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      dl_x = dd_array(1)
      ji= 0
      jj= SIZE(dd_array(:)) + 1

      DO
         jj=jj-1
         DO
            IF( dd_array(jj) <= dl_x ) EXIT
            jj=jj-1
         ENDDO
         ji=ji+1
         DO
            IF( dd_array(ji) >= dl_x ) EXIT
            ji=ji+1
         ENDDO
         IF( ji < jj )THEN
            ! exchange dd_array(ji) and dd_array(jj)
            dl_temp= dd_array(ji)
            dd_array(ji) = dd_array(jj)
            dd_array(jj) = dl_temp
         ELSEIF( ji==jj )THEN
            id_marker=ji+1
            RETURN
         ELSE
            id_marker=ji
            RETURN
         ENDIF
      ENDDO

   END SUBROUTINE math__Partition
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE SUBROUTINE math_unwrap(dd_array, dd_discont)
   !-------------------------------------------------------------------
   !> @brief This subroutine correct phase angles to produce smoother
   !> phase plots.
   !>
   !> @details
   !> This code is based on numpy unwrap function
   !>
   !> Unwrap by changing deltas between values to 2*pi complement.
   !>
   !> Unwrap radian phase `dd_array` by changing absolute jumps greater than
   !> `dd_discont` to their 2*pi complement.
   !>
   !> @note If the discontinuity in `dd_array` is smaller than ``pi``,
   !> but larger than `dd_discont`, no unwrapping is done because taking
   !> the 2*pi complement would only make the discontinuity larger.
   !>
   !> @author J.Paul
   !> @date Marsh, 2015 - Rewrite in fortran, with SIREN coding rules
   !>
   !> @param[inout] dd_array  1D array
   !> @param[in] dd_discont maximum discontinuity between values, default pi
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)   , DIMENSION(:), INTENT(INOUT) :: dd_array
      REAL(dp)   ,               INTENT(IN   ), OPTIONAL :: dd_discont

      ! local variable
      INTEGER(i4)                         :: il_size

      REAL(dp)                            :: dl_discont

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_diff
      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_mod
      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_correct
      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_tmp

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------
      dl_discont=dp_pi
      IF( PRESENT(dd_discont) ) dl_discont=dd_discont

      il_size=SIZE(dd_array)
      ALLOCATE(dl_diff(il_size-1))
      DO ji=1,il_size-1
         dl_diff(ji)=dd_array(ji+1)-dd_array(ji)
      ENDDO

      ALLOCATE(dl_mod(il_size-1))
      DO ji=1,il_size-1
         dl_mod(ji) = MOD(dl_diff(ji) + dp_pi, 2*dp_pi) - dp_pi
      ENDDO

      WHERE( (dl_mod(:) == -dp_pi) .AND. (dl_diff(:) > 0._dp ) )
         dl_mod(:)=dp_pi
      END WHERE

      ALLOCATE(dl_correct(il_size-1))
      dl_correct(:)=dl_mod(:)-dl_diff(:)

      DEALLOCATE(dl_mod)

      WHERE( ABS(dl_diff(:)) < dl_discont )
         dl_correct(:)=0._dp
      END WHERE

      DEALLOCATE(dl_diff)

      ALLOCATE(dl_tmp(il_size))
      dl_tmp(:)=dd_array(:)

      DO ji=1,il_size-1
         dd_array(ji+1)=dl_tmp(ji+1)+SUM(dl_correct(1:ji))
      ENDDO

      DEALLOCATE(dl_correct)
      DEALLOCATE(dl_tmp)

   END SUBROUTINE math_unwrap
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   RECURSIVE FUNCTION math_compute(cd_var) &
         &  RESULT(df_res)
   !-------------------------------------------------------------------
   !> @brief This function compute simple operation
   !>
   !> @details
   !> - operation should be write as a string of character.
   !> - operators allowed are : +,-,*,/
   !> - to ordered operation you should use parentheses
   !>
   !> exemples: '1e6/(16/122)', '(3/2)*(2+1)'
   !>
   !> @author J.Paul
   !> @date June, 2015 - initial version
   !>
   !> @param[in] cd_var operation to compute (string of character)
   !> @return result of the operation, real(dp)
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      CHARACTER(LEN=*), INTENT(IN) :: cd_var

      ! fucntion
      REAL(dp)                     :: df_res

      ! local variables
      CHARACTER(LEN=lc) :: cl_var
      CHARACTER(LEN=lc) :: cl_str1
      CHARACTER(LEN=lc) :: cl_str2

      INTEGER(i4)       :: il_ind
      ! loop indices
      !----------------------------------------------------------------

      IF(fct_is_real(cd_var))THEN
         READ(cd_var,*) df_res
      ELSE

         CALL math__parentheses(cd_var, cl_var)

         IF(fct_is_real(cl_var))THEN
            READ(cl_var,*) df_res
         ELSE
            il_ind=SCAN(TRIM(cl_var),'*')
            IF( il_ind /= 0 )THEN
               cl_str1=cl_var(1:il_ind-1)
               cl_str2=cl_var(il_ind+1:)
               df_res=math_compute(cl_str1)*math_compute(cl_str2)
            ELSE
               il_ind=SCAN(TRIM(cl_var),'/')
               IF( il_ind /= 0 )THEN
                  cl_str1=cl_var(1:il_ind-1)
                  cl_str2=cl_var(il_ind+1:)
                  df_res=math_compute(cl_str1)/math_compute(cl_str2)
               ELSE
                  il_ind=SCAN(TRIM(cl_var),'+')
                  IF( il_ind /= 0 )THEN
                     cl_str1=cl_var(1:il_ind-1)
                     cl_str2=cl_var(il_ind+1:)
                     df_res=math_compute(cl_str1)+math_compute(cl_str2)
                  ELSE
                     il_ind=SCAN(TRIM(cl_var),'-')
                     IF( il_ind /= 0 )THEN
                        cl_str1=cl_var(1:il_ind-1)
                        cl_str2=cl_var(il_ind+1:)
                        df_res=math_compute(cl_str1)-math_compute(cl_str2)
                     ELSE
                        df_res=dp_fill
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
      ENDIF

   END FUNCTION math_compute
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE math__parentheses(cd_varin, cd_varout)
   !-------------------------------------------------------------------
   !> @brief This subroutine replace sub string inside parentheses
   !> by the value of the operation inside.
   !>
   !> @details
   !> exemple :
   !> - '2.6+(3/2)' => '2.6+1.5000'
   !>
   !> @author J.Paul
   !> @date June, 2015 - initial version
   !>
   !> @param[in] cd_varin  string of character with operation inside
   !> parentheses
   !> @param[out] cd_varout string of character with result of
   !> operation inside parentheses
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      CHARACTER(LEN=*) , INTENT(IN)  :: cd_varin
      CHARACTER(LEN=lc), INTENT(OUT) :: cd_varout

      ! local variables
      CHARACTER(LEN=lc)     :: cl_cpt
      INTEGER(i4)           :: il_ind
      INTEGER(i4)           :: il_count

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------
      il_ind=INDEX(cd_varin,'(')
      IF( il_ind /= 0 )THEN
         il_count=0
         DO ji=il_ind+1,LEN(cd_varin)
            IF( cd_varin(ji:ji) == '(' )THEN
               il_count=il_count+1
            ELSEIF( cd_varin(ji:ji) == ')' )THEN
               IF( il_count == 0 )THEN
                  WRITE(cl_cpt,*) math_compute(cd_varin(il_ind+1:ji-1))
                  cd_varout=TRIM(cd_varin(1:il_ind-1))//TRIM(ADJUSTL(cl_cpt))//&
                     &        TRIM(cd_varin(ji+1:))
                  EXIT
               ELSE
                  il_count=il_count-1
               ENDIF
            ENDIF
         ENDDO
      ELSE
         cd_varout=TRIM(cd_varin)
      ENDIF

   END SUBROUTINE math__parentheses
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math_deriv_1D(dd_value, dd_fill, ld_discont) &
         & RESULT (df_deriv)
   !-------------------------------------------------------------------
   !> @brief
   !> This function compute derivative of 1D array.
   !>
   !> @details
   !> optionaly you could specify to take into account east west discontinuity
   !> (-180° 180° or 0° 360° for longitude variable)
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_value     1D array of variable to be extrapolated
   !> @param[in] dd_fill      FillValue of variable
   !> @param[in] ld_discont   logical to take into account east west discontinuity
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)   , DIMENSION(:), INTENT(IN) :: dd_value
      REAL(dp)                 , INTENT(IN) :: dd_fill
      LOGICAL                  , INTENT(IN), OPTIONAL :: ld_discont

      ! function
      REAL(dp), DIMENSION(SIZE(dd_value,DIM=1) ) :: df_deriv

      ! local variable
      INTEGER(i4)                            :: il_imin
      INTEGER(i4)                            :: il_imax
      INTEGER(i4), DIMENSION(1)              :: il_shape

      REAL(dp)                               :: dl_min
      REAL(dp)                               :: dl_max
      REAL(dp)   , DIMENSION(:), ALLOCATABLE :: dl_value

      LOGICAL                                :: ll_discont

      ! loop indices
      INTEGER(i4) :: ji

      INTEGER(i4) :: i1
      INTEGER(i4) :: i2
      !----------------------------------------------------------------
      ! init
      df_deriv(:)=dd_fill

      ll_discont=.FALSE.
      IF( PRESENT(ld_discont) ) ll_discont=ld_discont

      il_shape(:)=SHAPE(dd_value(:))

      ALLOCATE( dl_value(3))

      ! compute derivative in i-direction
      DO ji=1,il_shape(1)

            il_imin=MAX(ji-1,1)
            il_imax=MIN(ji+1,il_shape(1))

            IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=3
            ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=2
            ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN
               i1=2  ; i2=3
            ENDIF

            dl_value(i1:i2)=dd_value(il_imin:il_imax)
            IF( il_imin == 1 )THEN
               dl_value(:)=EOSHIFT( dl_value(:), &
               &                    DIM=1,         &
               &                    SHIFT=-1,      &
               &                    BOUNDARY=dl_value(1) )
            ENDIF
            IF( il_imax == il_shape(1) )THEN
               dl_value(:)=EOSHIFT( dl_value(:), &
               &                    DIM=1,         &
               &                    SHIFT=1,       &
               &                    BOUNDARY=dl_value(3))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:), dl_value(:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:), dl_value(:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:) < 0._dp )
                     dl_value(:) = dl_value(:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:) > 180._dp )
                     dl_value(:) = dl_value(:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

         IF( dl_value( 2) /= dd_fill .AND. & ! ji
         &   dl_value( 3) /= dd_fill .AND. & ! ji+1
         &   dl_value( 1) /= dd_fill )THEN   ! ji-1

            df_deriv(ji)= (dl_value(3) - dl_value(1)) / REAL(il_imax-il_imin,dp)

         ENDIF

      ENDDO

      DEALLOCATE( dl_value )

   END FUNCTION math_deriv_1D
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION math_deriv_2D(dd_value, dd_fill, cd_dim, ld_discont) &
         & RESULT (df_deriv)
   !-------------------------------------------------------------------
   !> @brief
   !> This function compute derivative of 2D array.
   !> you have to specify in which direction derivative have to be computed:
   !> first (I) or second (J) dimension.
   !>
   !> @details
   !> optionaly you could specify to take into account east west discontinuity
   !> (-180° 180° or 0° 360° for longitude variable)
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_value     2D array of variable to be extrapolated
   !> @param[in] dd_fill      FillValue of variable
   !> @param[in] cd_dim       compute derivative on first (I) or second (J) dimension
   !> @param[in] ld_discont   logical to take into account east west discontinuity
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)   , DIMENSION(:,:), INTENT(IN) :: dd_value
      REAL(dp)                   , INTENT(IN) :: dd_fill
      CHARACTER(LEN=*)           , INTENT(IN) :: cd_dim
      LOGICAL                    , INTENT(IN), OPTIONAL :: ld_discont

      ! function
      REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &
         &                SIZE(dd_value,DIM=2) ) :: df_deriv

      ! local variable
      INTEGER(i4)                              :: il_imin
      INTEGER(i4)                              :: il_imax
      INTEGER(i4)                              :: il_jmin
      INTEGER(i4)                              :: il_jmax
      INTEGER(i4), DIMENSION(2)                :: il_shape

      REAL(dp)                                 :: dl_min
      REAL(dp)                                 :: dl_max
      REAL(dp)   , DIMENSION(:,:), ALLOCATABLE :: dl_value

      LOGICAL                                  :: ll_discont

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj

      INTEGER(i4) :: i1
      INTEGER(i4) :: i2

      INTEGER(i4) :: j1
      INTEGER(i4) :: j2
      !----------------------------------------------------------------
      ! init
      df_deriv(:,:)=dd_fill

      ll_discont=.FALSE.
      IF( PRESENT(ld_discont) ) ll_discont=ld_discont

      il_shape(:)=SHAPE(dd_value(:,:))

      SELECT CASE(TRIM(fct_upper(cd_dim)))

      CASE('I')

         ALLOCATE( dl_value(3,il_shape(2)) )
         ! compute derivative in i-direction
         DO ji=1,il_shape(1)

            ! init
            dl_value(:,:)=dd_fill

            il_imin=MAX(ji-1,1)
            il_imax=MIN(ji+1,il_shape(1))

            IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=3
            ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=2
            ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN
               i1=2  ; i2=3
            ENDIF

            dl_value(i1:i2,:)=dd_value(il_imin:il_imax,:)
            IF( il_imin == 1 )THEN
               dl_value(:,:)=EOSHIFT( dl_value(:,:), &
                  &                   DIM=1,         &
                  &                   SHIFT=-1,      &
                  &                   BOUNDARY=dl_value(1,:) )
            ENDIF
            IF( il_imax == il_shape(1) )THEN
               dl_value(:,:)=EOSHIFT( dl_value(:,:), &
                  &                   DIM=1,         &
                  &                   SHIFT=1,       &
                  &                   BOUNDARY=dl_value(3,:))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:,:) < 0_dp )
                     dl_value(:,:) = dl_value(:,:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:,:) > 180 )
                     dl_value(:,:) = dl_value(:,:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

            WHERE( dl_value(2,:) /= dd_fill .AND. &  ! ji
               &   dl_value(3,:) /= dd_fill .AND. &  ! ji+1
               &   dl_value(1,:) /= dd_fill )        ! ji-1

               df_deriv(ji,:)= (dl_value(3,:) - dl_value(1,:)) / REAL(il_imax-il_imin,dp)

            END WHERE

         ENDDO

      CASE('J')

         ALLOCATE( dl_value(il_shape(1),3) )
         ! compute derivative in j-direction
         DO jj=1,il_shape(2)

            il_jmin=MAX(jj-1,1)
            il_jmax=MIN(jj+1,il_shape(2))

            IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN
               j1=1  ; j2=3
            ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN
               j1=1  ; j2=2
            ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN
               j1=2  ; j2=3
            ENDIF

            dl_value(:,j1:j2)=dd_value(:,il_jmin:il_jmax)
            IF( il_jmin == 1 )THEN
               dl_value(:,:)=EOSHIFT( dl_value(:,:), &
                  &                   DIM=2,         &
                  &                   SHIFT=-1,      &
                  &                   BOUNDARY=dl_value(:,1))
            ENDIF
            IF( il_jmax == il_shape(2) )THEN
               dl_value(:,:)=EOSHIFT( dl_value(:,:), &
                  &                   DIM=2,         &
                  &                   SHIFT=1,       &
                  &                   BOUNDARY=dl_value(:,3))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:,:) < 0_dp )
                     dl_value(:,:) = dl_value(:,:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:,:) > 180 )
                     dl_value(:,:) = dl_value(:,:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

            WHERE( dl_value(:, 2) /= dd_fill .AND. & ! jj
               &   dl_value(:, 3) /= dd_fill .AND. & ! jj+1
               &   dl_value(:, 1) /= dd_fill )       ! jj-1

               df_deriv(:,jj)= (dl_value(:,3) - dl_value(:,1)) / REAL(il_jmax-il_jmin,dp)

            END WHERE

         ENDDO

      END SELECT

      DEALLOCATE( dl_value )

   END FUNCTION math_deriv_2D
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   PURE FUNCTION math_deriv_3D(dd_value, dd_fill, cd_dim, ld_discont) &
         & RESULT (df_deriv)
   !-------------------------------------------------------------------
   !> @brief
   !> This function compute derivative of 3D array.
   !> you have to specify in which direction derivative have to be computed:
   !> first (I), second (J) or third (K) dimension.
   !>
   !> @details
   !> optionaly you could specify to take into account east west discontinuity
   !> (-180° 180° or 0° 360° for longitude variable)
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  3D array of variable to be extrapolated
   !> @param[in] dd_fill      FillValue of variable
   !> @param[in] cd_dim       compute derivative on first (I) second (J) or third (K) dimension
   !> @param[in] ld_discont   logical to take into account east west discontinuity
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:,:,:), INTENT(IN) :: dd_value
      REAL(dp)                          , INTENT(IN) :: dd_fill
      CHARACTER(LEN=*)                  , INTENT(IN) :: cd_dim
      LOGICAL                           , INTENT(IN), OPTIONAL :: ld_discont

      ! function
      REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &
      &                   SIZE(dd_value,DIM=2), &
      &                   SIZE(dd_value,DIM=3)) :: df_deriv

      ! local variable
      INTEGER(i4)                                :: il_imin
      INTEGER(i4)                                :: il_imax
      INTEGER(i4)                                :: il_jmin
      INTEGER(i4)                                :: il_jmax
      INTEGER(i4)                                :: il_kmin
      INTEGER(i4)                                :: il_kmax
      INTEGER(i4), DIMENSION(3)                  :: il_shape

      REAL(dp)                                   :: dl_min
      REAL(dp)                                   :: dl_max
      REAL(dp)   , DIMENSION(:,:,:), ALLOCATABLE :: dl_value

      LOGICAL                                    :: ll_discont

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      INTEGER(i4) :: jk

      INTEGER(i4) :: i1
      INTEGER(i4) :: i2

      INTEGER(i4) :: j1
      INTEGER(i4) :: j2

      INTEGER(i4) :: k1
      INTEGER(i4) :: k2
      !----------------------------------------------------------------
      ! init
      df_deriv(:,:,:)=dd_fill

      ll_discont=.FALSE.
      IF( PRESENT(ld_discont) ) ll_discont=ld_discont

      il_shape(:)=SHAPE(dd_value(:,:,:))

      SELECT CASE(TRIM(fct_upper(cd_dim)))

      CASE('I')

         ALLOCATE( dl_value(3,il_shape(2),il_shape(3)) )
         ! compute derivative in i-direction
         DO ji=1,il_shape(1)

            il_imin=MAX(ji-1,1)
            il_imax=MIN(ji+1,il_shape(1))

            IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=3
            ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN
               i1=1  ; i2=2
            ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN
               i1=2  ; i2=3
            ENDIF

            dl_value(i1:i2,:,:)=dd_value(il_imin:il_imax,:,:)
            IF( il_imin == 1 )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=1,         &
                  &                     SHIFT=-1,      &
                  &                     BOUNDARY=dl_value(1,:,:) )
            ENDIF
            IF( il_imax == il_shape(1) )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=1,         &
                  &                     SHIFT=1,       &
                  &                     BOUNDARY=dl_value(3,:,:))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:,:,:) < 0_dp )
                     dl_value(:,:,:) = dl_value(:,:,:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:,:,:) > 180 )
                     dl_value(:,:,:) = dl_value(:,:,:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

            WHERE( dl_value(2,:,:) /= dd_fill .AND. & ! ji
               &   dl_value(3,:,:) /= dd_fill .AND. & !ji+1
               &   dl_value(1,:,:) /= dd_fill )       !ji-1

               df_deriv(ji,:,:)= (dl_value(3,:,:) - dl_value(1,:,:)) / REAL(il_imax-il_imin,dp)

            END WHERE

         ENDDO

      CASE('J')

         ALLOCATE( dl_value(il_shape(1),3,il_shape(3)) )
         ! compute derivative in j-direction
         DO jj=1,il_shape(2)

            il_jmin=MAX(jj-1,1)
            il_jmax=MIN(jj+1,il_shape(2))

            IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN
               j1=1  ; j2=3
            ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN
               j1=1  ; j2=2
            ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN
               j1=2  ; j2=3
            ENDIF

            dl_value(:,j1:j2,:)=dd_value(:,il_jmin:il_jmax,:)
            IF( il_jmin == 1 )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=2,         &
                  &                     SHIFT=-1,      &
                  &                     BOUNDARY=dl_value(:,1,:) )
            ENDIF
            IF( il_jmax == il_shape(2) )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=2,         &
                  &                     SHIFT=1,       &
                  &                     BOUNDARY=dl_value(:,3,:))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:,:,:) < 0_dp )
                     dl_value(:,:,:) = dl_value(:,:,:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:,:,:) > 180 )
                     dl_value(:,:,:) = dl_value(:,:,:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

            WHERE( dl_value(:, 2,:) /= dd_fill .AND. & ! jj
               &   dl_value(:, 3,:) /= dd_fill .AND. & ! jj+1
               &   dl_value(:, 1,:) /= dd_fill )       ! jj-1

               df_deriv(:,jj,:)= (dl_value(:,3,:) - dl_value(:,1,:)) / REAL(il_jmax - il_jmin,dp)

            END WHERE

         ENDDO

      CASE('K')

         ALLOCATE( dl_value(il_shape(1),il_shape(2),3) )
         ! compute derivative in k-direction
         DO jk=1,il_shape(3)

            il_kmin=MAX(jk-1,1)
            il_kmax=MIN(jk+1,il_shape(3))

            IF( il_kmin==jk-1 .AND. il_kmax==jk+1 )THEN
               k1=1  ; k2=3
            ELSEIF( il_kmin==jk .AND. il_kmax==jk+1 )THEN
               k1=1  ; k2=2
            ELSEIF( il_kmin==jk-1 .AND. il_kmax==jk )THEN
               k1=2  ; k2=3
            ENDIF

            dl_value(:,:,k1:k2)=dd_value(:,:,il_kmin:il_kmax)
            IF( il_kmin == 1 )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=3,         &
                  &                     SHIFT=-1,      &
                  &                     BOUNDARY=dl_value(:,:,1) )
            ENDIF
            IF( il_kmax == il_shape(3) )THEN
               dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &
                  &                     DIM=3,         &
                  &                     SHIFT=1,       &
                  &                     BOUNDARY=dl_value(:,:,3))
            ENDIF

            IF( ll_discont )THEN
               dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )
               IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
                  WHERE( dl_value(:,:,:) < 0_dp )
                     dl_value(:,:,:) = dl_value(:,:,:)+360._dp
                  END WHERE
               ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
                  WHERE( dl_value(:,:,:) > 180 )
                     dl_value(:,:,:) = dl_value(:,:,:)-180._dp
                  END WHERE
               ENDIF
            ENDIF

            WHERE( dl_value(:,:,2) /= dd_fill .AND. & ! jk
               &   dl_value(:,:,3) /= dd_fill .AND. & ! jk+1
               &   dl_value(:,:,1) /= dd_fill )       ! jk-1

               df_deriv(:,:,jk)= (dl_value(:,:,3) - dl_value(:,:,1)) / REAL(il_kmax-il_kmin,dp)

            END WHERE

         ENDDO

      END SELECT

      DEALLOCATE( dl_value )

   END FUNCTION math_deriv_3D
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION math_ortho(dd_latm) &
         &  RESULT(df_ortho)
   !-------------------------------------------------------------------
   !> @brief
   !> This function compute orthodome distance between opposite point of a cell
   !> of one degree.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date April, 2017 - Initial Version
   !>
   !> @param[in] dd_latm   mean latitude of the cell
   !> @return orthodome distance
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), TARGET :: dd_latm

      ! function
      REAL(dp)         :: df_ortho

      ! local
      REAL(dp) :: dl_dlat
      REAL(dp) :: dl_dlon
      REAL(dp) :: dl_lat1
      REAL(dp) :: dl_lat2
      REAL(dp) :: dl_tmp
      !----------------------------------------------------------------

      ! one degree cell
      dl_dlat= 1._dp * dp_deg2rad
      dl_dlon= 1._dp * dp_deg2rad

      !
      dl_lat1 = (dd_latm - 0.5_dp) * dp_deg2rad
      dl_lat2 = (dd_latm + 0.5_dp) * dp_deg2rad

      dl_tmp = SQRT( SIN(dl_dlat*0.5)**2 + &
         &           COS(dl_lat1)*COS(dl_lat2)*SIN(dl_dlon*0.5)**2 )

      df_ortho= 2* dp_rearth * ASIN( dl_tmp )

   END FUNCTION math_ortho
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION math_euclid(dd_lonm,dd_latm) &
         & RESULT(df_euclid)
   !-------------------------------------------------------------------
   !> @brief
   !> This function compute euclidian distance between opposite point of a cell
   !> of one degree, center on (lonm,latm).
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date April, 2017 - Initial Version
   !>
   !> @param[in] dd_lonm   mean longitude of the cell
   !> @param[in] dd_latm   mean latitude of the cell
   !> @return orthodome distance
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp), TARGET :: dd_lonm
      REAL(dp), TARGET :: dd_latm

      ! function
      REAL(dp)         :: df_euclid

      ! local
      REAL(dp) :: dl_lata
      REAL(dp) :: dl_lona
      REAL(dp) :: dl_latb
      REAL(dp) :: dl_lonb
      REAL(dp) :: xa,ya,za
      REAL(dp) :: xb,yb,zb
      !----------------------------------------------------------------

      dl_lata=(dd_latm-0.5)*dp_deg2rad
      dl_lona=(dd_lonm-0.5)*dp_deg2rad

      xa = dp_rearth * COS(dl_lata) * COS(dl_lona)
      ya = dp_rearth * COS(dl_lata) * SIN(dl_lona)
      za = dp_rearth * SIN(dl_lata)

      dl_latb=(dd_latm+0.5)*dp_deg2rad
      dl_lonb=(dd_lonm+0.5)*dp_deg2rad

      xb = dp_rearth * COS(dl_latb) * COS(dl_lonb)
      yb = dp_rearth * COS(dl_latb) * SIN(dl_lonb)
      zb = dp_rearth * SIN(dl_latb)

      df_euclid = ((xb-xa)**2 + (yb-ya)**2 + (zb-za)**2)

   END FUNCTION math_euclid
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
END MODULE math


MODULE procedures
   IMPLICIT NONE

CONTAINS
  SUBROUTINE foo(Y)

   DOUBLE PRECISION, DIMENSION(:,:,:,:), INTENT(IN) :: Y

   INTEGER :: i,j,k
   DOUBLE PRECISION, DIMENSION(SIZE(Y,4)) :: Ys

   !$omp target teams distribute parallel do collapse(3) default(none) &
   !$omp& private(i,j,k,Ys) &
   !$omp& shared(Y)
   DO i=1,SIZE(Y,1)
    DO j=1,SIZE(Y,2)
     DO k=1,SIZE(Y,3)

      Ys = MIN(MAX(Y(i,j,k,:), 0.0D0), 1.0D0)

     END DO ! k
    END DO ! j
   END DO ! i

   !$omp end target teams distribute parallel do

  END SUBROUTINE
END MODULE procedures

PROGRAM fmain
   USE PROCEDURES
   IMPLICIT NONE

   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Y

   ALLOCATE(Y(32,32,32,8))

   CALL foo(Y)

END PROGRAM fmain


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_Coor_by_KesiYita(kesi,yita,X_NODES,Y_NODES,
     &                                Out_x,Out_y)
C     Calculate global coordinates using local coordinates kesi and yita.

      implicit none
      double precision,intent(in)::kesi,yita,X_NODES(4),Y_NODES(4)
      double precision,intent(out)::Out_x,Out_y
      double precision N(4)

      N  = 0.25D0 * [(1-kesi)*(1-yita),(1+kesi)*(1-yita),
     &               (1+kesi)*(1+yita),(1-kesi)*(1+yita)]

      Out_x  = N(1)*X_NODES(1)+N(2)*X_NODES(2)+
     &         N(3)*X_NODES(3)+N(4)*X_NODES(4)
      Out_y  = N(1)*Y_NODES(1)+N(2)*Y_NODES(2)+
     &         N(3)*Y_NODES(3)+N(4)*Y_NODES(4)

      return
      end SUBROUTINE Cal_Coor_by_KesiYita


program main

  use mo_kind,      only: i4, i8, sp, dp
  use mo_functions, only: factorial, factln, gamm, gammln, beta
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_utils, only: ne

  implicit none

  logical                              :: isgood

  isgood = .true.
  write(*,*) ''
  write(*,*) 'Test mo_functions'

  ! Factorial
  if ( factorial(5_i4) .ne. 120_i4 ) isgood = .false.
  if ( factorial(5_i8) .ne. 120_i8 ) isgood = .false.

  ! factln
  if ( nint(exp(factln(5_i4)),i4) .ne. 120_i4 ) isgood = .false.
  if ( nint(exp(factln(5_i8)),i8) .ne. 120_i8 ) isgood = .false.

  ! gamm
  if ( nint(gamm(6._sp),i4) .ne. 120_i4 ) isgood = .false.
  if ( nint(gamm(6._dp),i8) .ne. 120_i8 ) isgood = .false.

  ! gammln
  if ( nint(exp(gammln(6._sp)),i4) .ne. 120_i4 ) isgood = .false.
  if ( nint(exp(gammln(6._dp)),i8) .ne. 120_i8 ) isgood = .false.

  ! beta
  if ( ne(beta(0.5_sp, 0.5_sp), 3.1415935_sp)) isgood = .false.
  if ( ne(beta(0.5_dp, 0.5_dp), 3.1415926535897927_dp)) isgood = .false.

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_functions ', color('o.k.', c_green)
  else
     write(*,*) 'mo_functions ', color('failed', c_red)
  end if

end program main


module Tools
  USE Inputs
  implicit none
  SAVE

contains

  !     Bin_Data subroutine enables the binning of data into a histogram
  !
  !
  !     ------------------------------Arguments-------------------------------------
  !
  !     HistoData: A 1xN array, where N is the number of bins in the histogram. N is usually the parameter bins
  !
  !     Data: A 1xM array, where M is the number of contributions to be added to HistoData. Each element is the value of a contribution
  !
  !     Weights: (OPTIONAL) A 1xM array containing the weights of each contribution in Data. If not present, the weight of a contribution is 1
  !
  !
  !     Dropped: (OPTIONAL) A variable of type integer that keeps track of the number of contributions outside of a specified range
  !              If not present, dropped contributions are ignored
  !
  !     Max/Min: Type real. The maximum (Max) and minimum (Min) values to be counted. Contributions outside are not counted

  subroutine Bin_Data( HistoData, Data, Weights, Dropped, Max, Min, bins )
    implicit none
    real(dp), dimension(:), intent(in) :: Data
    real(dp), dimension(:), Optional, intent(in) :: Weights
    integer, intent(in) :: bins
    real(dp), intent(inout) :: HistoData(bins)
    real, intent(in) :: Max
    real, intent(in) :: Min
    real(dp), optional, intent(inout) :: Dropped
    integer Loop1, Loop2 !Loop integers

    ! since both Dropped and Weights are optional there are 2^2 different versions of this subroutine.

    !First is if both Dropped and Weights are present
    If ( Present(Dropped) .and. Present(Weights) ) then

       do Loop1 = 1,size(Data)                                                !Loop through contributions
          if ( Weights(Loop1) .eq. 0 ) CYCLE                                  !If a contribution has a weight of 0, ignore.
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) then
             Dropped = Dropped + Weights(Loop1)                               !If a contribution is \lt or \gt min/max increment Dropped
          else
             Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)          !Find bin number of contribution
             if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) then                !Had some precision errors near the edge of the band, this ignore those
                Dropped = Dropped + Weights(Loop1)
             end if

             HistoData(Loop2) = HistoData(Loop2) + Weights(Loop1)             !Increment Loop2 bin of HistoData by the Weight is the Loop2 element

          end if

       end do

    !Second is if Dropped is present and Weights is not
    else if ( Present(Dropped) .and. (.not. Present(Weights) ) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) then
             Dropped = Dropped + 1
          else
             Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
             if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
             HistoData(Loop2) = HistoData(Loop2) + 1

          end if

       end do

    !Third is if Dropped is not present and Weights is present
    else if ( (.not. Present(Dropped)) .and. Present(Weights) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) CYCLE
          Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
          if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
          HistoData(Loop2) = HistoData(Loop2) + Weights(Loop1)

       end do

    !Last is if neither Dropped nor Weights are present.
    else if ( .not. ( Present(Dropped) .or. Present(Weights) ) ) then

       do Loop1 = 1,size(Data)
          if ( ( Data(Loop1) .lt. Min ) .or. ( Data(Loop1) .gt. Max ) ) CYCLE
          Loop2 = FLOOR(bins*(Data(Loop1) - Min)/(Max - Min) + 1)
          if ( (Loop2 .gt. bins) .or. (Loop2 .lt. 1) ) CYCLE
          HistoData(Loop2) = HistoData(Loop2) + 1

       end do

    else
       print*, "Bin_Data options exceeded"
       STOP
    end if

  end subroutine Bin_Data

  !     OpenFile creates a file with comments detailing system parameters and contents of the file
  !
  !
  !     ------------------------------Arguments-------------------------------------
  !
  !     Unum : Integer variable that contains the unit number for the file. Usually on the order of 100
  !
  !     Name : Character variable with any length that specificies the base file name.
  !
  !     Contents : Character variable with any length that names the data inside
  !
  !     Column1 : Character Variable with any length. Specifies the information in the first column
  !
  !     Column2 : Character Variable with any length. Specifies the information in the second column

  subroutine OpenFile( Unum, Name, Contents, Column1, Column2, num_procs )
    implicit none
    integer, intent(in) :: Unum
    character(len=*), intent(in) :: Name, Contents, Column1, Column2
    integer, intent(in), optional :: num_procs
    character(len=25) :: filename
    character(len=8) :: FormatP, FormatB
    filename = Name
    filename = FileNamer(filename)
    open (unit = Unum, file = "output/"//trim(filename)//"" ,status ='unknown' )

    FormatP = '(A,F6.1)'
    FormatB = '(A,F6.2)'

    write(Unum,'(A,A)') "#This file contains the following data type for the ensemble: ", Trim(Contents)
    write(Unum,'(A,A)') "#First column is: ", Trim(Column1)
    write(Unum,'(A,A)') "#Second column is: ", Trim(Column2)
    write(Unum,FormatP) "#Disorder Strength = ", DELTA
    write(Unum,FormatB) "#Bond Cutoff = ", bond_cutoff
    write(Unum,FormatB) "#Pruned bonds cutoff = ", prune_cutoff
    write(Unum,'(A)') "#Fraction of n.n. sites in which at least one orbital pair ignored = "
    write(Unum,'(A,F6.3)') "#", real(PrunedBonds)/real(dim*systemn)
    write(Unum,'(A,F6.3)') "#Fraction of prunings that are useful = ", real(StrongestBondsPruned)/real(PrunedBonds)
    write(Unum,FormatP) "#Hopping = ", hop
    write(Unum,FormatP) "#Interaction strength = ", uSite
    write(Unum,FormatP) "#Chemical Potential = ", ChemPot
    write(Unum,'(A,I4)') "#Dimensions = ", dim
    if ( Present(num_procs) ) then
       write(Unum,'(A,I4)') "#Number of processes = ", num_procs
       write(Unum,'(A,I10)') "#Number of systems = ", num_procs*systemn
    else if ( .not. Present(num_procs) ) then
       write(Unum,'(A,I10)') "#Number of systems = ", systemn
    end if

  end subroutine OpenFile

  !     PrintFile prints the data to the file created in OpenFile
  !
  !
  !     ------------------------------Arguments-------------------------------------
  !
  !     Unum : Integer variable that contains the unit number for the file. Usually on the order of 100
  !
  !     Form : Character variable of any length. Specifies the form the printed data will take in the file
  !
  !     Max/Min : real variable specifying the max and min values for the data being printed. Used for bin sizes
  !
  !     BinNum : Integer variable. Number of bins to be printed.
  !
  !     Data : Real rank-one array. Data to be printed.
  !
  !     Dropped : (OPTIONAL) real variable. Counts the combined weight that is less than min or greater than max for the purposes of normalization

  subroutine PrintData( Unum, Form, Min, Max, BinNum, Data_DOS, Data_dp, Data_int, Dropped )
    implicit none
    integer, intent(in) :: Unum, BinNum
    character(len=*), intent(in) :: Form
    real, intent(in) :: Min, Max
    real(dp), optional, intent(in) :: Dropped
    real(dp), optional, intent(in), dimension(:) :: Data_DOS, Data_dp
    integer(ip), optional, intent(in), dimension(:) :: Data_int
    real(dp) :: width
    integer :: Loop1
    integer(ip) :: sum1

    !This is Dropped is present
    if ( Present(Data_DOS) ) then
       if ( Present(Dropped) ) then
          width = (Max-Min)/BinNum
          do Loop1=1,BinNum
             write(Unum,(Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_DOS(Loop1)/ &
                  ( (Sum(Data_DOS) + Dropped) * width )
          end do
       else
          !If not present this is used. Difference is minor but not dividing by Dropped or the sum of data.
          !Second part is to enable cumulative DOS (DOS with clustermax=1,2,3,4,5 normalized to the DOS with clustermax = 6)
          width = (Max-Min)/BinNum
          do Loop1=1,BinNum
             write(Unum,( Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_DOS(Loop1)/( width )
          end do
       end if
    end if

    if ( Present(Data_dp) ) then
       width = (Max-Min)/BinNum
       do Loop1=1,BinNum
          write(Unum,(Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_dp(Loop1)/( Sum(Data_dp)*width )
       end do
    end if

    if (Present(Data_int) ) then
       sum1=0
       do Loop1=1,BinNum
          sum1 = sum1 + Data_int(Loop1)
       end do
       width = (Max - Min)/real(BinNum)
       do Loop1=1,BinNum
          write(Unum,(Form)) Min + ( Max - Min )*Loop1/real(BinNum) - BinWidth/2, Data_int(Loop1)/(sum1*width)
       end do
    end if

    Close(Unum)

  end subroutine PrintData

  !     resize_array removes a number of elements from a rank-one array
  !
  !
  !     ------------------------------Arguments-------------------------------------
  !
  !     array : Real rank-one array that is to be resized
  !
  !     numRemove : Integer. The number of elements to remove starting from the element Start in array
  !
  !     Start : Integer. The first element to remove from array

  subroutine resize_array(array, numRemove, Start)
    real(dp), dimension(:), allocatable :: tmp_arr
    real(dp), dimension(:), allocatable, intent(inout) :: array
    integer, intent(in) :: numRemove                           ! Number of elements to remove from 'array'
    integer, intent(in) :: Start                               ! The element in which to start removing the array
    integer i, j                                               ! Looping integer

    allocate(tmp_arr(size(array) - numRemove))

    tmp_arr(:) = 0.d0

    j=1

    if ( (Start + numRemove) .le. size(array) ) then

       do i = 1, Start - 1

          tmp_arr(i) = array(i)
          j = j + 1

       end do

       do i = (Start + numRemove), Size(array)

          tmp_arr(j) = array(i)
          j = j + 1

       end do

    else if ( (Start + numRemove) .gt. size(array) ) then

       do i = (Start + numRemove - size(array)) , Start-1

          tmp_arr(j) = array(i)
          j = j + 1

       end do

    end if

    deallocate(array)
    allocate(array(size(tmp_arr)))

    array = tmp_arr

  end subroutine resize_array

  subroutine DefineCluster( SitePotential, Sites, weakL, weakR, ClusterSize )
    implicit none

    ! Inputs
    real(dp), dimension(dim), intent(in) :: SitePotential
    integer, intent(in) :: weakL, weakR
    integer, intent(in) :: ClusterSize

    ! Outputs
    real(dp), dimension(ClusterSize), intent(out) :: Sites

    ! Other
    integer :: EndSite

    if ( (weakL .ge. weakR) .and. (ClusterSize .gt. 1) ) then !2, 3 site clusters which wrap around the "edge" of the system. As well as 4-site clusters with a single weak bond
       EndSite = dim - weakL
       Sites(1:EndSite) = SitePotential((weakL+1):dim)
       Sites((EndSite+1):ClusterSize) = SitePotential(1:weakR)
    else if ( ClusterSize .eq. 1 ) then !1-site clusters
       Sites = SitePotential(weakR:weakR)
    else if ( (ClusterSize .eq. dim) .and. (weakL .eq. 0) ) then !4-site clusters with no weak bonds
       Sites = SitePotential
    else !All other clusters
       Sites = SitePotential((weakL+1):weakR)
    end if

  end subroutine DefineCluster

  !     str(k) takes an integer k as input and returns a string with the same integer

  character(len=20) function str(k)
    integer, intent(in) :: k

    write (str, *) k
    str = adjustl(str)
  end function str

  !     FileNamer(Name) takes a base file name as input and adds a counter starting at 0 to the file name. If that exists, the counter is incremented by 1 (++)

  character(len=25) function FileNamer(Name)                                ! Increments filename labels Blah023.dat label:023
    character(len=25), intent(in) :: Name                                   ! Initial filename. Would be 'Blah' from above example
    integer num                                                             ! Keeps track of the label increment as this continues to check for name existence
    logical Exist                                                           ! Used to store if a filename exists

    Exist = .true.
    num = 0
    FileNamer = ""//trim(Name)//"000.text"                                  ! Takes Blah and puts it into the format 'Blah000.text'

    do while (Exist)                                                        ! Continue to change filename if the current one exists
       inquire( file = "output/"//trim(FileNamer)//"", exist = Exist )                           ! Checks the current folder (where this .f90 file is found) if the current filename exists
       if ( Exist ) then                                                    ! If the file name exists
          num = num + 1                                                     ! Increment the label

          if ( len(trim(str(num))) .eq. 1 ) then                            ! Labels can be from 000 to 999. To preserve filename length the leading zeros are required
             FileNamer = ""//trim(Name)//"00"//trim(str(num))//".text"      ! This if statement (and the one below) check the length of the label (1 has length 1, 23 has length 2, 450 has length 3)
          else if ( len(trim(str(num))) .eq. 2) then                        ! This determines the number of leading zeros to add to the filename label
             FileNamer = ""//trim(Name)//"0"//trim(str(num))//".text"
          else
             FileNamer = ""//trim(Name)//trim(str(num))//".text"
          end if

       else if ( .not. Exist ) then                                         ! If it does not exist. Note: Didn't increment 'num'
          if ( len(trim(str(num))) .eq. 1 ) then
             FileNamer = ""//trim(Name)//"00"//trim(str(num))//".text"
          else if ( len(trim(str(num))) .eq. 2) then
             FileNamer = ""//trim(Name)//"0"//trim(str(num))//".text"
          else
             FileNamer = ""//trim(Name)//trim(str(num))//".text"
          end if
          Exist = .false.
       else
          print*, "You belong in a museum. Error: FileNameErr"              ! Outputs error if something strange happens. Can't imagine what
       end if
    end do
  end function FileNamer

end module Tools


!Program to test SET_EXPONENT intrinsic function.

program test_set_exponent
  call test_real4()
  call test_real8()
end

subroutine test_real4()
  real*4 x,y
  integer*4 i,n
  equivalence(x, i)

  n = -148
  x = 1024.0
  y = set_exponent (x, n)
  if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()

  n = 8
  x = 1024.0
  y = set_exponent (x, n)
  if (exponent (y) .ne. n) call abort()

  n = 128
  i = 8388607
  x = transfer (i, x) ! z'007fffff' Positive denormalized floating-point.
  y = set_exponent (x, n)
  if (exponent (y) .ne. n) call abort()

  n = -148
  x = -1024.0
  y = set_exponent (x, n)
  if  ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()

  n = 8
  x = -1024.0
  y = set_exponent (x, n)
  if (y .ne. -128.0) call abort()
  if (exponent (y) .ne. n) call abort()

  n = 128
  i = -2139095041
  x = transfer (i, x) ! z'807fffff' Negative denormalized floating-point.
  y = set_exponent (x, n)
  if (exponent (y) .ne. n) call abort()

end

subroutine test_real8()
  implicit none
  real*8 x, y
  integer*8 i, n
  equivalence(x, i)

  n = -1073
  x = 1024.0_8
  y = set_exponent (x, n)
  if  ((y .ne. 0.0_8) .and. (exponent (y) .ne. n)) call abort()

  n = 8
  x = 1024.0_8
  y = set_exponent (x, n)
  if (y .ne. 128.0) call abort()
  if (exponent (y) .ne. n) call abort()

  n = 1024
  i = 4503599627370495_8
  x = transfer (i, x) !z'000fffffffffffff' Positive denormalized floating-point.
  y = set_exponent (x, n)
  if (exponent (y) .ne. n) call abort()

  n = -1073
  x = -1024.0
  y = set_exponent (x, n)
  if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort()

  n = 8
  x = -1024.0
  y = set_exponent (x, n)
  if (y .ne. -128.0) call abort()
  if (exponent (y) .ne. n) call abort()

  n = 1024
  i = -9218868437227405313_8
  x = transfer (i, x)!z'800fffffffffffff' Negative denormalized floating-point.
  y = set_exponent (x, n)
  if (exponent (y) .ne. n) call abort()
end


module auxilary_subroutines
implicit none
contains
!
!--------------------------------------------------------
! Combinations:
!-------------------------------------------------------
!
integer(kind=16) function combination_x_of_p(x,p)
implicit none
!
integer(kind=16), intent(in) :: x, p
integer(kind=16) :: diff, prod, x_fact, p_x_fact, i
!
diff = p - x
write(*,*) 'x', x, 'p', p
write(*,*) 'diff', diff
!
!--------------------
! p-x > x :
!--------------------
!
if (diff .ge. x) then
   write(*,*) 'p - x > x'
   prod = 1
   do i = 1, x
      prod = prod * (diff + i)
      write(*,*) 'prod', prod
   end do
   !
   if (x .ne. 0) then
      x_fact = 1
      do i = 1, x
         x_fact = x_fact * i
      end do
   end if
   if (x .eq. 0) then
      x_fact = 1
   end if
   !
   write(*,*) 'prod', prod
   write(*,*) 'x_fact', x_fact
   combination_x_of_p = prod/x_fact
   write(*,*) 'combination x of p', combination_x_of_p
!
!--------------------------
! p-x < x :
!--------------------------
!
else if (diff .lt. x) then
   write(*,*) 'x > p - x'
   prod = 1
   do i = 1, diff
      prod = prod * (x+i)
   end do
   !
   p_x_fact = 1
   do i = 1, p - x
      p_x_fact = p_x_fact * i
   end do
   !
   combination_x_of_p = prod/p_x_fact
end if
!
!-----------------------------------------------------------------
! example -> x .lt. p-x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 2
!   p - x = 6
!
!   x < p-x
!
!   6! 7 8            p-x+1 p-x+2
! -------------- = --------------------
!   6! 2!               x!
!
!-----------------------------------------------------------------
! example -> x .gt. p=x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 5
!   p - x = 3
!
!   5! 6 7 8        x+1 x+2 x+3
! ------------ = ------------------
!   5! 3!           p - x!
!
!
end function combination_x_of_p
!
!-----------------------------------------------------------------
!Subroutine to generate the distance matrix for a structure:
!-----------------------------------------------------------------
!
subroutine distance_matrix (a_matrix, a_atoms, dist_matrix)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: a_matrix
integer, intent(in) :: a_atoms
real(dp), allocatable, dimension(:,:), intent(out) :: dist_matrix
integer :: i, j
!
allocate(dist_matrix(a_atoms,a_atoms))
do i = 1, a_atoms
  do j = 1, a_atoms
     dist_matrix(i,j) = sqrt( (a_matrix(i,1)-a_matrix(j,1))**(2.) + &
       (a_matrix(i,2)-a_matrix(j,2))**(2.) + &
       (a_matrix(i,3)-a_matrix(j,3))**(2.) )
  end do
end do
!
write(*,*)'Distance matrix:'
write(*,*)'----------------------------------------'
!
do i = 1, a_atoms
  write(*,'(20F7.3)') (dist_matrix(i,j), j=1,a_atoms)
end do
!
end subroutine distance_matrix
!
!----------------------------------------------------------------
!Periodic system - read the mass for every atom in the molecule:
!----------------------------------------------------------------
!
subroutine periodic (labels_in, a, masses_out)
Implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
character(len=1), allocatable, dimension(:), intent(in) :: labels_in
integer :: a, i, k !number of atoms
real(dp), dimension(2) :: masses
character(len=1), dimension(2) :: atoms
real(dp), allocatable, dimension(:), intent(out) :: masses_out
!
atoms = (/'B', 'V'/)
masses = (/10.81, 50.9415/)
!
allocate ( masses_out(a) )
!
!-----------------------
!Assigning the masses:
!-----------------------
!
do i = 1, a
    do k = 1, 2
        if (labels_in(i) == atoms(k)) then
            masses_out(i) = masses(k)
        end if
    end do
end do
!
end subroutine periodic
!
!---------------------------------------------------------
!Calculate CPU time:
!---------------------------------------------------------
!
subroutine CPU (start, method15)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: start
character(len=17), intent(in) :: method15
real(dp) :: finish, cputime
!
call CPU_time(finish)
cputime = finish - start
write(25,*)
write(25,'(A18)') method15, ':'
write(25,*) 'CPU time:', cputime
!
end subroutine CPU
!
end module auxilary_subroutines


!********************************************************************************
!   HORNER_RUNERR: Test compensated Horner running error bound
!   Authors: Thomas R. Cameron and Aidan O'Neill
!   Institution: Davidson College, Mathematics and Computer Science Department
!   Last Modified: 29 March 2020
!********************************************************************************
program horner_runErr
    use eft
    use mproutines
    implicit none
    ! paramters
    integer, parameter              :: deg = 5, n = 2000
    real(kind=dp), parameter        :: dx = 1E-5_dp
    ! polynomial variables
    real(kind=dp), allocatable      :: poly(:), roots(:)
    complex(kind=dp), allocatable   :: cpoly(:), croots(:)
    ! testing variables
    integer                         :: k
    real(kind=dp)                   :: abound, comp, error, exact, g, rbound, x
    complex(kind=dp)                :: ccomp, cexact, z

    ! allocate polynomial variables
    allocate(poly(deg+1), roots(deg))
    roots = (/ (1.0_dp, k=1,deg)/)
	poly(deg+1) = 1.0_dp
    call rootCoeff(deg,roots,poly)
    ! open file
    open(unit=1,file="data_files/horner_runErr_real.dat")
    write(1,'(A)') 'x, a priori error bound, running error bound, forward error'
    ! run real test
    x = 0.99_dp
    do k=1,n+1
        ! multi-precision real Horner
        exact = MPHorner(poly,x,deg)
        ! compensated Horner and running error bound
        call CHorner(poly,x,deg,comp,rbound)
        ! a priori error bound
        g = 2*deg*mu/(1-2*deg*mu)
        abound = mu*abs(exact) + MPHorner(abs(poly),abs(x),deg)*g**2
        ! forward error
        error = CHornerErr(poly,x,deg,comp)
        ! write real test results
        write(1,'(ES15.5,A)', advance='no') x, ', '
        write(1,'(ES15.5,A)', advance='no') abound, ', '
        write(1,'(ES15.5,A)', advance='no') rbound, ', '
        write(1,'(ES15.5)') error
        ! update x
        x = x + dx
    end do
    ! deallocate polynomial variables
    deallocate(poly, roots)
    ! close file
    close(1)

    ! allocate polynomial variables
    allocate(cpoly(deg+1), croots(deg))
    croots = (/ (cmplx(1.0_dp,1.0_dp,kind=dp), k=1,deg)/)
	cpoly(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
    call rootCoeffCplx(deg,croots,cpoly)
    ! open file
    open(unit=1,file="data_files/horner_runErr_cmplx.dat")
    write(1,'(A)') 'x, a priori error bound, running error bound, forward error'
    ! run complex test
    z = cmplx(0.99_dp,1.0_dp,kind=dp)
    do k=1,n+1
        ! multi-precision complex Horner
        cexact = MPHornerCplx(cpoly,z,deg)
        ! compensated Horner and running error bound
        call CHornerCplx(cpoly,z,deg,ccomp,rbound)
        ! a priori error bound
        g = 2*mu/(1-2*mu)
        g = 2*deg*sqrt(2.0_dp)*g/(1-2*deg*sqrt(2.0_dp)*g)
        abound = mu*abs(cexact) + MPHorner(abs(cpoly),abs(z),deg)*g**2
        ! forward error
        error = CHornerErrCplx(cpoly,z,deg,ccomp)
        ! write real test results
        write(1,'(ES15.5,A)', advance='no') real(z), ', '
        write(1,'(ES15.5,A)', advance='no') abound, ', '
        write(1,'(ES15.5,A)', advance='no') rbound, ', '
        write(1,'(ES15.5)') error
        ! update z
        z = z + cmplx(dx,0,kind=dp)
    end do
    ! deallocate polynomial variables
    deallocate(cpoly, croots)
    ! close file
    close(1)
contains

    !****************************************************
    !                       Horner Sum                  *
    !****************************************************
    ! Computes the evaluation of the sum of two
    ! polynomials of degree (deg-1), at a floating-point
    ! number. Result is returned in comp which has type
    ! real(kind=dp).
    !****************************************************
    function HSum(p,q,x,deg) result(comp)
        implicit none
        ! argument variables
        integer             :: deg
        real(kind=dp)       :: p(:), q(:), x
        ! local variables
        integer             :: k
        real(kind=dp)       :: comp

        ! Horner's method
        comp = p(deg) + q(deg)
        do k=deg-1,1,-1
            comp = x*comp + (p(k) + q(k))
        end do
        return
    end function HSum
    !****************************************************
    !                       HornerSumCplx               *
    !****************************************************
    ! Computes the evaluation of the sum of four
    ! complex polynomials of degree deg-1, at a complex
    ! floating-point number. Result is returned in comp
    ! which has type complex(kind=dp).
    !****************************************************
    function HSumCplx(p,q,r,s,x,deg) result(comp)
        implicit none
        ! argument variables
        integer             :: deg
        complex(kind=dp)    :: p(:), q(:), r(:), s(:), x
        ! local variables
        integer             :: k
        complex(kind=dp)    :: comp

        ! Horner's method
        comp = FaithSumCplx(p(deg),q(deg),r(deg),s(deg))
        do k=deg-1,1,-1
            comp = x*comp + FaithSumCplx(p(k),q(k),r(k),s(k))
        end do
        return
    end function HSumCplx
    !****************************************************
    !              Compensated Horner                   *
    !****************************************************
    ! Computes the evaluation of a polynomial at
    ! a floating point number using the compensated
    ! Horner routine. The result is stored in comp and the
    ! running relative forward error is stored in error.
    !****************************************************
    subroutine CHorner(poly,x,deg,comp,error)
        implicit none
        ! argument variables
        integer, intent(in)         :: deg
        real(kind=dp), intent(in)   :: poly(:), x
        real(kind=dp), intent(out)  :: comp, error
        ! local variables
        real(kind=dp)               :: g
        type(REFTHorner)            :: eft

        ! compute EFTHorner
        eft = EFTHorner(poly,x,deg)
        ! compute error using HSum and add back to result
        comp = eft%h + HSum(eft%p,eft%q,x,deg)
        !  compute running forward error
        g = (4*deg+2)*mu/(1-(4*deg+2)*mu)
        error = mu*abs(comp) + (2*mu**2*abs(comp) + g*HSum(abs(eft%p),abs(eft%q),abs(x),deg))
        ! deallocate error polynomials in eft
        deallocate(eft%p,eft%q)
    end subroutine CHorner
    !****************************************************
    !              Compensated Horner Cplx              *
    !****************************************************
    ! Computes the evaluation of a polynomial at
    ! a floating point number using the compensated
    ! Horner routine. The result is stored in comp and the
    ! running relative forward error is stored in error.
    !****************************************************
    subroutine CHornerCplx(poly,x,deg,comp,error)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: poly(:), x
        real(kind=dp), intent(out)      :: error
        complex(kind=dp), intent(out)   :: comp
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: g
        type(CEFTHorner)                :: eft

        ! compute EFTHornerCplx
        eft = EFTHornerCplx(poly,x,deg)
        ! compute error using HSumCplx and add back to result
        comp = eft%h + HSumCplx(eft%p,eft%q,eft%r,eft%s,x,deg)
        !  compute running forward error
        g = 2*mu/(1-2*mu)
        g = (4*deg+2)*sqrt(2.0_dp)*g/(1-(4*deg+2)*sqrt(2.0_dp)*g)
        error = FaithSum(abs(eft%p(deg)),abs(eft%q(deg)),abs(eft%r(deg)),abs(eft%s(deg)))
        do k=deg-1,1,-1
            error = abs(x)*error + FaithSum(abs(eft%p(k)),abs(eft%q(k)),abs(eft%r(k)),abs(eft%s(k)))
        end do
        error = mu*abs(comp) + (g*error + 2*mu**2*abs(comp))
        ! deallocate error polynomials in eft
        deallocate(eft%p,eft%q,eft%r,eft%s)
    end subroutine CHornerCplx
    !****************************************************
    !              Compensated Horner Error             *
    !****************************************************
    ! Compute error in compensated Horner evaluation vs.
    ! MP Horner evaluation.
    !****************************************************
    function CHornerErr(poly,x,deg,comp) result(err)
        implicit none
        ! argument variables
        integer                 :: deg
        real(kind=dp)           :: poly(:), x, comp
        ! local variables
        integer                 :: k
        real(kind=dp)           :: err
        type(mp_real)           :: mp_comp, mp_err, mp_horner, mp_poly(deg+1), mp_x

        ! convert to mp-type
        mp_comp = mpreald(comp)
        do k=1,deg+1
            mp_poly(k) = mpreald(poly(k))
        end do
        mp_x = mpreald(x)
        ! Horner's method
        mp_horner = mp_poly(deg+1)
        do k=deg,1,-1
            mp_horner = mp_x*mp_horner + mp_poly(k)
        end do
        ! error
        mp_err = abs(mp_comp - mp_horner)
        ! convert to dp-precision
        err = mpreal(mp_err)
    end function CHornerErr
    !****************************************************
    !              Compensated Horner Error Cplx        *
    !****************************************************
    ! Compute error in compensated Horner evaluation vs.
    ! MP Horner evaluation.
    !****************************************************
    function CHornerErrCplx(poly,x,deg,comp) result(err)
        implicit none
        ! argument variables
        integer                 :: deg
        complex(kind=dp)        :: poly(:), x, comp
        ! local variables
        integer                 :: k
        real(kind=dp)           :: err
        type(mp_real)           :: mp_err
        type(mp_complex)        :: mp_comp, mp_horner, mp_poly(deg+1), mp_x

        ! convert to mp-type
        mp_comp = mpcmplxdc(comp)
        do k=1,deg+1
            mp_poly(k) = mpcmplxdc(poly(k))
        end do
        mp_x = mpcmplxdc(x)
        ! Horner's method
        mp_horner = mp_poly(deg+1)
        do k=deg,1,-1
            mp_horner = mp_x*mp_horner + mp_poly(k)
        end do
        ! error
        mp_err = abs(mp_comp - mp_horner)
        ! convert to dp-precision
        err = mpreal(mp_err)
    end function CHornerErrCplx
end program horner_runErr


c...............................................
      function ylag(xi,x,y,ind1,n1,imax,iex)
c
c     lagrangian interpolation
c   modified from subroutine polint from Numerical Recipe, by Press et al.
c     xi is intepolated entry into x-array
c     n is the order of lagrangran interpolation
c     y is array from which ylag is obtained by interpolation
c     ind is the min-i for x(i).gt.xi
c     if ind=0,x-array will be searched
c     imax is max index of x-and y-arrays
c     extrapolation can occur,iex=-1 or +1
c
      implicit real*8(a-h,o-z)
      parameter(nmax=10)
      real*8 x(*),y(*)
      real*8 c(nmax),d(nmax),dx(nmax)
c
      ind=ind1
      n=n1
      iex=0
      if (n.le.imax) go to 10
      n=imax
      iex=n
   10 if (ind.gt.0) go to 40
      do 20 j = 1,imax
         if (xi-x(j) .lt. 0.0) goto 30
         if (xi-x(j) .eq. 0.0) goto 130
   20 continue
      iex=1
      go to 70
   30 ind=j
   40 if (ind.le.1) iex=-1
      inl=max(0,ind-ishft(n+1,-1))
      inu=inl+n
      if (inu.le.imax) go to 80
   70 inl=imax-n
      inu=imax
   80 dif=abs(xi-x(inl+1))
      ns=1
      do 105 j=1,inu-inl
	 j1=j+inl
	 dx(j)=xi-x(j1)
         dift=abs(dx(j))
         if(dift.lt.dif) then
           ns=j
           dif=dift
         endif
         c(j)=y(j1)
         d(j)=y(j1)
  105 continue
      ylag=y(inl+ns)
      ns=ns-1
      do 110 j=inl+1,inu-1
         do 100 i=1,inu-j
	    ij=i+j
            den=x(i+inl)-x(ij)
            if(den.eq.0.d0) stop'Two xs are the same in ylag.'
            den=(d(i)-c(i+1))/den
            d(i)=dx(ij-inl)*den
            c(i)=dx(i)*den
  100    continue
         if(ishft(ns,1).lt.inu-j) then
           ylag=ylag+c(2*ns+1)
         else
           ylag=ylag+d(ns)
           ns=ns-1
         endif
  110 continue
      return
  130 ylag=y(j)
      return
      end


program do_cycle

   implicit none

   integer :: i
   real, parameter :: pi = 3.141592653
   real :: x, y

   do i = 0, 360, 10
      x = cos(real(i)*pi/180)
      y = sin(real(i)*pi/180)

      if (abs(x) < 1E-7) then
         print *, "Small denominator (cycle)"
         cycle
      end if
      print *, i, x, y, y/x
   end do

   print *, 'Final values:', i, x

end program


      SUBROUTINE crank(n,w,s)
      INTEGER n
      REAL s,w(n)
      INTEGER j,ji,jt
      REAL rank,t
      s=0.
      j=1
1     if(j.lt.n)then
        if(w(j+1).ne.w(j))then
          w(j)=j
          j=j+1
        else
          do 11 jt=j+1,n
            if(w(jt).ne.w(j))goto 2
11        continue
          jt=n+1
2         rank=0.5*(j+jt-1)
          do 12 ji=j,jt-1
            w(ji)=rank
12        continue
          t=jt-j
          s=s+t**3-t
          j=jt
        endif
      goto 1
      endif
      if(j.eq.n)w(n)=n
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/crank.for


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hstplr

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter :: M = 50, N = 48
    integer(ip), parameter :: IDIMF = M + 1, NP1 = N + 1
    integer(ip)            :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)               :: f(IDIMF, NP1)
    real(wp), dimension(N) :: bdb, theta
    real(wp), dimension(M) :: bdc, bdd, r
    real(wp)               :: a, b, c, d, bda(1), dr, dtheta
    real(wp)               :: elmbda, pertrb
    real(wp), parameter    :: ZERO = 0.0_wp, HALF = 0.5_wp
    real(wp), parameter    :: ONE = 1.0_wp, FOUR = 4.0_wp

    ! Set domain
    a = ZERO
    b = ONE
    c = ZERO
    d = HALF_PI

    ! Set boundary conditions
    mbdcnd = 5
    nbdcnd = 3

    ! Set helmholtz constant
    elmbda = ZERO

    ! Set mesh sizes
    dr = (b - a)/M
    dtheta = (d - c)/N

    ! Generate and store grid points for the purpose of computing
    ! boundary data and the right side of the poisson equation.
    do i = 1, M
        r(i) = (real(i, kind=wp) - HALF) * dr
    end do

    do j = 1, N
        theta(j) = (real(j, kind=wp) - HALF) * dtheta
    end do

    ! Generate boundary data. In our example, bda is a 1-dimensional dummy variable.
    bdb = ONE - cos(FOUR*theta)
    bdc = ZERO
    bdd = ZERO

    ! Generate right side of equation.
    block
        real(wp), parameter :: SIXTEEN = 16.0_wp

        do i = 1, M
            f(i, :N) = SIXTEEN * r(i)**2
        end do
    end block

    ! Solve 2D Helmholtz in polar coordinates on staggered grid
    call hstplr(a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, bdd, &
        elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error.  the exact solution is
    !
    ! u(r, theta) = r**4*(1 - cos(4*theta))
    block
        real(wp), parameter :: KNOWN_ERROR = 0.113037945648764e-2_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M,N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (r(i)**4) * (ONE - cos(FOUR * theta(j)))
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:M,:N)))

        call check_output('hstplr', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_hstplr


program bmi
        implicit none
        real :: height, weight

        print *, 'Weight, please! (in kg)'
        read (*,*) weight

        print *, 'Now, your height (in m)'
        read(*,*) height

        write(*,'(A, F10.2') 'Your bmi is ',  (weight / (height**2))
end program bmi


module linalg
  contains
function expm(a)
  ! ----------------------------------------------------------------------- !
  real(kind=8) :: expm(3,3)
  real(kind=8), intent(in) :: a(3,3)
  integer, parameter :: m=3, ldh=3, ideg=6, lwsp=4*m*m+ideg+1
  integer, parameter :: n=3, lwork=3*n-1
  real(kind=8) :: t, wsp(lwsp), v(3,3)
  real(kind=8) :: w(n), work(lwork), l(3,3)
  integer :: ipiv(m), iexph, ns, iflag, info
  character*120 :: msg
  ! ----------------------------------------------------------------------- !
  expm = 0.e+00_8
  if (all(abs(a) <= epsilon(a))) then
     expm = eye(3)
     return
  else if (isdiag(a)) then
     expm(1,1) = exp(a(1,1))
     expm(2,2) = exp(a(2,2))
     expm(3,3) = exp(a(3,3))
     return
  end if

  ! try dgpadm (usually good)
  t = 1.e+00_8
  iflag = 0
  call DGPADM(ideg, m, t, a, ldh, wsp, lwsp, ipiv, iexph, ns, iflag)
  if (iflag >= 0) then
     expm = reshape(wsp(iexph:iexph+m*m-1), shape(expm))
     return
  end if

  ! problem with dgpadm, use other method
  if (iflag == -8) then
     msg = '*** ERROR: bad sizes (in input of DGPADM)'
  else if (iflag == -9) then
     msg = '*** ERROR: Error - null H in input of DGPADM.'
  else if (iflag == -7) then
     msg = '*** ERROR: Problem in DGESV (within DGPADM)'
  end if
  print*, msg
  stop

  v = a
  call DSYEV("V", "L", 3, v, 3, w, work, lwork, info)
  l = 0.e+00_8
  l(1,1) = exp(w(1))
  l(2,2) = exp(w(2))
  l(3,3) = exp(w(3))
  expm = matmul(matmul(v, l ), transpose(v))
  return
end function expm

! ------------------------------------------------------------------------- !
function powm(a, m)
  ! ----------------------------------------------------------------------- !
  ! Computes the matrix power
  ! ----------------------------------------------------------------------- !
  real(kind=8) :: powm(3,3)
  real(kind=8), intent(in) :: a(3,3), m
  integer, parameter :: n=3, lwork=3*n-1
  real(kind=8) :: w(n), work(lwork), v(3,3), l(3,3)
  integer :: info
  ! eigenvalues/vectors of a
  v = a
  powm = 0.e+00_8
  if (isdiag(a)) then
     powm(1,1) = a(1,1) ** m
     powm(2,2) = a(2,2) ** m
     powm(3,3) = a(3,3) ** m
  else
     call DSYEV("V", "L", 3, v, 3, w, work, lwork, info)
     l = 0.e+00_8
     l(1,1) = w(1) ** m
     l(2,2) = w(2) ** m
     l(3,3) = w(3) ** m
     powm = matmul(matmul(v, l ), transpose(v))
  end if
  return
end function powm

! ------------------------------------------------------------------------- !
function sqrtm(a)
  ! ----------------------------------------------------------------------- !
  ! Computes the matrix sqrt
  ! ----------------------------------------------------------------------- !
  real(kind=8) :: sqrtm(3,3)
  real(kind=8), intent(in) :: a(3,3)
  integer, parameter :: n=3, lwork=3*n-1
  real(kind=8) :: w(n), work(lwork), v(3,3), l(3,3)
  integer :: info
  sqrtm = 0.e+00_8
  if (isdiag(a)) then
     sqrtm(1,1) = sqrt(a(1,1))
     sqrtm(2,2) = sqrt(a(2,2))
     sqrtm(3,3) = sqrt(a(3,3))
  else
     ! eigenvalues/vectors of a
     v = a
     call DSYEV("V", "L", 3, v, 3, w, work, lwork, info)
     l = 0.e+00_8
     l(1,1) = sqrt(w(1))
     l(2,2) = sqrt(w(2))
     l(3,3) = sqrt(w(3))
     sqrtm = matmul(matmul(v, l ), transpose(v))
  end if
  return
end function sqrtm

! ------------------------------------------------------------------------- !
function logm(a)
  ! ----------------------------------------------------------------------- !
  ! Computes the matrix logarithm
  ! ----------------------------------------------------------------------- !
  real(kind=8) :: logm(3,3)
  real(kind=8), intent(in) :: a(3,3)
  integer, parameter :: n=3, lwork=3*n-1
  real(kind=8) :: w(n), work(lwork), v(3,3), l(3,3)
  integer :: info
  if (isdiag(a)) then
     logm = 0.e+00_8
     logm(1,1) = log(a(1,1))
     logm(2,2) = log(a(2,2))
     logm(3,3) = log(a(3,3))
  else
     ! eigenvalues/vectors of a
     v = a
     call DSYEV("V", "L", 3, v, 3, w, work, lwork, info)
     l = 0.e+00_8
     l(1,1) = log(w(1))
     l(2,2) = log(w(2))
     l(3,3) = log(w(3))
     logm = matmul(matmul(v, l), transpose(v))
  end if
  return
end function logm

! ------------------------------------------------------------------------- !
function isdiag(a)
  logical :: isdiag
  real(kind=8), intent(in) :: a(3,3)
  isdiag = all(abs((/a(1,2),a(1,3),a(2,1),a(2,3),a(3,1),a(3,2)/)) <= epsilon(a))
  return
end function isdiag

function eye(n)
  integer, intent(in) :: n
  real(kind=8) :: eye(n,n)
  integer :: i
  eye = 0.e+00_8
  forall(i=1:n) eye(i,i) = 1.e+00_8
  return
end function eye

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

function det(a)
  ! ----------------------------------------------------------------------- !
  ! determinant of 3x3
  ! ----------------------------------------------------------------------- !
  implicit none
  real(kind=8) :: det
  real(kind=8), intent(in) :: a(3,3)
  det = a(1,1)*a(2,2)*a(3,3)  &
       - a(1,1)*a(2,3)*a(3,2)  &
       - a(1,2)*a(2,1)*a(3,3)  &
       + a(1,2)*a(2,3)*a(3,1)  &
       + a(1,3)*a(2,1)*a(3,2)  &
       - a(1,3)*a(2,2)*a(3,1)
  return
end function det

! ------------------------------------------------------------------------- !
function inv(a)
  ! ----------------------------------------------------------------------- !
  ! inverse of 3x3
  ! ----------------------------------------------------------------------- !
  implicit none
  real(kind=8) :: inv(3,3)
  real(kind=8), intent(in)  :: a(3,3)
  real(kind=8) :: deta
  real(kind=8) :: cof(3,3)
  deta = det(a)
  if (abs(deta) .le. epsilon(deta)) then
     inv = 0.e+00_8
     stop "non-invertible matrix sent to inv"
  end if
  cof(1,1) = +(a(2,2)*a(3,3)-a(2,3)*a(3,2))
  cof(1,2) = -(a(2,1)*a(3,3)-a(2,3)*a(3,1))
  cof(1,3) = +(a(2,1)*a(3,2)-a(2,2)*a(3,1))
  cof(2,1) = -(a(1,2)*a(3,3)-a(1,3)*a(3,2))
  cof(2,2) = +(a(1,1)*a(3,3)-a(1,3)*a(3,1))
  cof(2,3) = -(a(1,1)*a(3,2)-a(1,2)*a(3,1))
  cof(3,1) = +(a(1,2)*a(2,3)-a(1,3)*a(2,2))
  cof(3,2) = -(a(1,1)*a(2,3)-a(1,3)*a(2,1))
  cof(3,3) = +(a(1,1)*a(2,2)-a(1,2)*a(2,1))
  inv = transpose(cof) / deta
  return
end function inv

subroutine polar_decomp(F, R, U, ierr)
  implicit none
  real(kind=8), intent(in) :: F(3,3)
  real(kind=8), intent(out) :: R(3,3), U(3,3)
  integer, intent(out) :: ierr
  real(kind=8) :: I(3,3)
  integer :: j
  I = eye(3)
  R = F
  ierr = 0
  do j = 1, 20
     R = .5 * matmul(R, 3. * I - matmul(transpose(R), R))
     if (maxval(abs(matmul(transpose(R), R) - I)) < 1.e-6_8) then
        U = matmul(transpose(R), F)
        return
     end if
  end do
  ierr = 1
end subroutine polar_decomp
end module linalg