submodule(euler_interface_m) euler_prob_0046_m
    implicit none

contains

    module character(len=20) function euler0046()
        write (euler0046, "(i20)") ans(10000)
    end function euler0046

    integer function ans(n)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none
        integer, intent(in) :: n
        integer :: j, res
        logical :: not_found
        logical, allocatable :: is_prime(:)

        call sieve_of_Eratosthenes(n, is_prime)
        res = 1; not_found = .true.

        outer: do while (not_found)
            res = res + 2
            j = 2
            not_found = .false.

            inner: do while (res >= j)
                if (is_prime(j) .and. is_twice_square(res - j)) then
                    not_found = .true.
                    exit inner
                end if
                j = j + 1
            end do inner
        end do outer

        ans = res
    end function ans

    logical function is_twice_square(n)
        integer, intent(in) :: n
        real(dp) :: sqrt_nover2

        is_twice_square = .false.
        sqrt_nover2 = sqrt(0.5_dp*real(n, dp))

        if (sqrt_nover2 - real(floor(sqrt_nover2), dp) < tiny_dp) &
            is_twice_square = .true.
    end function is_twice_square

end submodule euler_prob_0046_m


program test

use, intrinsic:: ieee_arithmetic
use lineclip,only: Ccohensutherland, cohensutherland
use assert, only: wp, assert_isclose

implicit none

call test_lineclip()
call test_array_lineclip()

contains

subroutine test_array_lineclip()

integer, parameter :: Np=2
real(wp), dimension(Np) :: length, x1,x2,y1,y2
real(wp),parameter :: xmin=1., ymax=5.,xmax=4., ymin=3.
real(wp),parameter :: truelength(Np) =[2.40370083, 3.]

x1=[0.,0.]
y1=[0.,4.]
x2=[4.,5.]
y2=[6.,4.]

call Ccohensutherland(xmin,ymax,xmax,ymin,Np,x1,y1,x2,y2)

length = hypot((x2-x1), (y2-y1))
call assert_isclose(length, truelength)

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

call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)

length = hypot((x2-x1), (y2-y1))
call assert_isclose(length, truelength)

print *, 'OK array_lineclip'

end subroutine test_array_lineclip

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

subroutine test_lineclip()

real(wp), parameter :: xmin=1., ymax=5., xmax=4., ymin=3.
real(wp) :: x1, y1, x2, y2  !not a parameter

!    make box with corners LL/UR (1,3) (4,5)
!    and line segment with ends (0,0) (4,6)

! LOWER to UPPER test
x1=0.; y1=0.; x2=4.; y2=6.

call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)

call assert_isclose(x1, 2._wp)
call assert_isclose(y1, 3._wp)
call assert_isclose(x2, 3.3333333_wp)
call assert_isclose(y2, 5._wp)

! no intersection test
x1=0.;y1=0.1;x2=0.;y2=0.1

call cohensutherland(xmin,ymax,xmax,ymin,x1,y1,x2,y2)
if (.not.all(ieee_is_nan([x1,y1,x2,y2]))) error stop 'failed no intersection test'

print *, 'OK lineclip'

end subroutine test_lineclip

end program


program tri_ppal

implicit none

real(8), dimension(:), allocatable :: a,b,c,r

integer :: n, i, j

print*, 'Introduce o orde do sistema: '
read*, n
print*
print*, 'O orde introducido e: ', n
print*

allocate(a(n), b(n-1), c(2:n), r(n))

print*,
print*, 'Introduce a diagonal principal: '
read*, a(1:n)
print*,

print*,
print*, 'Introduce a diagonal superior: '
read*, b(1:n-1)
print*,

print*,
print*, 'Introduce a diagonal inferior: '
read*, c(2:n)
print*,
allocate(a(n), b(n-1), c(2:n), r(n))
print*,
print*, 'Introduce el segundo miembro: '
read*, r(1:n)
print*,

print*,
print*, 'Diagonal principal: ',a(1:n)
print*, 'Diagonal superior: ', b(1:n-1)
print*, 'Diagonal inferior ', c(2:n)
print*, 'Segundo miembro: ',r(1:n)
print*,

do i =2,n
  c(i)=c(i)/a(i-1)
  a(i)=a(i)-c(i)*b(i-1)
end do

do i=2,n
  r(i)=r(i)-c(i)*r(i-1)
end do

r(n)=r(n)/a(n)

do i=n-1,1,-1
  r(i)= (r(i)-b(i)*r(i+1))/a(i)
end do

print*,
print*, 'Vector r (Solucion): '
print*,

print*,
print*, r
print*,

end program


module global_module

! This module contains data needed throughout the program.
! Most data is specified as a parameter, as to make the execution faster.
! This module is loaded by most other modules.

  implicit none

  ! Time integration

  !!! For Euler !!! real(kind=8), parameter :: dt    = 1.0d-7 ! [s] time step for the simulation
  !!! For Euler !!! real(kind=8), parameter :: t_end = 1.0d-2 ! [s] total simulated time (from 0 to t_end)

  real(kind=8), parameter :: dt    = 1.0d-4 ! [s] time step for the simulation
  real(kind=8), parameter :: t_end = 10.0d0 ! [s] total simulated time (from 0 to t_end)

  ! Specify domain and discretization

  real(kind=8), parameter :: x_min = -1.0 ! [m]
  real(kind=8), parameter :: x_max = 2.0  ! [m]
  real(kind=8), parameter :: y_min = -1.0 ! [m]
  real(kind=8), parameter :: y_max = 1.0  ! [m]

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 500
  integer, parameter :: Ny = 500

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4)
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4)

end module


C
C NLP-UNCONSTRAINED-CLI/HOOKE-JEEVES/F77/SRC/HOOKE.F
C =============================================================================
C NONLINEAR OPTIMIZATION ALGORITHMS MULTILANG. VERSION 0.1
C =============================================================================
C NONLINEAR PROGRAMMING ALGORITHMS AS THE (UN-)CONSTRAINED MINIMIZATION
C PROBLEMS WITH THE FOCUS ON THEIR NUMERICAL EXPRESSION USING VARIOUS
C PROGRAMMING LANGUAGES.
C
C THIS IS THE HOOKE AND JEEVES NONLINEAR UNCONSTRAINED MINIMIZATION ALGORITHM.
C =============================================================================
C WRITTEN BY RADISLAV (RADICCHIO) GOLUBTSOV, 2015-2020
C
C THIS IS FREE AND UNENCUMBERED SOFTWARE RELEASED INTO THE PUBLIC DOMAIN.
C
C ANYONE IS FREE TO COPY, MODIFY, PUBLISH, USE, COMPILE, SELL, OR
C DISTRIBUTE THIS SOFTWARE, EITHER IN SOURCE CODE FORM OR AS A COMPILED
C BINARY, FOR ANY PURPOSE, COMMERCIAL OR NON-COMMERCIAL, AND BY ANY
C MEANS.
C
C (SEE THE LICENSE FILE AT THE TOP OF THE SOURCE TREE.)
C

C     === THE USER-SUPPLIED OBJECTIVE FUNCTION F(X,N).
      FUNCTION F(X, N)
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 250)

C         RETURN VAL. THE OBJECTIVE FUNCTION VALUE.
          DOUBLE PRECISION F

C         ARG. THE POINT AT WHICH F(X) SHOULD BE EVALUATED.
          DOUBLE PRECISION X(VARS)

C         ARG. THE NUMBER OF COORDINATES OF X.
          INTEGER N

C         GLOB. THE NUMBER OF FUNCTION EVALUATIONS.
          INTEGER FUNEVA
          COMMON  FUNEVA

#ifndef WOODS
C     ROSENBROCK'S CLASSIC PARABOLIC VALLEY ('BANANA') FUNCTION.
          DOUBLE PRECISION A
          DOUBLE PRECISION B
          DOUBLE PRECISION C

          FUNEVA = FUNEVA + 1

          A = X(1)
          B = X(2)

          C = 100.0 * (B - (A * A)) * (B - (A * A))

          F = C + ((1.0 - A) * (1.0 - A))
#else
C     WOODS -- A LA MORE, GARBOW AND HILLSTROM (TOMS ALGORITHM 566).
          DOUBLE PRECISION S1
          DOUBLE PRECISION S2
          DOUBLE PRECISION S3
          DOUBLE PRECISION T1
          DOUBLE PRECISION T2
          DOUBLE PRECISION T3
          DOUBLE PRECISION T4
          DOUBLE PRECISION T5

          FUNEVA = FUNEVA + 1

          S1 = X(2) - X(1) * X(1)
          S2 = 1    - X(1)
          S3 = X(2) - 1

          T1 = X(4) - X(3) * X(3)
          T2 = 1    - X(3)
          T3 = X(4) - 1

          T4 = S3 + T3
          T5 = S3 - T3

          F = 100 * (S1 * S1) + S2 * S2
     *       + 90 * (T1 * T1) + T2 * T2
     *       + 10 * (T4 * T4) + T5 * T5 / 10.
#endif

          IF (N .EQ. 0) THEN
              PRINT 10
10            FORMAT ('WARNING: THE NUMBER OF COORDINATES OF X = 0.')
          END IF

          RETURN
      END

C     === HELPER FUNCTION.
C     GIVEN A POINT, LOOK FOR A BETTER ONE NEARBY, ONE COORD AT A TIME.
      FUNCTION BEST_N(DELTA, POINT, PREVBE, NVARS)
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 250)

C         RETURN VAL. THE OBJECTIVE FUNCTION VALUE AT A NEARBY.
          DOUBLE PRECISION BEST_N

C         ARG. THE DELTA BETWEEN PREVBE AND POINT.
          DOUBLE PRECISION DELTA(VARS)

C         ARG. THE COORDINATE FROM WHERE TO BEGIN.
          DOUBLE PRECISION POINT(VARS)

C         ARG. THE PREVIOUS BEST-VALUED COORDINATE.
          DOUBLE PRECISION PREVBE

C         ARG. THE NUMBER OF VARIABLES.
          INTEGER NVARS

          DOUBLE PRECISION MINF
          DOUBLE PRECISION Z(VARS)
          DOUBLE PRECISION FTMP

          INTEGER I

C         PROTO REF. THE OBJECTIVE FUNCTION F(X,N).
          DOUBLE PRECISION F

          MINF = PREVBE

          DO 10 I = 1, NVARS
              Z(I) = POINT(I)
10        CONTINUE

          DO 20 I = 1, NVARS
              Z(I) = POINT(I) + DELTA(I)

              FTMP = F(Z, NVARS)

              IF (FTMP .LT. MINF) THEN
                  MINF = FTMP
              ELSE
                  DELTA(I) = 0.0 - DELTA(I)
                  Z(I)     = POINT(I) + DELTA(I)

                  FTMP = F(Z, NVARS)

                  IF (FTMP .LT. MINF) THEN
                      MINF = FTMP
                  ELSE
                      Z(I) = POINT(I)
                  END IF
              END IF
20        CONTINUE

          DO 30 I = 1, NVARS
              POINT(I) = Z(I)
30        CONTINUE

          BEST_N = MINF

          RETURN
      END

C     === MAIN OPTIMIZATION FUNCTION.
C     THE HOOKE SUBROUTINE ITSELF.
      FUNCTION HOOKE(NVARS, STARTP, ENDPT, RHO, EPSILO, ITERMA)
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 250)

C         RETURN VAL. THE NUMBER OF ITERATIONS USED TO FIND THE LOCAL MINIMUM.
          INTEGER HOOKE

C         ARG. THE NUMBER OF VARIABLES.
          INTEGER NVARS

C         ARG. THE STARTING POINT COORDINATES.
          DOUBLE PRECISION STARTP(VARS)

C         ARG. THE ENDING POINT COORDINATES.
          DOUBLE PRECISION ENDPT(VARS)

C         ARG. THE RHO VALUE.
          DOUBLE PRECISION RHO

C         ARG. THE EPSILON VALUE.
          DOUBLE PRECISION EPSILO

C         ARG. THE MAXIMUM NUMBER OF ITERATIONS.
          INTEGER ITERMA

          INTEGER I
          INTEGER IADJ
          INTEGER ITERS
          INTEGER J
          INTEGER KEEP

          DOUBLE PRECISION NEWX(VARS)
          DOUBLE PRECISION XBEFOR(VARS)
          DOUBLE PRECISION DELTA(VARS)
          DOUBLE PRECISION STEPLE
          DOUBLE PRECISION FBEFOR
          DOUBLE PRECISION NEWF
          DOUBLE PRECISION TMP

C         GLOB. THE NUMBER OF FUNCTION EVALUATIONS.
          INTEGER FUNEVA
          COMMON  FUNEVA

C         PROTO REF. THE OBJECTIVE FUNCTION F(X,N).
          DOUBLE PRECISION F

C         PROTO REF. THE HELPER FUNCTION BEST_NEARBY(...).
          DOUBLE PRECISION BEST_N

          DO 10 I = 1, NVARS
              XBEFOR(I) = STARTP(I)
              NEWX(I)   = XBEFOR(I)

              DELTA(I) = ABS(STARTP(I) * RHO)

              IF (DELTA(I) .EQ. 0.0) THEN
                  DELTA(I) = RHO
              END IF
10        CONTINUE

          IADJ   = 0
          STEPLE = RHO
          ITERS  = 0

          FBEFOR = F(NEWX, NVARS)

          NEWF = FBEFOR

120       IF ((ITERS .LT. ITERMA) .AND. (STEPLE .GT. EPSILO)) THEN
              ITERS = ITERS + 1
              IADJ  = IADJ + 1

              PRINT 20, FUNEVA, FBEFOR
20            FORMAT (/, 'After ', I5, ' funevals, f(x) =  ', 1PE10.4E2,
     *                ' at')

              DO 30 J = 1, NVARS
                  PRINT 40, J - 1, XBEFOR(J)
40                FORMAT ('   x[', I2, '] = ', 1PE11.4E2)
30            CONTINUE

C             FIND BEST NEW POINT, ONE COORD AT A TIME.
              DO 50 I = 1, NVARS
                  NEWX(I) = XBEFOR(I)
50            CONTINUE

              NEWF = BEST_N(DELTA, NEWX, FBEFOR, NVARS)

C             IF WE MADE SOME IMPROVEMENTS, PURSUE THAT DIRECTION.
              KEEP = 1

100           IF ((NEWF .LT. FBEFOR) .AND. (KEEP .EQ. 1)) THEN
                  IADJ = 0

                  DO 60 I = 1, NVARS
C                     FIRSTLY, ARRANGE THE SIGN OF DELTA().
                      IF (NEWX(I) .LE. XBEFOR(I)) THEN
                          DELTA(I) = 0.0 - ABS(DELTA(I))
                      ELSE
                          DELTA(I) = ABS(DELTA(I))
                      END IF

C                     NOW, MOVE FURTHER IN THIS DIRECTION.
                      TMP       = XBEFOR(I)
                      XBEFOR(I) = NEWX(I)
                      NEWX(I)   = NEWX(I) + NEWX(I) - TMP
60                CONTINUE

                  FBEFOR = NEWF

                  NEWF = BEST_N(DELTA, NEWX, FBEFOR, NVARS)

C                 IF THE FURTHER (OPTIMISTIC) MOVE WAS BAD....
                  IF (NEWF .GE. FBEFOR) THEN
                      GO TO 70
                  END IF

C                 MAKE SURE THAT THE DIFFERENCES BETWEEN THE NEW AND THE OLD
C                 POINTS ARE DUE TO ACTUAL DISPLACEMENTS; BEWARE OF ROUNDOFF
C                 ERRORS THAT MIGHT CAUSE NEWF < FBEFOR.
                  KEEP = 0

                  DO 80 I = 1, NVARS
                      KEEP = 1

                      IF (ABS(NEWX(I) - XBEFOR(I))
     *                    .GT. (0.5 * ABS(DELTA(I)))) THEN

                          GO TO 90
                      ELSE
                          KEEP = 0
                      END IF
80                CONTINUE

90                GO TO 100
70            END IF

              IF ((STEPLE .GE. EPSILO) .AND. (NEWF .GE. FBEFOR)) THEN
                  STEPLE = STEPLE * RHO

                  DO 110 I = 1, NVARS
                      DELTA(I) = DELTA(I) * RHO
110               CONTINUE
              END IF

              GO TO 120
          END IF

          DO 130 I = 1, NVARS
              ENDPT(I) = XBEFOR(I)
130       CONTINUE

          HOOKE = ITERS

          RETURN
      END

C     === MAIN PROGRAM.
      PROGRAM HOOKEF
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 250)

#ifndef WOODS
C         CONSTANT. THE STEPSIZE GEOMETRIC SHRINK.
          DOUBLE PRECISION RHO_BE
          PARAMETER       (RHO_BE = 0.5)
#else
C         THE HOOKE AND JEEVES ALGORITHM WORKS REASONABLY WELL ON
C         ROSENBROCK'S FUNCTION, BUT CAN FARE WORSE ON SOME STANDARD
C         TEST FUNCTIONS, DEPENDING ON RHO. HERE IS AN EXAMPLE THAT
C         WORKS WELL WHEN RHO = 0.5, BUT FARES POORLY WITH RHO = 0.6,
C         AND BETTER AGAIN WITH RHO = 0.8.
          DOUBLE PRECISION RHO_WO
          PARAMETER       (RHO_WO = 0.6)
#endif

C         CONSTANT. THE ENDING VALUE OF STEPSIZE.
          DOUBLE PRECISION EPSMIN
          PARAMETER       (EPSMIN = 1E-6)

C         CONSTANT. THE MAXIMUM NUMBER OF ITERATIONS.
          INTEGER    IMAX
          PARAMETER (IMAX = 5000)

C         GLOB. THE NUMBER OF FUNCTION EVALUATIONS.
          INTEGER FUNEVA
          COMMON  FUNEVA

          INTEGER NVARS
          INTEGER ITERMA
          INTEGER JJ
          INTEGER I

          DOUBLE PRECISION STARTP(VARS)
          DOUBLE PRECISION RHO
          DOUBLE PRECISION EPSILO
          DOUBLE PRECISION ENDPT(VARS)

C         PROTO REF. THE MAIN OPTIMIZATION FUNCTION HOOKE(...).
          INTEGER HOOKE

          FUNEVA = 0

#ifndef WOODS
C     STARTING GUESS FOR ROSENBROCK'S TEST FUNCTION.
          NVARS     =  2
          STARTP(1) = -1.2
          STARTP(2) =  1.0
          RHO       =  RHO_BE
#else
C     STARTING GUESS TEST PROBLEM 'WOODS'.
          NVARS     =  4
          STARTP(1) = -3
          STARTP(2) = -1
          STARTP(3) = -3
          STARTP(4) = -1
          RHO       =  RHO_WO
#endif

          ITERMA = IMAX
          EPSILO = EPSMIN

          JJ = HOOKE(NVARS, STARTP, ENDPT, RHO, EPSILO, ITERMA)

          PRINT 10, JJ
10        FORMAT (///, 'HOOKE USED ', I2, ' ITERATIONS, AND RETURNED')

          DO 20 I = 1, NVARS
              PRINT 30, I - 1, ENDPT(I)
30            FORMAT ('x[', I3, '] = ', 1PE15.7E2, ' ')
20        CONTINUE

#ifdef WOODS
          PRINT 40
40        FORMAT ('True answer: f(1, 1, 1, 1) = 0.')
#endif
      END


module mod_constants

   use iso_fortran_env

   implicit none

   real, parameter :: pi = 3.1415926536
   real, parameter :: e = 2.7182818285

   real(kind=real64), parameter :: elementary_charge = 1.602176634D-19
   real(kind=real64), parameter :: G_grav = 6.67430D-11     ! Gravitational constant
   real(kind=real64), parameter :: h_plank = 6.62607015D-34  ! Plank constant
   real(kind=real64), parameter :: c_light = 299792458       ! Light Speed
   real(kind=real64), parameter :: vacuum_electric_permittivity = 8.8541878128D-12
   real(kind=real64), parameter :: vacuum_magnetic_permeability = 1.25663706212D-6
   real(kind=real64), parameter :: electron_mass = 9.1093837015D-31
   real(kind=real64), parameter :: fine_structure = 7.2973525693D-3
   real(kind=real64), parameter :: Josephson = 483597.8484
   real(kind=real64), parameter :: Rydberg = 10973731.568160
   real(kind=real64), parameter :: von_Klitzing = 25812.80745

contains

   subroutine show_consts()
      print *, "G = ", G_grav
      print *, "h = ", h_plank
      print *, "c = ", c_light
   end subroutine show_consts

end module mod_constants

program physical_constants

   use mod_constants

   implicit none

   print *, sqrt(2.0_real64)
   print *, sqrt(2.0_real128)
   print *, 'Inverse of Fine Structure constant = ', 1.0_real64 / fine_structure

   call show_consts()

end program


! { dg-do run }
! PR PR 56872 - wrong front-end optimization with a
! single array constructor and another value.
program main
  real    :: s
  integer :: m
  integer :: k
  real :: res

  m = 2
  s = 1000.

  res = SUM([3.0,(s**(REAL(k-1)/REAL(m-1)),k=1,m),17.])
  if (abs(res - 1021.)>1e-4) call abort
end


      SUBROUTINE sprsax(sa,ija,x,b,n)
      INTEGER n,ija(*)
      REAL b(n),sa(*),x(n)
      INTEGER i,k
      if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprsax'
      do 12 i=1,n
        b(i)=sa(i)*x(i)
        do 11 k=ija(i),ija(i+1)-1
          b(i)=b(i)+sa(k)*x(ija(k))
11      continue
12    continue
      return
      END

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


!*****************************************************************************************
!> author: Jacob Williams
!
!  For computing the obliquity of the ecliptic.
!
!### Notes
!  * Mean obliquity does not include the short-period terms
!    due to nutation. True obliquity includes these terms.

    module obliquity_module

    use conversion_module
    use kind_module

    implicit none

    private

    abstract interface
        pure function mean_obliquity_func(et) result(e)
        !! a function for computing the mean obliquity of the ecliptic.
        import :: wp
        implicit none
        real(wp),intent(in) :: et  !! ephemeris time (sec)
        real(wp)            :: e   !! obliquity of ecliptic (deg)
        end function mean_obliquity_func
    end interface

    public :: mean_ecliptic_to_equatorial_rotmat
    public :: equatorial_to_mean_ecliptic_rotmat
    public :: mean_obliquity_of_ecliptic_iau1980
    public :: mean_obliquity_of_ecliptic_iau2006

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Rotation matrix from Mean Ecliptic to J2000.
!
!### Reference
! * https://en.wikipedia.org/wiki/Ecliptic_coordinate_system

    pure function mean_ecliptic_to_equatorial_rotmat(obliquity_func) result(rot)

    implicit none

    real(wp),dimension(3,3) :: rot  !! rotation matrix
    procedure(mean_obliquity_func),optional :: obliquity_func !! optional function to compute
                                                              !! the mean obliquity. If not
                                                              !! present, then
                                                              !! [[mean_obliquity_of_ecliptic_iau1980]]
                                                              !! is used.

    real(wp) :: e !! mean obliquity at J2000 (rad)
    real(wp) :: s,c

    if (present(obliquity_func)) then
        e = obliquity_func(0.0_wp)
    else
        e = mean_obliquity_of_ecliptic_iau1980(0.0_wp)
    end if
    e = e * deg2rad
    s = sin(e)
    c = cos(e)

    rot(:,1) = [1.0_wp, 0.0_wp, 0.0_wp]
    rot(:,2) = [0.0_wp, c, s]
    rot(:,3) = [0.0_wp, -s, c]

    end function mean_ecliptic_to_equatorial_rotmat
!*****************************************************************************************

!*****************************************************************************************
!>
!  Rotation matrix from J2000 to Mean Ecliptic.

    pure function equatorial_to_mean_ecliptic_rotmat(obliquity_func) result(rot)

    implicit none

    real(wp),dimension(3,3) :: rot  !! rotation matrix
    procedure(mean_obliquity_func),optional :: obliquity_func !! optional function to compute
                                                              !! the mean obliquity. If not
                                                              !! present, then
                                                              !! [[mean_obliquity_of_ecliptic_iau1980]]
                                                              !! is used.

    rot = transpose(mean_ecliptic_to_equatorial_rotmat(obliquity_func))

    end function equatorial_to_mean_ecliptic_rotmat
!*****************************************************************************************

!*****************************************************************************************
!>
!  Mean obliquity of the ecliptic, IAU 2006 formula.

    pure function mean_obliquity_of_ecliptic_iau2006(et) result(e)

    implicit none

    real(wp),intent(in) :: et  !! ephemeris time (sec)
    real(wp)            :: e   !! obliquity of ecliptic (deg)

    real(wp) :: t  !! time in centuries from the J2000 epoch

    real(wp),parameter,dimension(6) :: c = [84381.406_wp,&
                                            -46.836769_wp,&
                                            -0.0001831_wp,&
                                            0.00200340_wp,&
                                            -0.000000576_wp,&
                                            -0.0000000434_wp] !! coefficients

    ! convert input time to centuries:
    t = et*sec2day*day2century

    ! use horner's rule:
    e = (c(1)+t*(c(2)+t*(c(3)+t*(c(4)+t*(c(5)+t*c(6))))))*arcsec2deg

    end function mean_obliquity_of_ecliptic_iau2006
!*****************************************************************************************

!*****************************************************************************************
!>
!  Mean obliquity of the ecliptic, IAU 1980 formula.
!
!@note This equation is consistent with the one from the SPICE `zzmobliq` routine.

    pure function mean_obliquity_of_ecliptic_iau1980(et) result(e)

    implicit none

    real(wp),intent(in) :: et  !! ephemeris time (sec)
    real(wp)            :: e   !! obliquity of ecliptic (deg)

    real(wp) :: t  !! time in centuries from the J2000 epoch

    real(wp),dimension(0:3),parameter :: c = [84381.448_wp,&
                                              -46.8150_wp,&
                                              -0.00059_wp,&
                                              +0.001813_wp] !! coefficients

    ! convert input time to centuries:
    t = et*sec2day*day2century

    ! use horner's rule:
    e = (c(0)+t*(c(1)+t*(c(2)+t*c(3))))*arcsec2deg

    end function mean_obliquity_of_ecliptic_iau1980
!*****************************************************************************************

!*****************************************************************************************
    end module obliquity_module
!*****************************************************************************************