FUNCTION CSEDSET(SED,SHEAR,IOPT)

  ! *** CSEDSET CALCULATES CONCENTRATION DEPENDENT SETTLING VELOCITY OF
  ! *** COHESIVE SEDIMENT WITH UNITS OF M/S

  !----------------------------------------------------------------------C
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  !    2015-06       CHRIS HALL        UPDATED THE SHRESTHA-ORLOB EQUATION
  !                  BILL MCANALLY/ASHISH MEHTA

  IMPLICIT NONE

  REAL, INTENT(IN)    :: SED,SHEAR
  INTEGER, INTENT(IN) :: IOPT
  REAL    :: CSEDSET,TMP,RNG,BG,WTMP,GG,CG,BD2,CON,VAL,TMPSED

  IF( SED <= 0.0001 )THEN
    CSEDSET = 0.0
    RETURN
  ENDIF

  ! **  IOPT=1  BASED ON
  ! **
  ! **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
  ! **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
  ! **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
  IF( IOPT == 1 )THEN
    TMPSED=SED/2000.
    TMP=LOG10(TMPSED)
    TMP=-16.*TMP*TMP/9.
    TMP=10.**TMP
    CSEDSET = 8.E-4*TMP
  ENDIF

  ! **  IOPT=2  BASED ON
  ! **
  ! **  SHRESTA, P. L., AND G. T. ORLOB, 1996: MULTIPHASE DISTRIBUTION
  ! **  OF COHESIVE SEDIMENTS AND HEAVY METALS IN ESTUARINE SYSTEMS,
  ! **  J. ENVIRONMENTAL ENGINEERING, 122, 730-740.
  IF( IOPT == 2 )THEN
    ! *** SHRESTHA-ORLOB EQUATION (DEPRECATED - 2015-06)
    !SED=(SED/2.65E-6)**(1/3)
    !BG=0.03*SHEAR**(-0.5)
    !WTMP=SED*BG
    !CSEDSET=WTMP/3600.

    ! *** MODIFIED (MEHTA) SHRESTHA-ORLOB EQUATION
    TMPSED  = 1.E-3*SED
    RNG     = 1.11075 + 0.0386*SHEAR
    BG      = EXP( -4.20706 + 0.1465*SHEAR )
    WTMP    = BG*TMPSED**RNG
    CSEDSET = WTMP/3600.
  ENDIF

  ! **  IOPT=3  BASED ON
  ! **
  ! **  ZIEGLER, C. K., AND B. S. NESBIT, 1995: LONG-TERM SIMULAITON
  ! **  OF FINE GRAIN SEDIMENT TRANSPORT IN LARGE RESERVOIR,
  ! **  J. HYDRAULIC ENGINEERING, 121, 773-781.
  IF( IOPT == 3 )THEN
    TMPSED  = 1.E-6*SED        ! *** CONVERT G/M^3 TO G/CM^3
    GG      = 1.E4*SHEAR       ! *** CONVERT FROM M^2/S^2 TO CM^2/S^2
    CG      = GG*TMPSED        ! *** G/CM/S^2 = G/CM^3 * CM^2/S^2
    CG      = MAX(CG,7.51E-6)
    BD2     = -0.4 - 0.25*LOG10(CG - 7.5E-6)
    CON     = 9.6E-4*(1.E-8)**BD2
    VAL     = CG**(-0.85-BD2)
    CSEDSET = 0.01*CON*VAL
  ENDIF

  ! **  IOPT=4  BASED ON SHEAR
  IF( IOPT == 4 )THEN
    GG      = 1.E4*SHEAR       ! *** CONVERT FROM M^2/S^2 TO CM^2/S^2
    TMPSED  = GG*SED
    CSEDSET = 8.E-5
    IF( TMPSED < 40.0  ) CSEDSET = 1.510E-5*(TMPSED**0.45)
    IF( TMPSED > 400.0 ) CSEDSET = 0.893E-6*(TMPSED**0.75)
  ENDIF

  ! **  IOPT=5  BASED ON HOUSATONIC RIVER
  ! **     HQ MODIFIED OPTION 5: CONVERT M/DAY TO M/SEC BY /86400
  !        INTERSECTION OF THE TWO FUNCTIONS IS AT 3.8 NOT 10.0
  IF( IOPT == 5 )THEN
    GG      = 1.E4*SHEAR       ! *** CONVERT FROM M^2/S^2 TO CM^2/S^2
    TMPSED  = GG*SED
    IF( TMPSED < 3.8 )THEN
      CSEDSET = (1.270*(TMPSED**0.79))/86400. ! 12/31/03 new WP regr
    ELSE
      CSEDSET = (3.024*(TMPSED**0.14))/86400. ! 12/31/03 Burban&Lick
    ENDIF
  ENDIF

  ! **  IOPT=6
  IF( IOPT == 6 )THEN
    GG      = 1.E4*SHEAR       ! *** CONVERT FROM M^2/S^2 TO CM^2/S^2
    TMPSED  = GG*SED
    IF( TMPSED <  100.0 )THEN
      CSEDSET = 2.*1.16E-5*(TMPSED**0.5)
    ELSE
      CSEDSET = 2.*1.84E-5*(TMPSED**0.4)
    ENDIF
  ENDIF

  ! **  IOPT=7  BASED ON
  IF( IOPT == 7 )THEN
    TMPSED  = SHEAR*SED
    CSEDSET = 0.0052*(TMPSED**0.470138)
  ENDIF

  ! ** MODIFIED SHRESTHA (CHRISTOPHER HALL JULY 9, 2015)
  IF( IOPT == 8 )THEN
    TMPSED = 1.E-3*SED        ! *** CONVERT G/M^3 TO G/L
    IF( SHEAR > 0.1 )THEN
        BG=0.06/SQRT(SHEAR)
    ELSE
        BG=0.1
    ENDIF
    CSEDSET = BG*(TMPSED/2650)**(1./3.)
  ENDIF

  RETURN
END


! *****************************************************
!    kernel.F95 for GCD+ ver. f03.0
! 04  Jan. 2013   written by D. Kawata
! *****************************************************

subroutine setkernel()
      use gcdp_const
      use gcdp_kernel
      use gcdp_system

      implicit none

      integer i,j
      double precision f,cv,s,ds_tb

      dnktab=dble(NKTAB)
      ds_tb=1.0d0/dnktab

! *** W: SPH kernel ***
! *** for constant ***
      cv=8.0d0/M_PI

      do i=0,NKTAB
        s_tb(i)=ds_tb*dble(i)
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(1.0d0-6.0d0*(s**2)+6.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(2.0d0*((1.0d0-s)**3))
        else
          f=0.0d0
        endif
        w_tb(i)=cv*f
      enddo

! *** dW(s)/ds/s: SPH kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=-12.0d0+18.0d0*s
        else if(s.le.1.0d0) then
          f=-6.0d0*((1.0d0-s)**2)/s
        else
          f=0.0d0
        endif
        dwds_s_tb(i)=cv*f
! *** core dw/ds ***
        if(s.le.THIRD) then
          f=-2.0d0
        else if(s.le.0.5d0) then
          f=-12.0d0*s+18.0d0*s*s
        else if(s.le.1.0d0) then
          f=-6.0d0*((1.0d0-s)**2)
        else
          f=0.0d0
        endif
        dwdsc_tb(i)=cv*f
      enddo
! *** h x dW/dh: SPH kernel ***
! #ifdef SIM1D
!      cv=1.0d0
! #elif defined(SIM2D)
!      cv=2.0d0
! #else
!      cv=3.0d0
! #endif
!      do i=0,NKTAB
!        s=s_tb(i)
!        hdwdh_tb(i)=-cv*w_tb(i)-dwds_s_tb(i)*(s**2)
!      enddo

! *** h*phi: phi kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.lt.0.5d0) then
          f=(16.0d0/3.0d0)*(s**2)-(48.0d0/5.0d0)*(s**4)+(32.0d0/5.0d0)*(s**5) &
            -(14.0d0/5.0d0)
        else
          f=(32.0d0/3.0d0)*(s**2)-16.0d0*(s**3)+(48.0d0/5.0d0)*(s**4) &
            -(32.0d0/15.0d0)*(s**5)-(16.0d0/5.0d0)+(1.0d0/(15.0d0*s))
        endif
        hphi_tb(i)=f
      enddo

! *** dphi/dr/r: phi kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(32.0d0/15.0d0)*(5.0d0-18.0d0*(s**2)+15.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(4.0d0/15.0d0)*(80.0d0*s-180.0d0*(s**2)+144.0d0*(s**3) &
           -40.0d0*(s**4)-0.25d0/(s**2))/s
        endif
        dphidr_r_tb(i)=f
      enddo

! *** for test
!      if(myrank.eq.0) then
!        open(60,file='kernel.dat',status='unknown')
!        do i=1,NKTAB-1
!          s=s_tb(i)
!          write(60,160) s_tb(i),w_tb(i),hphi_tb(i)
!           ,dwds_s_tb(i),(dwds_s_tb(i)-dwds_s_tb(i-1))/dwds_s_tb(i) &
!           ,dphidr_r_tb(i),(dphidr_r_tb(i)-dphidr_r_tb(i-1))/dphidr_r_tb(i) &
!           ,dphidh_tb(i),(dphidh_tb(i)-dphidh_tb(i-1))/dphidh_tb(i) &
!           ,d2phidr2_tb(i),(d2phidr2_tb(i)-d2phidr2_tb(i-1))/d2phidr2_tb(i) &
!           ,d3phidr3_tb(i),(d3phidr3_tb(i)-d3phidr3_tb(i-1))/d3phidr3_tb(i)
!        enddo
!  160   format(3(1pE13.5))
!        close(60)
!      endif

end subroutine


module Task ! Модуль с процедурами
use fgsl ! Подключение библиотеки FGSL
implicit none

contains

function GetSplineValue(x, x_array, y_array) ! Интерполяция сплайнами

     real(fgsl_double), dimension(:), intent(in) :: x_array, y_array
     real(fgsl_double), intent(in) :: x
     real(fgsl_double) :: GetSplineValue

     integer(fgsl_size_t) n
     integer(fgsl_int) status

     type(fgsl_interp_accel) :: acc
     type(fgsl_spline) :: spline

     n = size(x_array)

     spline = fgsl_spline_alloc(fgsl_interp_cspline_periodic, n)

     status = fgsl_spline_init(spline, x_array, y_array)

     GetSplineValue = fgsl_spline_eval(spline, x, acc)

     call fgsl_spline_free (spline)
     call fgsl_interp_accel_free (acc)

end function

end module


 program filtre

! on calcule la fonction de psf, gaussienne 2-D
! exp(-0.5*(i^2+j^2)/sig2) normalisee, avec sig2=1.5, soit sig=1.22

 implicit none

 integer	:: i, j, ii
 real		:: sig2, arg, DPi, somch

 real, dimension(16)   :: chapeau

 open (10, file = 'filtre.dat')

! calcul de la fonction de lissage
    sig2 = 1.5
    DPi = 8.0*atan(1.0)		! c'est 2*pi
    somch = 0.
    do j= -7,8
    	do i= -7,8
	   ii = i+8
	   arg = 0.5*(i*i+j*j)/sig2
	   chapeau(ii) = 1.0*exp(-arg)/DPi/sig2
	   somch = somch + chapeau(ii)
	enddo

	write(10,'(16(f9.6))') chapeau

    enddo

    print*,'somch = ', somch

end program filtre


MODULE HartleyFFT_2D
IMPLICIT NONE
PUBLIC  :: fht2d

! From hamill@mailhub.nmg.sms.siemens.com Wed Apr 24 16:21:31 1996

! Code converted using TO_F90 by Alan Miller
! Date: 2004-02-04  Time: 13:01:18

! I see from the newsgroups that you are interested in multidimensional
! Hartley transforms.  The attached FORTRAN code works (I think ... but
! it's been a few years since I used it) for 2D and 1D.  For 3D see H.Hao
! and R.N.Bracewell, "A Three-Dimensional DFT Algorithm Using the Fast
! Hartley Transform," Proc IEEE vol. 75 no. 2 (Feb, 87) p.264-266.

! I do not vouch for the correctness of the information or the code, but
! perhaps it is a useful starting point.

! Good luck!

! Jim Hamill

!------------------------------------------------
! hamill@mailhub.nmg.sms.siemens.com
! James Hamill
! Siemens Medical Systems, Nuclear Medicine Group
! 2501 N. Barrington Rd.
! Hoffman Estates, IL  60195
! voice:(847)304-7760       FAX:(847)304-7706
!------------------------------------------------

CONTAINS

!------------------------------------------------------------------------------
!   FHT2D
!        A subroutine for the 2-dimensional Hartley transform of an
!        array  F2(N,N)  where N = 2**P
!        This routine call the 1-d Hartley transform routine FHTFR, for
!        rows and then for columns.
!-------------------------------------------------------------------------------

SUBROUTINE fht2d(nx, f2)
INTEGER, INTENT(IN)   :: nx
REAL, INTENT(IN OUT)  :: f2(0:nx-1,0:nx-1)

REAL     :: a, b, c, d, e, f(0:255)
INTEGER  :: i, j, n, ny, n1, p, u, v

p = INT( LOG(REAL(nx))/LOG(2.) + 0.5)
n  = 2**p
n1 = n - 1
DO j = 0,n1
  CALL fhtfr(p, f2(0,j))
END DO
DO i = 0,n1
  DO j = 0,n1
    f(j)=f2(i,j)
  END DO
  CALL fhtfr(p, f)
  DO j = 0,n1
    f2(i,j)=f(j)
  END DO
END DO

!  UP TO THIS POINT F2(U,V) NOW CONTAIN THE SEPARABLE
!                    CAS(2*pi*u*x)*CAS(2*pi*v*y)   transform

!  The following replacements form the nonseparable 2D-Hartley transform
!    Ref:   RN Bracewell, et al., "Fast Two-dimensional Hartley transform,"
!           Proc IEEE, 74:9,1282 (Sept 1986)

ny = nx
DO v = 1,ny/2-1
  DO u = 1,nx/2-1
    a = f2(u,v)
    b = f2(nx-u,v)
    c = f2(u,ny-v)
    d = f2(nx-u,ny-v)
    e = 0.5*( (a+d)-(b+c) )
    f2(u,v)       = a - e
    f2(nx-u,v)    = b + e
    f2(u,ny-v)    = c + e
    f2(nx-u,ny-v) = d - e
  END DO
END DO

RETURN
END SUBROUTINE fht2d

!-----------------------------------------------------------------------------
!   SUBROUTINE FHTFOR TAKES INPUT F() AND RETURNS THE DHT IN THE SAME F()
!   LENGTH OF F() IS 2**P
!-----------------------------------------------------------------------------
!     THIS IS THE CORRECTED VERSION OF FHTFOR.FOR
!     RN BRACEWELL,  THE HARTLEY TRANSFORM, Oxford Univ. Press (1986)
!     pp. 140-144
!-----------------------------------------------------------------------------

SUBROUTINE fhtfr(p, f)
INTEGER, INTENT(IN)   :: p
REAL, INTENT(IN OUT)  :: f(0:255)

REAL     :: h9, s9(256), t, t9(256)
INTEGER  :: d9, e9, i, j, k9, l9, n, n9, q9, sx9, u9, x9, y9,   &
    a9(0:64), m9(0:10), c9(0:10), v9(0:10)
INTEGER  :: pold = -99
REAL, PARAMETER     :: pi = 3.1415926536

IF (p == 1) THEN
  j    = f(0) + f(1)
  f(1) = f(0) - f(1)
  f(0) = j
  GO TO 9636   !   RETURN
END IF
IF(p == pold) GO TO 9400
n9 = 2**(p-2)
n = 4*n9
c9(5) = n-1
c9(6) = p-1

!   GET POWERS OF 2
i = 1
m9(0) = 1
m9(1) = 2
9204   m9(i+1) = m9(i) + m9(i)
i = i + 1
IF(i <= p) GO TO 9204

!  TRIGONOMETRIC FUNCTION TABLES
IF(n == 4) GO TO 9400
IF(n == 8) THEN
  s9(2) = 1.
  s9(1) = SIN(pi/4.)
  GO TO 9330
END IF
!   GET SINES
s9(n9) = 1.
!   COARSE SEED TABLE FOR SINES
DO i = 1,3
  s9(i*n9/4) = SIN(i*pi/8.)
END DO
!   INITIAL HALF SECANT
h9 = 1./2/COS(pi/16)
!   FILL SINE TABLE
c9(4) = p-4
DO i = 1,p-4
  c9(4) = c9(4)-1
  v9(0) = 0
  DO j = m9(c9(4)), n9-m9(c9(4)), m9(c9(4)+1)
    v9(1) = j + m9(c9(4))
    s9(j) = h9*(s9(v9(1))+v9(0))
    v9(0) = s9(v9(1))
  END DO
!   HALF SECANT RECURSION
  h9 = 1/SQRT(2+1/h9)
END DO

!   GET TANGENTS
9330 c9(0) = n9 - 1
DO i = 1,n9-1
  t9(i) = (1-s9(c9(0)))/s9(i)
  c9(0) = c9(0) - 1
END DO
t9(n9) = 1

!   FAST PERMUTE
!   FOR P = 2,3 PERMUTE DIRECTLY
9400 IF(p == 2) THEN
  v9(9) = f(1)
  f(1)  = f(2)
  f(2)  = v9(9)
  GO TO 9500
END IF
IF(p == 3) THEN
  v9(9) = f(1)
  f(1)  = f(4)
  f(4)  = v9(9)
  v9(9) = f(3)
  f(3)  = f(6)
  f(6)  = v9(9)
  GO TO 9500
END IF
IF(p == pold) GO TO 9420
!   FOR P=4, 5, 6 (Q9=2,3), SKIP STRUCTURE TABLE
q9 = p/2
c9(2) = m9(q9)
q9 = q9 + MOD(p,2)
IF(q9 == 2) THEN
  a9(0) = 0
  a9(1) = 2
  a9(2) = 1
  a9(3) = 3
  GO TO 9420
END IF
IF(q9 == 3) THEN
  a9(0) = 0
  a9(1) = 4
  a9(2) = 2
  a9(3) = 6
  a9(4) = 1
  a9(5) = 5
  a9(6) = 3
  a9(7) = 7
  GO TO 9420
END IF

!   SET UP STRUCTURE TABLE
a9(0) = 0
a9(1) = 1
DO i = 2,q9
  DO j = 0,m9(i-1)-1
    a9(j) = a9(j) + a9(j)
    a9(j+m9(i-1))=a9(j)+1
  END DO
END DO

!   PERMUTE
9420 DO i = 1,c9(2)-1
  v9(4)  = c9(2)*a9(i)
  v9(5)  = i
  v9(6)  = v9(4)
  v9(7)  = f(v9(5))
  f(v9(5)) = f(v9(6))
  f(v9(6)) = v9(7)
  DO j =1,a9(i)-1
    v9(5) = v9(5) + c9(2)
    v9(6) = v9(4) + a9(j)
    v9(7) = f(v9(5))
    f(v9(5)) = f(v9(6))
    f(v9(6)) = v9(7)
  END DO
END DO

!   STAGES 1 & 2
!   GET TWO-ELEMENT DHTs
9500 DO i = 0,n-2,2
  t      = f(i) - f(i+1)
  f(i)   = f(i) + f(i+1)
  f(i+1) = t
END DO

!   GET FOUR-ELEMENT DHTs
DO i = 0,n-4,4
  t      = f(i) - f(i+2)
  f(i)   = f(i) + f(i+2)
  f(i+2) = t
  t      = f(i+1)-f(i+3)
  f(i+1) = f(i+1)+f(i+3)
  f(i+3) = t
END DO

IF(p == 2) GO TO 9636  !  RETURN

!   STAGES 3, 4, ...
u9 = c9(6)
sx9 = 4
DO l9 = 2,c9(6)
  v9(2) = sx9 + sx9
  u9 = u9-1
  v9(3) = m9(u9-1)
  DO q9 = 0,c9(5),v9(2)
    i = q9
    d9 = i+sx9
    t     = f(i) - f(d9)
    f(i)  = f(i) + f(d9)
    f(d9) = t
    k9 = d9-1
    DO j=v9(3),n9,v9(3)
      i  = i  + 1
      d9 = i  + sx9
      e9 = k9 + sx9
      t  = f(d9) + f(e9)*t9(j)
      x9 = f(e9) - t*s9(j)
      y9 = x9*t9(j) + t
      t = f(i) + y9
      f(d9) = f(i)  - y9
      f(e9) = f(k9) + x9
      f(k9) = f(k9) - x9
      f(i)  = t
      k9 = k9 -1
    END DO
  END DO
  sx9= v9(2)
END DO

!   SAVE P SO TABLE GENERATION CAN BE SKIPPED ON NEXT CALL
9636 pold = p
RETURN
END SUBROUTINE fhtfr

END MODULE HartleyFFT_2D


Module math_constants
	Implicit None
	integer, parameter :: sp = kind(1.0)
	integer, parameter :: dp = KIND(1.0D0)
	real(dp), parameter :: sqrt2=1.41421356237309504880168872420969807856967_dp
	real(dp), parameter :: euler=0.5772156649015328606065120900824024310422_dp
	real(dp), parameter :: pi=3.141592653589793238462643383279502884197_dp
	real(dp), parameter :: pih=1.57079632679489661923132169163975144209858_dp
	real(dp), parameter :: pi2=6.283185307179586476925286766559005768394_dp
End module math_constants


	   subroutine est_weirdim(depwid,desdis,wwidth,wdepth,cd)

   !!	This program estimates rectangular weir dimensions based on
   !!	width-depth ratio of wier at different stages

       implicit none

	   real, intent(in) :: depwid          !             |
       real, intent(in) :: cd              !             |
       real, intent(in) :: desdis          !             |
	   real, intent(out) :: wdepth         !             |
       real, intent(out) :: wwidth         !             |
       real :: tempvar                     !             |

	   tempvar=depwid**1.5
	   wwidth=(desdis*tempvar/(1.84*cd))**0.4
	   wdepth=wwidth/depwid

	   return
	   end subroutine est_weirdim


      FUNCTION select(k,n,arr)
      INTEGER k,n
      REAL select,arr(n)
      INTEGER i,ir,j,l,mid
      REAL a,temp
      l=1
      ir=n
1     if(ir-l.le.1)then
        if(ir-l.eq.1)then
          if(arr(ir).lt.arr(l))then
            temp=arr(l)
            arr(l)=arr(ir)
            arr(ir)=temp
          endif
        endif
        select=arr(k)
        return
      else
        mid=(l+ir)/2
        temp=arr(mid)
        arr(mid)=arr(l+1)
        arr(l+1)=temp
        if(arr(l).gt.arr(ir))then
          temp=arr(l)
          arr(l)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l+1).gt.arr(ir))then
          temp=arr(l+1)
          arr(l+1)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l).gt.arr(l+1))then
          temp=arr(l)
          arr(l)=arr(l+1)
          arr(l+1)=temp
        endif
        i=l+1
        j=ir
        a=arr(l+1)
3       continue
          i=i+1
        if(arr(i).lt.a)goto 3
4       continue
          j=j-1
        if(arr(j).gt.a)goto 4
        if(j.lt.i)goto 5
        temp=arr(i)
        arr(i)=arr(j)
        arr(j)=temp
        goto 3
5       arr(l+1)=arr(j)
        arr(j)=a
        if(j.ge.k)ir=j-1
        if(j.le.k)l=i
      endif
      goto 1
      END

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


subroutine PlSchmidt(p, lmax, z, exitstatus)
!------------------------------------------------------------------------------
!
!   This function evalutates all of the Schmidt normalized legendre
!   polynomials up to degree lmax.
!
!   Calling Parameters
!
!       Out
!           p       A vector of all Schmidt normalized Legendgre polynomials
!                   evaluated at z up to lmax. The lenght must by greater or
!                   equal to (lmax+1).
!
!       IN
!           lmax    Maximum degree to compute.
!           z       [-1, 1], cos(colatitude) or sin(latitude).
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!
!   1.  The integral of plm**2 over (-1,1) is 2 * / (2l+1).
!   2.  The integral of Plm**2 over all space is 4 pi / (2l+1).
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    implicit none

    integer, intent(in) :: lmax
    real*8, intent(out) :: p(:)
    real*8, intent(in) :: z
    integer, intent(out), optional :: exitstatus
    real*8 :: pm2, pm1, pl
    integer :: l

    if (present(exitstatus)) exitstatus = 0

    if (size(p) < lmax+1) then
        print*, "Error --- PlSchmidt"
        print*, "P must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(p)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        endif

    else if (lmax < 0) then
        print*, "Error --- PlSchmidt"
        print*, "LMAX must be greater than or equal to 0."
        print*, "Input value is ", lmax
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        endif

    else if(abs(z) > 1.0d0) then
        print*, "Error --- PlSchmidt"
        print*, "ABS(Z) must be less than or equal to 1."
        print*, "Input value is ", z
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        endif

    end if

    pm2 = 1.d0
    p(1) = 1.d0

    pm1 = z
    p(2) = pm1

    do l = 2, lmax, 1
        pl = ( dble(2*l-1)  * z * pm1 - dble(l-1) * pm2 ) / dble(l)
        p(l+1) = pl
        pm2 = pm1
        pm1 = pl

    end do

end subroutine PlSchmidt


      PROGRAM xvoltra
C     driver for routine voltra
      INTEGER N,M
      REAL H
      PARAMETER(N=30,H=.05,M=2)
      INTEGER nn
      REAL t0,t(N),f(M,N)
      EXTERNAL g,ak
      t0=0.
      call voltra(N,M,t0,H,t,f,g,ak)
C     exact soln is f(1)=exp(-t), f(2)=2sin(t)
      write(*,*)
     *'abscissa,voltra answer1,real answer1,voltra answer2,real answer2'
      do 11 nn=1,N
        write(*,100) t(nn),f(1,nn),exp(-t(nn)),f(2,nn),2.*sin(t(nn))
11    continue
100   format(5f10.6)
      END
      REAL FUNCTION g(k,t)
      INTEGER k
      REAL t
      if (k.eq.1) then
        g=cosh(t)+t*sin(t)
      else
        g=2.*sin(t)+t*(sin(t)**2+exp(t))
      endif
      return
      END
      REAL FUNCTION ak(k,l,t,s)
      INTEGER k,l
      REAL t,s
      if (k.eq.1) then
        if (l.eq.1) then
          ak=-exp(t-s)
        else
          ak=-cos(t-s)
        endif
      else
        if (l.eq.1) then
          ak=-exp(t+s)
        else
          ak=-t*cos(s)
        endif
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xvoltra.for


module binary_module

  ! This module contains a number of routines that are designed to
  ! calculate generic properties of binary orbits.

  implicit none

contains

  ! Given the mass ratio q of two stars (assumed to be q = M_1 / M_2),
  ! compute the effective Roche radii of the stars, normalized to unity,
  ! using the approximate formula of Eggleton (1983). Optionally we can
  ! pass in a distance scale.

  subroutine get_roche_radii(mass_ratio, r_1, r_2, a)

    use bl_constants_module, only: ONE, TWO3RD, THIRD

    implicit none

    double precision, intent(in   ) :: mass_ratio
    double precision, intent(inout) :: r_1, r_2
    double precision, intent(in   ), optional :: a

    double precision :: q
    double precision :: c1, c2

    double precision :: scale

    if (present(a)) then
       scale = a
    else
       scale = ONE
    endif

    c1 = 0.49d0
    c2 = 0.60d0

    q = mass_ratio

    r_1 = scale * c1 * q**(TWO3RD) / (c2 * q**(TWO3RD) + LOG(ONE + q**(THIRD)))

    q = ONE / q

    r_2 = scale * c1 * q**(TWO3RD) / (c2 * q**(TWO3RD) + LOG(ONE + q**(THIRD)))

  end subroutine get_roche_radii

  ! Calculate Lagrange points. In each case we give the zone index
  ! closest to it (assuming we're on the coarse grid).

  subroutine get_lagrange_points(mass_1, mass_2, com_1, com_2, &
                                 L1, L2, L3) bind(C, name="get_lagrange_points")

    use bl_constants_module

    implicit none

    double precision :: mass_1, mass_2
    double precision :: com_1(3), com_2(3)
    double precision :: L1(3), L2(3), L3(3)

    double precision :: r ! Distance from Lagrange point to primary
    double precision :: a ! Distance between secondary and primary

    double precision :: r1, r2

    ! Don't try to calculate the Lagrange points if the secondary
    ! is already gone.

    if (mass_2 < ZERO) return

    a = sqrt(sum((com_2 - com_1)**2))

    r1 = -sqrt(sum(com_1**2))
    r2 = sqrt(sum(com_2**2))

    ! Do a root-find over the quintic equation for L1.

    r = ZERO

    call lagrange_iterate(r, mass_1, mass_2, r1, r2, a, r_min = r1, r_max = r2)

    ! Now turn this radial distance into a grid coordinate.

    L1 = r * (com_2 - com_1) / a

    ! Repeat for L2 Lagrange point.

    r = r2 + HALF * a

    call lagrange_iterate(r, mass_1, mass_2, r1, r2, a, r_min = r2)

    L2 = r * (com_2 - com_1) / a

    ! Repeat for L3 Lagrange point.

    r = r1 - HALF * a

    call lagrange_iterate(r, mass_1, mass_2, r1, r2, a, r_max = r1)

    L3 = r * (com_2 - com_1) / a

  end subroutine get_lagrange_points

  ! Iterate over the force balance equation to find a Lagrange point.
  ! r_min and r_max set the domain over which we want to find the answer,
  ! since in general the equation has multiple roots.
  ! We assume that r comes in with a valid starting guess value.

  subroutine lagrange_iterate(r, mass_1, mass_2, r1, r2, a, r_min, r_max)

    use bl_constants_module, only: ZERO, HALF

    implicit none

    ! Input variables

    double precision :: r
    double precision :: mass_1, mass_2, r1, r2, a
    double precision, optional :: r_min, r_max

    ! Root-find parameters

    double precision :: tolerance = 1.0d-8
    integer          :: max_iters = 200

    ! Local variables

    double precision :: rm, rp, rc, width, fm, fp, fc
    integer :: i

    if (.not. (present(r_min) .or. present(r_max))) then
       call bl_error("Lagrange point iteration must have at least one bound provided.")
    else if (present(r_min) .and. present(r_max)) then
       rm = r_min
       rp = r_max
    else if (present(r_min) .and. (.not. present(r_max))) then
       rm = r_min
       rp = abs(r_min) * 1000.0d0
    else if (present(r_max) .and. (.not. present(r_min))) then
       rm = -abs(r_max) * 1000.0d0
       rp = r_max
    endif

    width = (rp - rm)

    rm = rm + width / 1000.0d0
    rp = rp - width / 1000.0d0

    ! Use a bisection search to find the root of the force-balance equation.
    ! The reason we don't use something faster like Newton-Raphson is that
    ! the force terms have terms like 1/r^2, so evaluating the derivative and
    ! then dividing it can be numerically dangerous. Since we only call this routine
    ! once per timestep and the force evaluation is cheap, it shouldn't matter
    ! that the method itself converges slowly.

    do i = 1, max_iters

       fm = fL(mass_1, mass_2, r1, r2, rm, a)
       fp = fL(mass_1, mass_2, r1, r2, rp, a)

       rc = HALF * (rm + rp)
       fc = fL(mass_1, mass_2, r1, r2, rc, a)

       if (fm * fc < ZERO) then
          rp = rc
       else
          rm = rc
       endif

       ! Check to see if we've convernged.

       if (abs( (rp - rm) / a ) < tolerance) then
          exit
       endif

    enddo

    r = rc

    ! If we didn't converge, set the value to zero.

    if (i > max_iters) then
       r = ZERO
    endif

  end subroutine lagrange_iterate

  function fL(M1, M2, r1, r2, r, a)

    use bl_constants_module

    implicit none

    double precision :: M1, M2, r1, r2, r, a
    double precision :: fL

    double precision :: g1, g2, c

    g1 = gforce(M1, r - r1)
    g2 = gforce(M2, r - r2)

    c  = cforce(M1 + M2, a, r)

    fL = g1 + g2 + c

  end function fL

  function fdLdr(M1, M2, r1, r2, r, a)

    use bl_constants_module

    implicit none

    double precision :: M1, M2, r1, r2, r, a
    double precision :: fdLdr

    double precision :: dg1, dg2, dc

    dg1 = dgforcedr(M1, r - r1)
    dg2 = dgforcedr(M2, r - r2)

    dc  = dcforcedr(M1 + M2, a, r)

    fdLdr = dg1 + dg2 + dc

  end function fdLdr

  function gforce(M, r)

    use bl_constants_module, only: ONE
    use fundamental_constants_module, only: Gconst

    double precision :: M, r

    double precision :: gforce

    gforce = -Gconst * M / r**2 * sign(ONE,r)

  end function gforce

  function dgforcedr(M, r)

    use bl_constants_module, only: ONE, TWO
    use fundamental_constants_module, only: Gconst

    double precision :: M, r

    double precision :: dgforcedr

    dgforcedr = TWO * Gconst * M / r**3 * sign(ONE,r)

  end function dgforcedr

  function cforce(M, a, r)

    use bl_constants_module, only: ONE
    use fundamental_constants_module, only: Gconst

    double precision :: M, a, r

    double precision :: cforce

    cforce = Gconst * M / a**3 * r

  end function cforce

  function dcforcedr(M, a, r)

    use bl_constants_module, only: ONE
    use fundamental_constants_module, only: Gconst

    double precision :: M, a, r

    double precision :: dcforcedr

    dcforcedr = Gconst * M / a**3

  end function dcforcedr

end module binary_module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine planeeq(cotet,nodef,planfal)
!
!     calculate the equation of a plane through the points nodef(1),
!     nodef(2) and nodef(3). The equation of the plane is
!     planfal(1)*x+planfal(2)*y+planfal(3)*z+planfal(4)=0; the
!     coordinates of the nodes are stored in cotet
!
!     the vector (planefal(1),planfal(2),planfal(3)) is orthogonal
!     to the plane and is normalized
!
      implicit none
!
      integer nodef(3)
      real*8 cotet(3,*),planfal(4),x1,y1,z1,x2,y2,z2,dd
!
      x1=cotet(1,nodef(1))-cotet(1,nodef(2))
      y1=cotet(2,nodef(1))-cotet(2,nodef(2))
      z1=cotet(3,nodef(1))-cotet(3,nodef(2))
!
      x2=cotet(1,nodef(1))-cotet(1,nodef(3))
      y2=cotet(2,nodef(1))-cotet(2,nodef(3))
      z2=cotet(3,nodef(1))-cotet(3,nodef(3))
!
      planfal(1)=y1*z2-y2*z1
      planfal(2)=x2*z1-x1*z2
      planfal(3)=x1*y2-x2*y1
!
      dd=dsqrt(planfal(1)*planfal(1)+planfal(2)*planfal(2)+
     &         planfal(3)*planfal(3))
!
      if(dd.lt.1.d-10) then
         planfal(1)=0.d0
         planfal(2)=0.d0
         planfal(3)=0.d0
         planfal(4)=0.d0
         return
      endif
!
      planfal(1)=planfal(1)/dd
      planfal(2)=planfal(2)/dd
      planfal(3)=planfal(3)/dd
!
      planfal(4)=-(planfal(1)*cotet(1,nodef(1))+
     &             planfal(2)*cotet(2,nodef(1))+
     &             planfal(3)*cotet(3,nodef(1)))
!
      return
      end


program problem_10
    implicit none
    logical :: isPrime
    integer(kind = 8) :: total
    integer :: limit
    integer :: current

    ! This code is inneficient as fuck, sorry guys [~85.19 s].

    total = 2
    current = 3
    limit = 2000000

    do while (current .LT. limit)
        if (isPrime(current)) then
            total = total + current
        endif
        current = current + 2
    enddo
    print *, total

end program problem_10

logical function isPrime(number)
    implicit none
    integer :: number
    integer :: i

    if ((number .EQ. 0) .OR. (number .EQ. 1) .OR. ((number .NE. 2) .AND. (modulo(number, 2) .EQ. 0))) then
        isPrime = .FALSE.
        return
    endif

    do i=3, number / 3, 2
        if (modulo(number, i) .EQ. 0) then
            isPrime = .FALSE.
            return
        endif
    enddo

    isPrime = .TRUE.
    return
end function isPrime


submodule (stdlib_stats) stdlib_stats_median

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  ! Use "ord_sort" rather than "sort" because the former can be much faster for arrays
  ! that are already partly sorted. While it is slightly slower for random arrays,
  ! ord_sort seems a better overall choice.
  use stdlib_sorting, only: sort => ord_sort
  implicit none

contains

      module function median_all_1_iint32_dp (x, mask) result(res)
        integer(int32), intent(in) :: x(:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum( real(x_tmp(c:c+1), kind=dp) ) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_1_iint32_dp
      module function median_all_2_iint32_dp (x, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum( real(x_tmp(c:c+1), kind=dp) ) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_2_iint32_dp
      module function median_all_3_iint32_dp (x, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum( real(x_tmp(c:c+1), kind=dp) ) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_3_iint32_dp
      module function median_all_4_iint32_dp (x, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum( real(x_tmp(c:c+1), kind=dp) ) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_4_iint32_dp
      module function median_all_1_rdp_dp (x, mask) result(res)
        real(dp), intent(in) :: x(:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_1_rdp_dp
      module function median_all_2_rdp_dp (x, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_2_rdp_dp
      module function median_all_3_rdp_dp (x, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_3_rdp_dp
      module function median_all_4_rdp_dp (x, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        n = size(x, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64 )

        x_tmp = reshape(x, [n])

        call sort(x_tmp)

        if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else
            res = x_tmp(c)
        end if

      end function median_all_4_rdp_dp

      module function median_1_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
                x_tmp(:) = x(:)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res = x_tmp(c)
                end if
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_1_iint32_dp
      module function median_2_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
                x_tmp(:) = x(:, j2)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j2) = x_tmp(c)
                end if
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
                x_tmp(:) = x(j1, :)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1) = x_tmp(c)
                end if
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_2_iint32_dp
      module function median_3_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(:, j2, j3)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j2, j3) = x_tmp(c)
                end if
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(j1, :, j3)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1, j3) = x_tmp(c)
                end if
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
                x_tmp(:) = x(j1, j2, :)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1, j2) = x_tmp(c)
                end if
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_3_iint32_dp
      module function median_4_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer :: j4
        integer(int32), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(:, j2, j3, j4)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2, j3, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j2, j3, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(j1, :, j3, j4)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j3, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1, j3, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(j1, j2, :, j4)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1, j2, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(4)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(j1, j2, j3, :)

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp) ) / 2._dp
                else
                    res(j1, j2, j3) = x_tmp(c)
                end if
              end do
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_4_iint32_dp
      module function median_1_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
                x_tmp(:) = x(:)

                  if (any(ieee_is_nan(x_tmp))) then
                    res = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      return
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res = x_tmp(c)
                end if
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_1_rdp_dp
      module function median_2_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
                x_tmp(:) = x(:, j2)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      return
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j2) = x_tmp(c)
                end if
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
                x_tmp(:) = x(j1, :)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1) = x_tmp(c)
                end if
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_2_rdp_dp
      module function median_3_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(:, j2, j3)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      return
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j2, j3) = x_tmp(c)
                end if
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(j1, :, j3)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1, j3) = x_tmp(c)
                end if
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
                x_tmp(:) = x(j1, j2, :)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1, j2) = x_tmp(c)
                end if
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_3_rdp_dp
      module function median_4_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer :: j4
        real(dp), allocatable :: x_tmp(:)

        if (.not.optval(mask, .true.) .or. size(x) == 0) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = size(x, dim)
        c = floor( (n + 1) / 2._dp )

        allocate(x_tmp(n))

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(:, j2, j3, j4)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2, j3, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      return
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j2, j3, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j2, j3, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(j1, :, j3, j4)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j3, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j3, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1, j3, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j4 = 1, size(x, 4)
                x_tmp(:) = x(j1, j2, :, j4)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1, j2, j4) = x_tmp(c)
                end if
              end do
              end do
              end do
          case(4)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp(:) = x(j1, j2, j3, :)

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                if (mod(n, 2) == 0) then
                    res(j1, j2, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else
                    res(j1, j2, j3) = x_tmp(c)
                end if
              end do
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_4_rdp_dp

      module function median_all_mask_1_iint32_dp(x, mask) result(res)
        integer(int32), intent(in) :: x(:)
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_1_iint32_dp
      module function median_all_mask_2_iint32_dp(x, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        logical, intent(in) :: mask(:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_2_iint32_dp
      module function median_all_mask_3_iint32_dp(x, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_3_iint32_dp
      module function median_all_mask_4_iint32_dp(x, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_4_iint32_dp
      module function median_all_mask_1_rdp_dp(x, mask) result(res)
        real(dp), intent(in) :: x(:)
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_1_rdp_dp
      module function median_all_mask_2_rdp_dp(x, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        logical, intent(in) :: mask(:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_2_rdp_dp
      module function median_all_mask_3_rdp_dp(x, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_3_rdp_dp
      module function median_all_mask_4_rdp_dp(x, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable   :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

          if (any(ieee_is_nan(x))) then
            res = ieee_value(1._dp, ieee_quiet_nan)
            return
          end if

        x_tmp = pack(x, mask)

        call sort(x_tmp)

        n = size(x_tmp, kind=int64)
        c = floor( (n + 1) / 2._dp, kind=int64)

        if (n == 0) then
            res = ieee_value(1._dp, ieee_quiet_nan)
        else if (mod(n, 2_int64) == 0) then
            res = sum(x_tmp(c:c+1)) / 2._dp
        else if (mod(n, 2_int64) == 1) then
            res = x_tmp(c)
        end if

      end function median_all_mask_4_rdp_dp

      module function median_mask_1_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        integer(int32), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
                x_tmp = pack(x(:), &
                              mask(:))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res = x_tmp(c)
                end if

                deallocate(x_tmp)
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_1_iint32_dp
      module function median_mask_2_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        integer(int32), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
                x_tmp = pack(x(:, j2), &
                              mask(:, j2))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
                x_tmp = pack(x(j1, :), &
                              mask(j1, :))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_2_iint32_dp
      module function median_mask_3_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer(int32), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(:, j2, j3), &
                              mask(:, j2, j3))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(j1, :, j3), &
                              mask(j1, :, j3))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
                x_tmp = pack(x(j1, j2, :), &
                              mask(j1, j2, :))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_3_iint32_dp
      module function median_mask_4_iint32_dp(x, dim, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer :: j4
        integer(int32), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(:, j2, j3, j4), &
                              mask(:, j2, j3, j4))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2, j3, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2, j3, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2, j3, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(j1, :, j3, j4), &
                              mask(j1, :, j3, j4))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j3, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j3, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j3, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(j1, j2, :, j4), &
                              mask(j1, j2, :, j4))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2, j4) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(4)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(j1, j2, j3, :), &
                              mask(j1, j2, j3, :))

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2, j3) = &
                        sum(real(x_tmp(c:c+1), kind=dp)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_4_iint32_dp
      module function median_mask_1_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer(kind = int64) :: c, n
        real(dp), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
                x_tmp = pack(x(:), &
                              mask(:))

                  if (any(ieee_is_nan(x_tmp))) then
                    res = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      return
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res = x_tmp(c)
                end if

                deallocate(x_tmp)
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_1_rdp_dp
      module function median_mask_2_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        real(dp), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
                x_tmp = pack(x(:, j2), &
                              mask(:, j2))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
                x_tmp = pack(x(j1, :), &
                              mask(j1, :))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_2_rdp_dp
      module function median_mask_3_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        real(dp), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(:, j2, j3), &
                              mask(:, j2, j3))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(j1, :, j3), &
                              mask(j1, :, j3))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
                x_tmp = pack(x(j1, j2, :), &
                              mask(j1, j2, :))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_3_rdp_dp
      module function median_mask_4_rdp_dp(x, dim, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer(kind = int64) :: c, n
        integer :: j1
        integer :: j2
        integer :: j3
        integer :: j4
        real(dp), allocatable :: x_tmp(:)

        if (any(shape(x) .ne. shape(mask))) then
            call error_stop("ERROR (median): shapes of x and mask are different")
        end if

        select case(dim)
          case(1)
            ! Loop over every dimension of the array except "dim"
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(:, j2, j3, j4), &
                              mask(:, j2, j3, j4))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j2, j3, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j2, j3, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j2, j3, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j2, j3, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(2)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j3 = 1, size(x, 3)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(j1, :, j3, j4), &
                              mask(j1, :, j3, j4))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j3, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j3, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j3, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j3, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(3)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j4 = 1, size(x, 4)
                x_tmp = pack(x(j1, j2, :, j4), &
                              mask(j1, j2, :, j4))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2, j4) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2, j4) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2, j4) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2, j4) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case(4)
            ! Loop over every dimension of the array except "dim"
              do j1 = 1, size(x, 1)
              do j2 = 1, size(x, 2)
              do j3 = 1, size(x, 3)
                x_tmp = pack(x(j1, j2, j3, :), &
                              mask(j1, j2, j3, :))

                  if (any(ieee_is_nan(x_tmp))) then
                    res(j1, j2, j3) = &
                      ieee_value(1._dp, ieee_quiet_nan)
                      cycle
                  end if

                call sort(x_tmp)

                n = size(x_tmp, kind=int64)
                c = floor( (n + 1) / 2._dp, kind=int64 )

                if (n == 0) then
                    res(j1, j2, j3) = &
                        ieee_value(1._dp, ieee_quiet_nan)
                else if (mod(n, 2_int64) == 0) then
                    res(j1, j2, j3) = &
                        sum(x_tmp(c:c+1)) / 2._dp
                else if (mod(n, 2_int64) == 1) then
                    res(j1, j2, j3) = x_tmp(c)
                end if

                deallocate(x_tmp)
              end do
              end do
              end do
          case default
            call error_stop("ERROR (median): wrong dimension")
        end select

      end function median_mask_4_rdp_dp

end submodule


PROGRAM F046

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER, PARAMETER :: MAX_N = 1E5

    INTEGER :: PRIME_NUM
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    INTEGER, DIMENSION(MAX_N)     :: PRIMES_LIST

    INTEGER :: SMALLEST_ODD_COMPOSITE_NUMBER = 0
    INTEGER :: I, J

    REAL    :: B

    LOGICAL :: PRIME_FOUND

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO
        READ(2, *, END=10) PRIME_NUM
        IF (PRIME_NUM > MAX_N) EXIT
        PRIMES_LIST(PRIME_NUM) = 1
    END DO

    10 CLOSE(2)

    DO I = 35, MAX_N, 2

        IF (PRIMES_LIST(I) /= 0) CYCLE

        J = 2
        PRIME_FOUND = .FALSE.
        DO WHILE (J < I)

            IF (PRIMES_LIST(J) == 0) THEN
                J = J + 1
                CYCLE
            END IF

            B = SQRT(FLOAT(I - J) / 2.0)

            IF (B - REAL(INT(B)) <= 0) THEN
                PRIME_FOUND = .TRUE.
                EXIT
            END IF

            J = J + 1

        END DO

        IF (.NOT. PRIME_FOUND) THEN
            SMALLEST_ODD_COMPOSITE_NUMBER = I
            EXIT
        END IF

    END DO

    PRINT ('(I0)'), SMALLEST_ODD_COMPOSITE_NUMBER

END PROGRAM F046


program Subspace_complex

use,intrinsic:: iso_fortran_env, only: int64, stderr=>error_unit
use,intrinsic:: iso_c_binding, only: c_int

use comm, only: dp, rand_init
use perf, only: sysclock2ms
use subspace, only: esprit_c
use signals,only: signoise

implicit none (type, external)

integer(c_int) :: Ns = 1024, &
                  Ntone=2
real(dp) :: fs=48000, &
            f0=12345.6, &
            snr=60  !dB
integer(c_int) :: M

complex(dp),allocatable :: x(:)
real(dp),allocatable :: tones(:),sigma(:)

integer(int64) :: tic,toc
integer :: narg
character(16) :: arg

call rand_init(.false., .false.)
!----------- parse command line ------------------
M = Ns / 4_c_int
narg = command_argument_count()

if (narg > 0) then
  call get_command_argument(1,arg); read(arg,*) Ns
endif
if (narg > 1) then
  call get_command_argument(2,arg); read(arg,*) fs
endif
if (narg > 2) then
  call get_command_argument(3,arg); read(arg,*) Ntone
endif
if (narg > 3) then
  call get_command_argument(4,arg); read(arg,*) M
endif
if (narg > 4) then
  call get_command_argument(5,arg); read(arg,*) snr !dB
endif

print *, "Fortran Esprit: Complex Double Precision"
!---------- assign variable size arrays ---------------
allocate(x(Ns), tones(Ntone), sigma(Ntone))
!--- checking system numerics --------------
if (storage_size(fs) /= 64) then
  write(stderr,*) 'expected 64-bit real but you have: ', storage_size(fs)
  error stop
endif
if (storage_size(x(1)) /= 128) then
  write(stderr,*) 'expected 128-bit complex but you have: ', storage_size(x(1))
  error stop
endif

!------ simulate noisy signal ------------
call signoise(fs,f0,snr,Ns,&
              x)
!------ estimate frequency of sinusoid in noise --------
call system_clock(tic)
call esprit_c(x, size(x,kind=c_int), Ntone, M, fs, &
            tones,sigma)
call system_clock(toc)

! -- assert <0.1% error ---------
if (abs(tones(1)-f0) > 0.001*f0)  error stop 'excessive estimation error'

print '(A,100F10.2)', 'estimated tone freq [Hz]: ',tones
print '(A,100F5.1)', 'with sigma: ',sigma
print '(A,F10.3)', 'seconds to estimate frequencies: ',sysclock2ms(toc-tic) / 1000

print *,'OK'

end program


C
C This is the FORTRAN version of program 2.1 from page 19 of
C "Modeling Infectious Disease in humans and animals"
C by Keeling & Rohani.
C
C It is the simple SIR epidemic without births or deaths.
C
C This code is written to be simple, transparent and readily compiled.
C Far more elegant and efficient code can be written.
C
C This code can be compiled using the intel fortran compiler:
C ifort -Vaxlib  -o Program_2_1  Program_2_1.f
C

C Main program starts here.

      program main

      REAL beta
      REAL gamma

      REAL S,I,R

      REAL S0
      REAL I0
      REAL MaxTime
      REAL EVERY, step, t

      INTEGER GivesName

      CHARACTER*2000 str, FileName

      COMMON /parameters/ beta, gamma
      COMMON /variables/ S, I, R

      GivesName=iargc()

      if (GivesName.eq.0) then
         beta=1.4247
         gamma=0.14286
         S0=1 - 1.0d-6
         I0=1.0d-6
         MaxTime=70
      else

c
c     READ IN ALL THE VARIABLES
c

         call getarg(1,FileName)

         open(1,file=FileName,STATUS='OLD',ACCESS='SEQUENTIAL')

         read(1,*) str
         read(1,*) beta

         read(1,*) str
         read(1,*) gamma

         read(1,*) str
         read(1,*) S0

         read(1,*) str
         read(1,*) I0

         read(1,*) str
         read(1,*) MaxTime

         close(1)
      endif

C
C     Check all variables are OK & set up intitial conditions */
C

      if ( S0.le.0) then
         write(*,*) "ERROR: Initial level of susceptibles (",S0,") is
     .        less than or equal to zero."
         STOP
      endif

      if ( I0.le.0) then
         write(*,*) "ERROR: Initial level of infecteds (",I0,") is
     .        less than or equal to zero."
         STOP
      endif

      if ( beta.le.0) then
         write(*,*) "ERROR: Transmission rate beta (",beta,") is
     .        less than or equal to zero."
         STOP
      endif

      if ( gamma.le.0) then
         write(*,*) "ERROR: Recovery rate gamma (",gamma,") is
     .        less than or equal to zero."
         STOP
      endif

      if ( MaxTime.le.0) then
         write(*,*) "ERROR: Maximum run time (",MaxTime,") is
     .        less than or equal to zero."
         STOP
      endif

      if (S0+I0.ge.1) then
        write(*,*) "WARNING: Initial level of susceptibles+infecteds
     .        (",S0,"+",I0,"=",S0+I0,") is greater than one."
      endif

      if (beta.lt.gamma) then
        write(*,*) "WARNING: Basic reproductive ratio (R_0=",
     .        beta/gamma,") is less than one."
      endif

      S=S0
      I=I0
      R=1-S0-I0

C
C     Find a suitable time-scale for outputs
C
      step=0.01/((beta+gamma)*S0)

      Every=1.0/((beta+gamma)*S0)
      if (Every.gt.1) then
         Every=10.0**INT(log10(Every))
      else
         Every=10.0**INT(log10(Every)-1)
      endif
      DO WHILE (MaxTime/Every.gt.10000)
         Every=Every*10.0
      ENDDO

      open(1,recl=3000,file='Program_2_1_f.out',ACCESS='SEQUENTIAL')
C     for F77 use
C      open(1,file='Output_Risk',ACCESS='SEQUENTIAL')
C

C
C     The main iteration routine
C

      t=0
      write(1,*) t,S,I,R
      DO WHILE (t.lt.MaxTime)

         CALL Runge_Kutta(step)

         t=t+step

C     If time has moved on sufficiently, output the current data

         if( INT(t/Every).gt.INT((t-step)/Every) ) then
            write(1,*) t,S,I,R
         endif

      ENDDO

      END

      SUBROUTINE Runge_Kutta(step)

      REAL InitialPop(3), tmpPop(3)
      REAL dPop1(3), dPop2(3), dPop3(3), dPop4(3)

      REAL S,I,R, step
      COMMON /variables/ S, I, R

C
C     Integrates the equations one step, using Runge-Kutta 4
C     Note: we work with arrays rather than variables to make the
C     coding easier
C
      InitialPop(1)=S
      InitialPop(2)=I
      InitialPop(3)=R

      CALL Diff(InitialPop,dPop1)
      do k=1,3
         tmpPop(k)=InitialPop(k)+step*dPop1(k)/2.0
      ENDDO

      CALL Diff(tmpPop,dPop2)
      do k=1,3
         tmpPop(k)=InitialPop(k)+step*dPop2(k)/2.0
      ENDDO

      CALL Diff(tmpPop,dPop3)
      do k=1,3
         tmpPop(k)=InitialPop(k)+step*dPop3(k)
      ENDDO

      CALL Diff(tmpPop,dPop4)

      do k=1,3
         tmpPop(k)=InitialPop(k)+step*(dPop1(k)/6 + dPop2(k)/3 +
     .        dPop3(k)/3 + dPop4(k)/6)
      ENDDO

      S=tmpPop(1)
      I=tmpPop(2)
      R=tmpPop(3)

      RETURN
      END

C The Main Differential Equations.

      SUBROUTINE Diff(Pop, dPop)

      REAL Pop(3), dPop(3)

      REAL beta
      REAL gamma

      COMMON /parameters/ beta, gamma

C     Set up temporary variables to make the equations look neater

      REAL tmpS, tmpI, tmpR

      tmpS=Pop(1)
      tmpI=Pop(2)
      tmpR=Pop(3)

C
C     The differential equations
C

C     dS/dt =
      dPop(1) = - beta*tmpS*tmpI

C     dI/dt =
      dPop(2) = beta*tmpS*tmpI - gamma*tmpI

C     dR/dt =
      dPop(3) = gamma*tmpI

      RETURN
      END


! If we take 47, reverse and add, 47 + 74 = 121, which is palindromic.

! Not all numbers produce palindromes so quickly. For example,

! 349 + 943 = 1292,
! 1292 + 2921 = 4213
! 4213 + 3124 = 7337

! That is, 349 took three iterations to arrive at a palindrome.
!
! Although no one has proved it yet, it is thought that some numbers,
! like 196, never produce a palindrome. A number that never
! forms a palindrome through the reverse and add process is called
! a Lychrel number. Due to the theoretical nature of these numbers,
! and for the purpose of this problem, we shall assume that a number
! is Lychrel until proven otherwise. In addition you are given
! that for every number below ten-thousand, it will either (i)
! become a palindrome in less than fifty iterations, or, (ii) no one,
! with all the computing power that exists, has managed so far
! to map it to a palindrome. In fact, 10677 is the first
! number to be shown to require over fifty iterations
! before producing a palindrome:
! 4668731596684224866951378664 (53 iterations, 28-digits).
!
! Surprisingly, there are palindromic numbers that are
! themselves Lychrel numbers; the first example is 4994.

! How many Lychrel numbers are there below ten-thousand?

! Project Euler: 55
!
! Answer: 249

program main

implicit none

        integer, parameter :: MAX_ITER = 50;
        integer, parameter :: MAXIMUM = 10000;
        integer (kind=16), parameter :: ONE = 1;

        integer (kind=16) :: c = 0

        integer (kind=16) :: i
        do i = 1, MAXIMUM, 1

                if(is_lycherl(i)) then
                        call inc(c, ONE)
                endif

        enddo

        print*, c

contains

        subroutine inc(base, offset)

                integer (kind=16), intent(out) :: base;
                integer (kind=16), intent(in) :: offset;
                integer (kind=16) :: tmp;

                tmp = offset;
                base = base + tmp;

                return

        end subroutine inc

        function intrev(x)

                integer (kind=16), intent(in) :: x
                integer (kind=16) :: intrev
                integer (kind=16) :: tmp

                intrev  = 0
                tmp = x;

                do while (tmp /= 0)
                        intrev = intrev * 10
                        call inc(intrev, mod(tmp, 10));
                        tmp = tmp / 10
                enddo

                return

        end function intrev

        function is_lycherl(x)

                integer (kind=16), intent(in) :: x
                integer (kind=16) :: iterc
                integer (kind=16) :: n
                logical :: is_lycherl

                is_lycherl = .true.
                iterc = 1
                n = x

                call inc(n, intrev(n))

                do while(iterc < MAX_ITER)

                        if(is_palindrome(n)) then
                                is_lycherl = .false.
                                exit
                        endif

                        call inc(n, intrev(n))
                        call inc(iterc, ONE)

                enddo

                return

        end function is_lycherl

        function is_palindrome(x)

                integer (kind=16), intent(in) :: x;
                integer (kind=16) :: tmp;
                logical :: is_palindrome;

                tmp = x;
                is_palindrome = (intrev(x) == x);

                return

        end function is_palindrome

end program main