! fibonacci.f95
! Calculate Fibonacci numbers
!
! vim: set ft=fortran sw=2 ts=2 :

module fibonacci
  implicit none
  save

  integer, parameter :: pr = selected_int_kind(18)

contains

  recursive integer function fib_naive (n) result (res)

    implicit none

    integer :: n

    if (n < 2) then
      res = n
    else
      res = fib_naive (n-2) + fib_naive (n-1)
    end if

  end function fib_naive

  integer (kind=pr) function fib_iter (n)

    implicit none

    integer :: n, i
    integer (kind=pr) :: a, b, tmp

    a = 0_pr
    b = 1_pr

    do i = 1, n
      tmp = b
      b = a + b
      a = tmp
    end do

    fib_iter = a

  end function fib_iter

end module fibonacci


      SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform a symplectic scaling on the Hamiltonian matrix
C
C              ( A    G  )
C          H = (       T ),                                          (1)
C              ( Q   -A  )
C
C     i.e., perform either the symplectic scaling transformation
C
C                                   -1
C                 ( A'   G'  )   ( D   0 ) ( A   G  ) ( D  0   )
C          H' <-- (        T ) = (       ) (      T ) (     -1 ),    (2)
C                 ( Q'  -A'  )   ( 0   D ) ( Q  -A  ) ( 0  D   )
C
C     where D is a diagonal scaling matrix, or the symplectic norm
C     scaling transformation
C
C                  ( A''   G''  )    1  (   A   G/tau )
C          H'' <-- (          T ) = --- (           T ),             (3)
C                  ( Q''  -A''  )   tau ( tau Q   -A  )
C
C     where tau is a real scalar.  Note that if tau is not equal to 1,
C     then (3) is NOT a similarity transformation.  The eigenvalues
C     of H are then tau times the eigenvalues of H''.
C
C     For symplectic scaling (2), D is chosen to give the rows and
C     columns of A' approximately equal 1-norms and to give Q' and G'
C     approximately equal norms.  (See METHOD below for details.) For
C     norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.||
C     denotes the 1-norm (column sum norm).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBSCL  CHARACTER*1
C             Indicates which scaling strategy is used, as follows:
C             = 'S'       :  do the symplectic scaling (2);
C             = '1' or 'O':  do the 1-norm scaling (3);
C             = 'N'       :  do nothing; set INFO and return.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, and Q.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On input, if JOBSCL <> 'N', the leading N-by-N part of
C             this array must contain the upper left block A of the
C             Hamiltonian matrix H in (1).
C             On output, if JOBSCL <> 'N', the leading N-by-N part of
C             this array contains the leading N-by-N part of the scaled
C             Hamiltonian matrix H' in (2) or H'' in (3), depending on
C             the setting of JOBSCL.
C             If JOBSCL = 'N', this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N), if JOBSCL <> 'N';
C             LDA >= 1,        if JOBSCL =  'N'.
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C             (LDQG,N+1)
C             On input, if JOBSCL <> 'N', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangle of the lower left symmetric block Q of the
C             Hamiltonian matrix H in (1), and the N-by-N upper
C             triangular part of the submatrix in the columns 2 to N+1
C             of this array must contain the upper triangle of the upper
C             right symmetric block G of H in (1).
C             So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j)
C             and G(i,j) = G(j,i) is stored in QG(j,i+1).
C             On output, if JOBSCL <> 'N', the leading N-by-N lower
C             triangular part of this array contains the lower triangle
C             of the lower left symmetric block Q' or Q'', and the
C             N-by-N upper triangular part of the submatrix in the
C             columns 2 to N+1 of this array contains the upper triangle
C             of the upper right symmetric block G' or G'' of the scaled
C             Hamiltonian matrix H' in (2) or H'' in (3), depending on
C             the setting of JOBSCL.
C             If JOBSCL = 'N', this array is not referenced.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.
C             LDQG >= MAX(1,N), if JOBSCL <> 'N';
C             LDQG >= 1,        if JOBSCL =  'N'.
C
C     D       (output) DOUBLE PRECISION array, dimension (nd)
C             If JOBSCL = 'S', then nd = N and D contains the diagonal
C             elements of the diagonal scaling matrix in (2).
C             If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau
C             from (3). In this case, no other elements of D are
C             referenced.
C             If JOBSCL = 'N', this array is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C             If JOBSCL = 'N', this array is not referenced.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, then the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     1. Symplectic scaling (JOBSCL = 'S'):
C
C     First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms
C     of the rows and columns of A using a diagonal scaling matrix D_A.
C     Then, H is similarily transformed by the symplectic diagonal
C     matrix D1 = diag(D_A,D_A**(-1)).  Next, the off-diagonal blocks of
C     the resulting Hamiltonian matrix are equilibrated in the 1-norm
C     using the symplectic diagonal matrix D2 of the form
C
C                 ( I/rho    0   )
C            D2 = (              )
C                 (   0    rho*I )
C
C     where rho is a real scalar. Thus, in (2), D = D1*D2.
C
C     2. Norm scaling (JOBSCL = '1' or 'O'):
C
C     The norm of the matrices A and G of (1) is reduced by setting
C     A := A/tau  and  G := G/(tau**2) where tau is the power of the
C     base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and
C     ||.|| denotes the 1-norm.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., and Barth, E.
C         Fortran 77 Subroutines for Computing the Eigenvalues of
C         Hamiltonian Matrices. I: The Square-Reduced Method.
C         ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000.
C
C     NUMERICAL ASPECTS
C
C     For symplectic scaling, the complexity of the used algorithms is
C     hard to estimate and depends upon how well the rows and columns of
C     A in (1) are equilibrated.  In one sweep, each row/column of A is
C     scaled once, i.e., the cost of one sweep is N**2 multiplications.
C     Usually, 3-6 sweeps are enough to equilibrate the norms of the
C     rows and columns of a matrix.  Roundoff errors are possible as
C     LAPACK routine DGEBAL does NOT use powers of the machine base for
C     scaling. The second stage (equilibrating ||G|| and ||Q||) requires
C     N**2 multiplications.
C     For norm scaling, 3*N**2 + O(N) multiplications are required and
C     NO rounding errors occur as all multiplications are performed with
C     powers of the machine base.
C
C     CONTRIBUTOR
C
C     P. Benner, Universitaet Bremen, Germany, and
C     R. Byers, University of Kansas, Lawrence, USA.
C     Aug. 1998, routine DHABL.
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998, SLICOT Library version.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 2009.
C
C     KEYWORDS
C
C     Balancing, Hamiltonian matrix, norms, symplectic similarity
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDQG, N
      CHARACTER         JOBSCL
C    ..
C    .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), D(*), DWORK(*), QG(LDQG,*)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION  ANRM, BASE, EPS, GNRM, OFL, QNRM,
     $                  RHO, SFMAX, SFMIN, TAU, UFL, Y
      INTEGER           I, IERR, IHI, ILO, J
      LOGICAL           NONE, NORM, SYMP
C     ..
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANSY
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, DLANGE, DLANSY, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL          DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
      INFO = 0
      SYMP = LSAME( JOBSCL, 'S' )
      NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' )
      NONE = LSAME( JOBSCL, 'N' )
C
      IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF(  LDA.LT.1 .OR. ( .NOT.NONE .AND.  LDA.LT.N ) ) THEN
         INFO = -4
      ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN
         INFO = -6
      END IF
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04DY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. NONE )
     $   RETURN
C
C     Set some machine dependant constants.
C
      BASE = DLAMCH( 'Base' )
      EPS  = DLAMCH( 'Precision' )
      UFL  = DLAMCH( 'Safe minimum' )
      OFL  = ONE/UFL
      CALL DLABAD( UFL, OFL )
      SFMAX = ( EPS/BASE )/UFL
      SFMIN = ONE/SFMAX
C
      IF ( NORM ) THEN
C
C        Compute norms.
C
         ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
         GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK )
         QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK )
         Y    = MAX( ONE, ANRM, GNRM, QNRM )
         TAU  = ONE
C
C        WHILE ( TAU < Y ) DO
   10    CONTINUE
         IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN
            TAU = TAU*BASE
            GO TO 10
         END IF
C        END WHILE 10
         IF ( TAU.GT.ONE ) THEN
            IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) )
     $         TAU = TAU/BASE
            CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR )
            CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG,
     $                   IERR )
            CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG,
     $                   IERR )
         END IF
C
         D(1) = TAU
C
      ELSE
         CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR )
C
         DO 30 J = 1, N
C
            DO 20 I = J, N
               QG(I,J) = QG(I,J)*D(J)*D(I)
   20       CONTINUE
C
   30    CONTINUE
C
         DO 50 J = 2, N + 1
C
            DO 40 I = 1, J - 1
               QG(I,J) = QG(I,J)/D(J-1)/D(I)
   40       CONTINUE
C
   50    CONTINUE
C
         GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK )
         QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK )
         IF ( GNRM.EQ.ZERO ) THEN
            IF ( QNRM.EQ.ZERO ) THEN
               RHO = ONE
            ELSE
               RHO = SFMAX
            END IF
         ELSE IF ( QNRM.EQ.ZERO ) THEN
            RHO = SFMIN
         ELSE
            RHO = SQRT( QNRM )/SQRT( GNRM )
         END IF
C
         CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR )
         CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG,
     $                IERR )
         CALL DRSCL( N, SQRT( RHO ), D, 1 )
      END IF
C
      RETURN
C     *** Last line of MB04DY ***
      END


! { dg-do "run" }
! Transformational intrinsic TRANSPOSE as initialization expression.

  INTEGER, PARAMETER :: n = 10
  INTEGER, PARAMETER :: a(n,1) = RESHAPE([ (i, i = 1, n) ], [n, 1])
  INTEGER, PARAMETER :: b(1,n) = TRANSPOSE(a)
  INTEGER, PARAMETER :: c(n,1) = TRANSPOSE(b)

  IF (ANY(c /= a)) CALL abort()
END


MODULE spline_module

  implicit none

  PRIVATE
  PUBLIC :: spline, splint

CONTAINS

  SUBROUTINE spline( x,y,n,yp1,ypn,y2 )
    implicit none
    integer,intent(IN)  :: n
    real(8),intent(IN)  :: x(n),y(n),yp1,ypn
    real(8),intent(OUT) :: y2(n)
    real(8),allocatable :: a(:),b(:),c(:),f(:)
    integer :: i
    allocate( a(n), b(n), c(n), f(n) )
    a=0.0d0 ; b=0.0d0 ; c=0.0d0 ; f=0.0d0
    do i=2,n-1
       a(i) = x(i) - x(i-1)
    end do
    do i=2,n-1
       b(i) = ( x(i+1) - x(i-1) )*2.0d0
    end do
    do i=2,n-2
       c(i) = x(i+1) - x(i)
    end do
    do i=2,n-1
       f(i) = 6.0d0*( (y(i+1)-y(i))/(x(i+1)-x(i)) &
                    - (y(i)-y(i-1))/(x(i)-x(i-1)) )
    end do
    do i=3,n-1
       b(i) = b(i) - a(i)*c(i-1)/b(i-1)
       f(i) = f(i) - a(i)*f(i-1)/b(i-1)
    end do
    y2(:)=0.0d0
    y2(n-1) = f(n-1)/b(n-1)
    do i=n-2,2,-1
       y2(i) = ( f(i) - c(i)*y2(i+1) )/b(i)
    end do
    deallocate( f, c, b, a )
  END SUBROUTINE spline

  SUBROUTINE splint( xa,ya,y2a,n,x,y )
    implicit none
    integer,intent(IN) :: n
    real(8),intent(IN) :: xa(n),ya(n),y2a(n),x
    real(8),intent(OUT) :: y
    integer :: k,khi,klo
    real(8) :: a,b,c,d,h
    klo = 1
    khi = n
1   if ( khi - klo > 1 ) then
       k = ( khi + klo )/2
       if ( xa(k) > x ) then
          khi = k
       else
          klo = k
       end if
       goto 1
    end if
    h = xa(khi) - xa(klo)
    if ( h == 0.0d0 ) stop "splint"
    a = ya(klo)
    b = ( ya(khi)-ya(klo) )/h - ( y2a(khi) + 2.0d0*y2a(klo) )*h/6.0d0
    c = y2a(klo)/2.0d0
    d = ( y2a(khi)-y2a(klo) )/(6.0d0*h)
    h = x - xa(klo)
    y = a + b*h + c*h**2 + d*h**3
  END SUBROUTINE splint

!
! from NUMERICAL RECIPES
!
  SUBROUTINE spline_nr(x,y,n,yp1,ypn,y2)
    implicit none
    integer :: n
    real(8) :: x(n),y(n),yp1,ypn,y2(n)
    integer,parameter :: nmax=50000
    integer :: i,k
    real(8) :: p,qn,sig,un,u(nmax)
    integer,save :: unit=300

    if ( yp1 > 1.d30 ) then
       y2(1) = 0.d0
       u(1) = 0.d0
    else
       y2(1) = -0.5d0
       u(1) = ( 3.d0/(x(2)-x(1)) )*( (y(2)-y(1))/(x(2)-x(1)) - yp1 )
    end if

    do i=2,n-1
       sig = ( x(i)-x(i-1) )/( x(i+1)-x(i-1) )
       p = sig*y2(i-1)+2.d0
       y2(i) = ( sig-1.d0 )/p
       u(i) = ( 6.d0*( (y(i+1)-y(i))/(x(i+1)-x(i)) &
            -(y(i)-y(i-1))/(x(i)-x(i-1)) )/(x(i+1)-x(i-1))-sig*u(i-1) )/p
    end do

    if ( ypn > 1.d30 ) then
       qn = 0.d0
       un = 0.d0
    else
       qn = 0.5d0
       un = ( 3.d0/(x(n)-x(n-1)) )*( ypn - (y(n)-y(n-1))/(x(n)-x(n-1)) )
    end if
    y2(n) = ( un - qn*u(n-1) )/( qn*y2(n-1) + 1.d0 )
    do k=n-1,1,-1
       y2(k) = y2(k)*y2(k+1) + u(k)
    end do

  END SUBROUTINE spline_nr

  SUBROUTINE splint_nr(xa,ya,y2a,n,x,y)
    implicit none
    integer :: n
    real(8) :: x,y,xa(n),y2a(n),ya(n)
    integer :: k,khi,klo
    real(8) :: a,b,h
    klo=1
    khi=n
1   if ( khi-klo > 1 ) then
       k=(khi+klo)/2
       if ( xa(k) > x ) then
          khi=k
       else
          klo=k
       end if
       goto 1
    end if
    h=xa(khi)-xa(klo)
    if ( h == 0.d0 ) stop "splint"
    a=(xa(khi)-x)/h
    b=(x-xa(klo))/h
    y=a*ya(klo)+b*ya(khi)+( (a**3-a)*y2a(klo)+(b**3-b)*y2a(khi) )*(h**2)/6.d0
  END SUBROUTINE splint_nr

END MODULE spline_module


PROGRAM F036

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    ! Initial values denoting the numbers 0, 1, 3, 5, 7, and 9.
    INTEGER :: SUM_VAL = 25

    CHARACTER (LEN=10) :: DECIMAL
    CHARACTER (LEN=30) :: BINARY

    LOGICAL :: IS_DECIMAL_PALINDROMIC, IS_BINARY_PALINDROMIC

    INTEGER :: I, J, DECIMAL_LEN, DECIMAL_LEN_BY_2,                            &
                      BINARY_LEN,  BINARY_LEN_BY_2,                            &
                        TEMP_LEN,  QUOTIENT

    DO I = 10, 1000000

        IF (MOD(I, 2) == 0) CYCLE

        DECIMAL     = ACHAR(0)
        WRITE (DECIMAL, '(I0)') I
        DECIMAL_LEN = LEN_TRIM(DECIMAL)

        IS_DECIMAL_PALINDROMIC = .TRUE.

        IF (DECIMAL_LEN /= 1) THEN

            DECIMAL_LEN_BY_2 = FLOOR(REAL(DECIMAL_LEN) / 2.0)
            DO J = 1, DECIMAL_LEN_BY_2
                TEMP_LEN = DECIMAL_LEN - J + 1
                IF (DECIMAL(J:J) /= DECIMAL(TEMP_LEN:TEMP_LEN)) THEN
                    IS_DECIMAL_PALINDROMIC = .FALSE.
                    EXIT
                END IF
            END DO

        END IF

        IF (.NOT. IS_DECIMAL_PALINDROMIC) CYCLE

        BINARY = ACHAR(0)

        J = 1
        QUOTIENT = I
        DO WHILE (QUOTIENT /= 0)
            WRITE (BINARY(J:J), '(I1)') MOD(QUOTIENT, 2)
            QUOTIENT = FLOOR(REAL(QUOTIENT) / 2.0)
            J = J + 1
        END DO

        IS_BINARY_PALINDROMIC = .TRUE.

        BINARY_LEN      = LEN_TRIM(BINARY)
        BINARY_LEN_BY_2 = FLOOR(REAL(BINARY_LEN) / 2.0)

        DO J = 1, BINARY_LEN_BY_2
            TEMP_LEN = BINARY_LEN - J + 1
            IF (BINARY(J:J) /= BINARY(TEMP_LEN:TEMP_LEN)) THEN
                IS_BINARY_PALINDROMIC = .FALSE.
                EXIT
            END IF
        END DO

        IF (.NOT. IS_BINARY_PALINDROMIC) CYCLE

        SUM_VAL = SUM_VAL + I

    END DO

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F036


! interp.f90 --
!
!     Example belonging to "Modern Fortran in Practice" by Arjen Markus
!
!     This work is licensed under the Creative Commons Attribution 3.0 Unported License.
!     To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
!     or send a letter to:
!     Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
!
!     Straightforward version of interpolation
!
module interpolation

    implicit none

contains

real function interpolate( x, y, xp )

    real, dimension(:), intent(in) :: x
    real, dimension(:), intent(in) :: y
    real, intent(in)               :: xp

    integer :: i
    integer :: idx

    !
    ! Search for the interval that contains xp
    !
    idx = size(x) - 1

    do i = 2,size(x)-1
        if ( xp < x(i) ) then
            idx = i - 1
            exit
        endif
    enddo

    interpolate = y(idx) + (xp - x(idx)) * (y(idx+1) - y(idx)) / &
                      (x(idx+1) -  x(idx))

end function interpolate

end module interpolation

program test_interpolation
    use interpolation

    implicit none

    real, dimension(6) :: x = (/ 0.0, 1.0, 10.0, 10.0, 20.0, 120.0 /)
    real, dimension(6) :: y = (/ 0.0, 2.0, 20.0, 20.0, 10.0, 10.0 /)

    integer            :: i
    real               :: xp

    do i = 1,20
        xp = -4.0 + 1.0 * i
        write(*,'(2g12.4)') xp, interpolate( x, y, xp )
    enddo

    xp = 9.8
    write(*,'(2g12.4)') xp, interpolate( x, y, xp )

end program


MODULE FUN_xySAREA
!!#### PURPOSE
!! Calculate the signed SAREA of various shapes:
!!  @ quadrilateral [Qg]
!!  @ Trangle <Tr>
!!  @ polygon <Po>

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_1_by_2_Rsp => c_1_by_2 !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_2_Rdp => c_1_by_2 !!((02-A-PAR_Constants_Rdp.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xySAREA_Tr
 MODULE PROCEDURE xySAREA_Tr_Rsp
 MODULE PROCEDURE xySAREA_Tr_Rdp
END INTERFACE

INTERFACE xySAREA_Qg
 MODULE PROCEDURE xySAREA_Qg_Rsp
 MODULE PROCEDURE xySAREA_Qg_Rdp
END INTERFACE

INTERFACE xySAREA_Pg
 MODULE PROCEDURE xySAREA_Pg_Rsp
 MODULE PROCEDURE xySAREA_Pg_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xySAREA_Tr
PUBLIC :: xySAREA_Qg
PUBLIC :: xySAREA_Pg

CONTAINS

PURE FUNCTION xySAREA_Tr_Rsp( Tr ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "03-A-FUN_xySAREA_Tr.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Tr.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySAREA_Tr_Rdp( Tr ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "03-A-FUN_xySAREA_Tr.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Tr.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySAREA_Qg_Rsp( Qg ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "03-A-FUN_xySAREA_Qg.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Qg.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySAREA_Qg_Rdp( Qg ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "03-A-FUN_xySAREA_Qg.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Qg.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySAREA_Pg_Rsp( N , Pg ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "03-A-FUN_xySAREA_Pg.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Pg.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySAREA_Pg_Rdp( N , Pg ) RESULT(SAREA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "03-A-FUN_xySAREA_Pg.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySAREA_Pg.f90.bdy"
!!--end--
END FUNCTION

END MODULE


c fishpk25 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c          program to illustrate the use of subroutine hwscrt to solve
c     the equation
c
c     (d/dx)(du/dx) + (d/dy)(du/dy) - 4*u
c
c     = (2 - (4 + pi**2/4)*x**2)*cos((y+1)*pi/2)
c
c     with the boundary conditions
c     on the rectangle 0 .lt. x .lt. 2, -1 .lt. y .lt. 3 with the
c
c     u(0,y) = 0
c                                          -1 .le. y .le. 3
c     (du/dx)(2,y) = 4*cos((y+1)*pi/2)
c
c     and with u periodic in y.
c          the x-interval will be divided into 40 panels and the
c     y-interval will be divided into 80 panels.
c
      program thwscrt
      dimension       f(45,82)   ,bdb(81)    ,w(1103)    ,x(41)      ,
     1                y(81)
      dimension bda(1), bdc(1), bdd(1)
c
c     from dimension statement we get value of idimf.  also note that w
c     is dimensioned 4*(n+1) + (13 + int(log2(n+1)))*(m+1) .
c
      idimf = 45
      a = 0.
      b = 2.
      m = 40
      mbdcnd = 2
      c = -1.
      d = 3.
      n = 80
      nbdcnd = 0
      elmbda = -4.
c
c     auxiliary quantities.
c
      pi = pimach(dum)
      piby2 = pi/2.
      pisq = pi**2
      mp1 = m+1
      np1 = n+1
c
c     generate and store grid points for the purpose of computing
c     boundary data and the right side of the helmholtz equation.
c
      do 101 i=1,mp1
         x(i) = float(i-1)/20.
  101 continue
      do 102 j=1,np1
         y(j) = -1.+float(j-1)/20.
  102 continue
c
c     generate boundary data.
c
      do 103 j=1,np1
         bdb(j) = 4.*cos((y(j)+1.)*piby2)
  103 continue
c
c     bda, bdc, and bdd are dummy variables.
c
      do 104 j=1,np1
         f(1,j) = 0.
  104 continue
c
c     generate right side of equation.
c
      do 106 i=2,mp1
         do 105 j=1,np1
            f(i,j) = (2.-(4.+pisq/4.)*x(i)**2)*cos((y(j)+1.)*piby2)
  105    continue
  106 continue
      call hwscrt (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error.  the exact solution is
c                u(x,y) = x**2*cos((y+1)*piby2)
c
      err = 0.
      do 108 i=1,mp1
         do 107 j=1,np1
            z = abs(f(i,j)-x(i)**2*cos((y(j)+1.)*piby2))
            if (z .gt. err) err = z
  107    continue
  108 continue
      print 1001 , ierror,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hwscrt example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 5.36508e-04/
     4        12x,32hrequired length of w array = 880//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,f4.0)
c
      end
c


! Learn_dg - A quick and dirty project to deploy a working DG solver
! Copyright (c) 2017, Chris Coutinho
! All rights reserved.
!
! Licensed under the BSD-2 clause license. See LICENSE for details.

module mod_integration
    use, intrinsic  :: iso_fortran_env, only: wp=>real64
    use             :: lib_array,       only: linspace
    implicit none

    private
    public :: integrate
    interface integrate
        module procedure integrate1D
        module procedure integrate2D
    end interface integrate

    interface
        module function fun2d_interf(x, y) result(z)
            real(wp), intent(in)  :: x(:,:), y(:,:)
            real(wp), allocatable :: z(:,:)
        end function

        module function fun1d_interf(xx) result(yy)
            real(wp), intent(in)  :: xx(:)
            real(wp), allocatable :: yy(:)
        end function fun1d_interf

        module subroutine gaussquad(N, x, w)
            integer,  intent(in)  :: N
            real(wp), intent(out) :: x(N), w(N)
        end subroutine gaussquad
    end interface

contains

    module function integrate1D(fun, xbnds) result(result)
        ! This routine uses gauss-legendre quadrature to integrate a 1D
        ! line function

        ! Input/Output dummy variables
        real(wp), intent(in)    :: xbnds(2)
        real(wp)                :: result
        procedure(fun1d_interf) :: fun

        ! Local variables
        integer, parameter    :: N_start = 2
        integer               :: N
        real(wp)              :: result_old, error
        real(wp), parameter   :: eps = epsilon(0e0)
        real(wp), allocatable :: x(:), w(:), y(:)

        N = N_start
        result = 0.0_wp
        error = 1.0_wp

        do
            result_old = result

            allocate(x(N), w(N), y(N))

            call gaussquad(N, x, w)

            y = fun(x)
            result = dot_product(y, w)

            deallocate(x, w, y)

            ! error = norm2([result, result_old])
            error = sqrt((result-result_old)**2.0_wp)
            ! error = abs((result-result_old)/(result_old+eps))
            ! print*, N, result, error
            ! print*, N, result, result_old, error, eps

            ! Check if error is acceptable, as well as whether the loop
            ! was gone through at least twice (N = 3, 4, 5...)
            if ( N > N_start .and. &
                norm2( [ error ] ) <= eps ) then
                ! print'(a,i3,a,e13.5)',  'Fun integrated in ', N, &
                !                         ' iterations. Error = ', error
                exit
            else
                N = N + 1
            endif
        enddo
        return
    end function integrate1D

    module function integrate2D(fun, xbnds, ybnds) result(out)
        procedure(fun2d_interf) :: fun
        real(wp), intent(in)    :: xbnds(2), ybnds(2)
        real(wp)                :: out

        integer, parameter                    :: N_start = 4
        integer                               :: ii, N
        real(wp)                              :: out_old, error
        real(wp), parameter                   :: eps = epsilon(0e0)
        real(wp), dimension(:),   allocatable :: x, w
        real(wp), dimension(:,:), allocatable :: xx, yy
        real(wp), dimension(:,:), allocatable :: wx, wy
        real(wp), dimension(:,:), allocatable :: out_spread

        ! Adaptive integration based on 2D Gauss-Legendre Quadrature
        ii    = 1       ! Iteration number
        N     = N_start ! Initial number of points to use
        error = 1._wp   ! Initial estimate of error

        do
            ! Allocate x (positions) and w (weights) based on roots of the Legendre
            ! polynomial of order 'N'
            allocate(x(N), w(N))
            allocate(xx(N,N), yy(N,N))
            allocate(wx(N,N), wy(N,N))
            allocate(out_spread(N,N))

            call gaussquad(N, x, w)

            ! Copy the 'x' array along both the x and y axes
            xx = spread(x, dim=1, ncopies=N)
            yy = spread(x, dim=2, ncopies=N)

            ! Copy the weights along both the x and y axes as well
            wx = spread(w, dim=1, ncopies=N)
            wy = spread(w, dim=2, ncopies=N)

            ! Calculate the function at the xx and yy nodes, and
            ! multiply the result with the weights: wx and wy
            out_spread = fun(xx, yy) * wx * wy

            ! Sum up the resulting array into a single scalar output
            out = sum(reshape( out_spread, [N*N,1] ))
            ! print*, out

            ! Set error if ii > 1
            if ( ii>1 ) then
                error = out - out_old
            else
                error = 1._wp
            endif

            ! Deallocate all arrays no longer needed. They will change
            ! size in each iteration anyway

            deallocate(x, w, xx, yy, wx, wy, out_spread)

            ! If iteration counter is more than 1 then check exit
            ! criteria
            if ( N > N_start .and. &
                norm2( [ error ] ) <= eps ) then
                ! print'(a,i3,a,e13.5)', 'Fun integrated in ', N, &
                !                        ' iterations. Error = ', error
                exit
            else
                out_old = out
                ii = ii + 1
                N = N + 1
            endif

        enddo

        return
    end function

end module mod_integration


module vector_math
    implicit none
    ! Constants
    double precision, parameter :: pi = 3.141592653589793

contains

    function vector_sin(vec) result(result_sin)
        implicit none
        ! Input
        double precision, dimension (:), intent(in) :: vec
        ! Output
        double precision, allocatable, dimension (:) :: result_sin
        ! Internal
        integer :: n, i

        ! Statements Execution
        n = size( vec )
        allocate( result_sin(n) )
        do i = 1, n
            result_sin(i) = sin(i * pi/n)
        end do

    end function vector_sin

end module vector_math


      FUNCTION snrm(n,sx,itol)
      INTEGER n,itol,i,isamax
      DOUBLE PRECISION sx(n),snrm
      if (itol.le.3)then
        snrm=0.
        do 11 i=1,n
          snrm=snrm+sx(i)**2
11      continue
        snrm=sqrt(snrm)
      else
        isamax=1
        do 12 i=1,n
          if(abs(sx(i)).gt.abs(sx(isamax))) isamax=i
12      continue
        snrm=abs(sx(isamax))
      endif
      return
      END

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


MODULE m_matrixinv

! ----------------------------------------------------------------------
! MODULE: m_matrixinv
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the following subroutines
!
! Subroutines contained within the module:
! - matrixinv
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	22 March 2018
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE matrixinv (Amatrix, AmatrixInv, An)

! ----------------------------------------------------------------------
! SUBROUTINE: matrixinv
! ----------------------------------------------------------------------
! Purpose:
!  Matrix inversion based on LAPACK library
! ----------------------------------------------------------------------
! Input arguments:
! - Amatrix : 		Matrix with dimensions ixj
!
! Output arguments:
! - AmatrixInv :	Inverse of input matrix Amatrix
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
! 			Geoscience Australia
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	22 March 2018
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: An
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:), ALLOCATABLE :: Amatrix
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: AmatrixInv
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      !INTEGER (KIND = prec_int8) :: n, m, info
      INTEGER :: n, m, info
! ----------------------------------------------------------------------
      !REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: work_matrix
      !DOUBLE PRECISION   WORK( * )
	  !Integer, Dimension(:), ALLOCATABLE :: ipiv
	  Integer (KIND = prec_int8) :: ipiv(An)
      REAL (KIND = prec_d) :: WORK(An)
      REAL (KIND = prec_q) :: Nmatrix(An,An)
      REAL (KIND = prec_q) :: NmatrixInv(An,An)
      INTEGER (KIND = prec_int2) :: AllocateStatus
!       , DeAllocateStatus

! External procedures in LAPACK library
external DGETRF
external DGETRI

n = size(Amatrix, DIM = 1)
m = size(Amatrix, DIM = 2)

ALLOCATE (AmatrixInv(n,n), STAT = AllocateStatus)
!ALLOCATE (work_matrix(n), STAT = AllocateStatus)
!ALLOCATE (ipiv(n), STAT = AllocateStatus)

Nmatrix = Amatrix
NmatrixInv = Nmatrix

! ----------------------------------------------------------------------
! LU factorization using partial pivoting with row interchanges
!SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!call DGETRF(n, n, AmatrixInv, n, ipiv, info)
call DGETRF(n, n, NmatrixInv, n, ipiv, info)
!print *,"info", info
if (info /= 0) then
   !stop 'Matrix is numerically singular!'
   print *,"Matrix is numerically singular"
end if
! ----------------------------------------------------------------------
! DGETRI computes the inverse of an LU-factored general matrix computed by DGETRF.
!SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
!call DGETRI(n, AmatrixInv, n, ipiv, WORK, n, info)
call DGETRI(n, NmatrixInv, n, ipiv, WORK, n, info)

if (info /= 0) then
   !stop 'Matrix inversion failed!'
   print *,"Matrix inversion failed"
end if
! ----------------------------------------------------------------------

AmatrixInv = NmatrixInv

END SUBROUTINE

END Module


c     program DRDBACC
c>> 1996-05-28 DRDBACC  Krogh Moved formats up.
c>> 1994-10-19 DRDBACC  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDBACC  Lawson  Initial Code.
c--D replaces "?": DR?BACC, ?BACC, ?BSOL
c     Demonstration driver for DBACC & DBSOL
c     C. L. Lawson & S. Y. Chiu, JPL, July 1987, Sept 1987.
c     ------------------------------------------------------------------
      integer NX, LDG, NB, ISCALE
      integer I, IERR2, IERR3, IG, IR, J, JT, JTPREV, MT, MTOTAL
      parameter(NX = 10, LDG = 24, NB = 2, ISCALE = 6)
      double precision XTAB(NX), G(LDG,3), YFIT(NX), C(NX,NX)
      double precision DELX, DOF, DTOR, RDUMMY, RNORM, SIGFAC, VFAC
      double precision X, YF, YTRUE
      double precision ZERO, XINC, XLIMIT
      double precision ONE, C45, HALF
      parameter(ZERO = 0.0D0, XINC = 1.0D0, XLIMIT = 89.5D0)
      parameter(ONE = 1.0D0, C45 = 45.0D0, HALF = 0.5D0)
      data XTAB / 00.0D0, 10.0D0, 20.0D0, 30.0D0, 40.0D0,
     *            50.0D0, 60.0D0, 70.0D0, 80.0D0, 90.0D0 /
c
 1000 format(' Calling DBACC with JT =',i3,', MT =',i3)
 1003 format(1x/'     X       Y        YFIT   R=Y-YFIT'/1X)
 1004 format(1X, F6.1, 3F10.5)
 1006 format(1X,10(F7.2,1X))
c     ------------------------------------------------------------------
      write(*,'(1x,a//1x,a/1x,a/1x)')
     *'        Demonstration driver for DBACC and DBSOL.',
     *'Compute least-squares fit of a continuous piecewise linear',
     *'     function to the sine function on 0 to 90 degrees.'
      DTOR = atan(ONE)/C45
      MTOTAL = 0
      IR = 1
      MT = 0
      JT = 1
      IG = 0
      X = -XINC
      DELX = XTAB(JT+1) - XTAB(JT)
c
   20 if( X .lt. XLIMIT)then
         X = X + XINC
         MTOTAL = MTOTAL + 1
      if(X .gt. XTAB(JT+1))then
            write(*,1000) JT, MT
            call DBACC(G,LDG,NB,IR,MT,JT,JTPREV, IERR2)
            IG = IR-1
            MT = 0
            JT = min(JT+1, NX-1)
            DELX = XTAB(JT+1) - XTAB(JT)
      end if
         IG = IG + 1
         MT = MT + 1
         G(IG,1) = (XTAB(JT+1) - X) / DELX
         G(IG,2) = (X - XTAB(JT)) / DELX
         G(IG,3) = sin(x * DTOR)
      go to 20
      end if

      if(MT .gt. 0)then
         write(*,1000) JT, MT
         call DBACC(G,LDG,NB,IR,MT,JT,JTPREV, IERR2)
      end if

      call DBSOL(1,G,LDG,NB,IR,JTPREV,YFIT,NX,RNORM, IERR3)
c                       The following statement does a type conversion.
      DOF = MTOTAL - NX
      SIGFAC = RNORM / SQRT(DOF)
      write(*,'(1x/1x, a, i4, a, f10.5, a, f10.5)')
     *  'MTOTAL =', MTOTAL, ',  RNORM =', RNORM, ',  SIGFAC =', SIGFAC
      write(*,1003)
      do 30 I=1,NX
         YTRUE = sin(XTAB(I)*DTOR)
         write(*,1004) XTAB(I),YTRUE,YFIT(I),YFIT(I) - YTRUE
      if( I .ne. NX)then
            X = HALF*(XTAB(I+1) + XTAB(I))
            YF = HALF*(YFIT(I+1) + YFIT(I))
            YTRUE = sin(X*DTOR)
            write(*,1004) X,YTRUE,YF,YF - YTRUE
      end if
   30 continue
c
c     Compute unscaled covariance matrix in C(,).
c
      do 50 J = 1,NX
        do 40 I = 1,NX
            C(I,J) = ZERO
   40   continue
        C(J,J) = ONE
        call DBSOL(2,G,LDG,NB,IR,JTPREV,C(1,J),NX,RDUMMY,IERR3)
        call DBSOL(3,G,LDG,NB,IR,JTPREV,C(1,J),NX,RDUMMY,IERR3)
   50 continue
c
      write(*,'(1x/10x,a,i1/1x)')
     *  'Covariance matrix scaled up by 10**',ISCALE
c
      VFAC = (10**ISCALE) * SIGFAC**2
      do 60 I = 1,NX
        print 1006,(VFAC*C(I,J),J=1,NX)
   60 continue
c
      stop
      end


program givcor
!   Given two arrays of equal length of unordered values, find a
!   "matching value" in the second array for each value in the
!   first so that the global correlation coefficient reaches
!   exactly a given target.
! _________________________________________________________________
!   The routine first sorts the two arrays, so as to get the
!   match of maximum correlation.
!   It then will iterate, applying the random permutation algorithm
!   of controlled disorder ctrper to the second array. When the
!   resulting correlation goes beyond (lower than) the target
!   correlation, one steps back and reduces the disorder parameter
!   of the permutation. When the resulting correlation lies between
!   the current one and the target, one replaces the array with
!   the newly permuted one. When the resulting correlation increases
!   from the current value, one increases the disorder parameter.
!   That way, the target correlation is approached from above, by
!   a controlled increase in randomness.
!   The example is two arrays representing parents' incomes and
!   children's incomes, but where it is not known which parents
!   correspond to which children. The output is a list of pairs
!   {parents' income, children's income} such that the target
!   correlation is approached.
!   Michel Olagnon - December 2001.
!   Corrected August 2007 (dot_product (xnewt, xpart) line 87,
!             and negative correlation targets).
! _________________________________________________________________
      use m_ctrper
      use m_refsor
!
      Integer, Parameter :: ndim = 21571   ! Number of pairs
      Integer, Parameter :: kdp = selected_real_kind(15)
      Real(kind=kdp), Parameter :: dtar = 0.1654_kdp ! Target correlation
      Real(kind=kdp) :: dsum, dref, dmoyp, dsigp, dmoyc, dsigc, dtarw
      Real(kind=kdp), Dimension (ndim) :: xpart, xchit, xnewt
      Real :: xper = 0.25
      Real :: xdec = 0.997
      Integer, Dimension (:), Allocatable :: jseet, jsavt
      Integer :: nsee, ibcl
!
      Call random_seed (size=nsee)
      Allocate (jseet(1:nsee), jsavt(1:nsee))
!
!   Read parent's incomes
!
      Open (unit=11, file="parents.dat", form="formatted", status="old", action="read")
      Do ibcl = 1, ndim
        read (unit=11, fmt=*) xpart (ibcl)
      End Do
      Close (unit=11)
!
!   Sort, and normalize to make further correlation computations faster
!
      call refsor (xpart)
      dmoyp = sum (xpart) / real (ndim, kind=kdp)
      xpart = xpart - dmoyp
      dsigp = sqrt(dot_product(xpart,xpart))
      xpart = xpart * (1.0_kdp/dsigp)
!
!   Read children's incomes
!
      Open (unit=12, file="children.dat", form="formatted", status="old", action="read")
      Do ibcl = 1, ndim
        read (unit=12, fmt=*) xchit (ibcl)
      End Do
      Close (unit=12)
!
!   Sort, and normalize
!
      call refsor (xchit)
      dmoyc = sum (xchit) / real (ndim, kind=kdp)
      xchit = xchit - dmoyc
      dsigc = sqrt(dot_product(xchit,xchit))
      if (dtar < 0.0_kdp) then
         xchit = - xchit * (1.0_kdp/dsigc)
      else
         xchit = xchit * (1.0_kdp/dsigc)
      endif
      dtarw = abs (dtar)
!
!   Compute starting value, maximum correlation
!
      dref = dot_product(xpart,xchit)
!      write (unit=*, fmt="(f8.6)") dref
!
!   Iterate
!
      Do ibcl = 1, 100000
        xnewt = xchit
!
!   Add some randomness to the current order
!
        Call ctrper (xnewt, xper)
        dsum = dot_product(xnewt, xpart)
!    if (modulo (ibcl,100) == 1) write (unit=*, fmt=*) ibcl, dref, dsum, xper
!
!   Check for hit of target
!
        if (abs (dsum-dtarw) < 0.00001_kdp) then
           dref = dsum
           xchit = xnewt
           exit
        End If
!
!   Better, but not yet reached target: take new set as current one
!
        if (dsum < dref .and. dsum > dtarw) then
           dref = dsum
           xchit = xnewt
!
!   We went too far, beyond the target: try to be a little less random
!
        elseif (dsum < dtarw) then
           xper = max (xper * xdec, 0.5 / Real(ndim))
!
!   We are going in the ordered direction: try to be a little more random
!
        elseif (dsum > dref) then
           xper = min (xper / xdec, 0.25)
        endif
      End Do
!
!   Unnormalize and output pairs
!
      write (unit=*, fmt="(a,f10.8,a,i8)") "Reached ", dref, &
                                           "after iteration ", ibcl
      xpart = dmoyp + dsigp * xpart
      if (dtar < 0.0_kdp) then
         xchit = dmoyc - dsigc * xchit
      else
         xchit = dmoyc + dsigc * xchit
      endif
      Open (unit=13, file="corchild.dat", form="formatted", status="unknown",&
            action="write")
      Do ibcl = 1, ndim
           write (unit=13, fmt=*) nint(xpart(ibcl)), nint(xchit(ibcl))
      End Do
      Close (unit=13)
!
end program givcor


      SUBROUTINE SINFT1(Y,N)
! This is a version of Numerical Recipes fast sine transform routine.
      IMPLICIT NONE
      INTEGER n, j
      REAL(4) y(n),y1,y2,SUM
      REAL(8) WR,WI,WPR,WPI,WTEMP,THETA

      THETA=3.141592653589793D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      Y(1)=0.0d0
      DO 11 J=1,N/2
         WTEMP=WR
         WR=WR*WPR-WI*WPI+WR
         WI=WI*WPR+WTEMP*WPI+WI
         Y1=WI*(Y(J+1)+Y(N-J+1))
         Y2=0.5d0*(Y(J+1)-Y(N-J+1))
         Y(J+1)=Y1+Y2
         Y(N-J+1)=Y1-Y2
11    END DO
      CALL REALFT(Y,N,+1)
      SUM=0.0d0
      Y(1)=0.5d0*Y(1)
      Y(2)=0.0d0
      DO 12 J=1,N-1,2
         SUM=SUM+Y(J)
         Y(J)=Y(J+1)
         Y(J+1)=SUM
12    END DO
      RETURN
      END SUBROUTINE SINFT1


program main
    use parser_module
    implicit none
    type(Parser) :: p
    class(*), allocatable :: ans

    call p % register_function(["sin ", "sqrt"])
    call p % register_operator(["+","-","*","/"])
    call p % register_operator(["^"], is_right_assoc=.true.)

    p % on_operator => on_operator
    p % on_function => on_function
    p % on_operand  => on_operand

    ans = p % parse("sqrt(2)*sin(pi/4) + 3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3")
    select type(ans); type is (real)
        print*, ans
    end select

contains

    function on_operand(self, lhs, opr, rhs) result(ans)
        class(Parser) :: self
        class(*) :: opr
        class(*), optional :: lhs
        class(*), optional :: rhs
        class(*), allocatable :: ans

        select type(opr)
        type is (character(*))
            select case(opr)
            case('pi'); allocate(ans, source=4*atan(1.))
            case default; block
                integer :: info
                real :: value
                read(opr,*,iostat=info) value
                if (info == 0) allocate(ans, source=value)
            end block; end select
        class default
            allocate(ans, source=opr)
        end select
    end function

    function on_function(self, lhs, opr, rhs) result(ans)
        class(Parser) :: self
        class(*) :: opr
        class(*), optional :: lhs
        class(*), optional :: rhs
        class(*), allocatable :: ans

        select type(opr)
        type is (character(*))
            select type(rhs)
            type is (real)
                select case(opr)
                case('sqrt'); ans = sqrt(rhs)
                case('sin');  ans = sin(rhs)
                end select
            end select
        end select
    end function

    function on_operator(self, lhs, opr, rhs) result(ans)
        class(Parser) :: self
        class(*) :: opr
        class(*), optional :: lhs
        class(*), optional :: rhs
        class(*), allocatable :: ans
        real :: lhs_val, rhs_val

        select type(lhs)
        type is (real)
            lhs_val = lhs
        end select

        select type(rhs)
        type is (real)
            rhs_val = rhs
        end select

        select type(opr)
        type is (character(*))
            select case(opr)
            case('+'); allocate(ans, source=lhs_val+rhs_val)
            case('-'); allocate(ans, source=lhs_val-rhs_val)
            case('*'); allocate(ans, source=lhs_val*rhs_val)
            case('/'); allocate(ans, source=lhs_val/rhs_val)
            case('^'); allocate(ans, source=lhs_val**rhs_val)
            end select
        end select
    end function
end program


module loglikelihood_module
    use utils_module, only: dp

    contains

    !> Half Gaussian likelihood with mean mu(:) and an uncorrelated covariance sigma(:).
    !!
    !! It is normalised so that it should output an evidence of 1.0 for
    !! effectively infinite priors.
    !!
    !! The mean is set at 0.5 by default, but in the first coordinate the mean is at 0.0, at the edge of the prior
    !! all sigmas are 0.01
    function loglikelihood(theta,phi)
        use utils_module, only: logTwoPi,Vn
        implicit none
        !> Input parameters
        real(dp), intent(in), dimension(:)   :: theta
        !> Output derived parameters
        real(dp), intent(out),  dimension(:) :: phi

        real(dp) :: loglikelihood

        real(dp), dimension(size(theta)) :: sigma ! Standard deviation (uncorrelated)
        real(dp), dimension(size(theta)) :: mu    ! Mean

        ! Initialise the mean and standard deviation
        mu    = 5d-1   ! mean in the center
        sigma = 1d-1  ! all sigma set relatively small

        ! x direction mean at the edge
        mu(1) = 0d0

        ! Gaussian normalisation
        loglikelihood = - sum( log( sigma ) + logTwoPi/2d0 ) + log(2d0)

        ! theta dependence
        loglikelihood = loglikelihood - sum( ( ( theta - mu ) / sigma ) ** 2d0 ) / 2d0

        ! The radius
        phi(1) = sqrt(sum((theta-mu)**2))
        phi(2) = log(phi(1)**size(theta) * Vn(size(theta))/2d0)

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

    end subroutine setup_loglikelihood

end module loglikelihood_module


	FUNCTION PR_HGMF  ( hght )
C************************************************************************
C* PR_HGMF								*
C*									*
C* This function computes HGFT from HGHT.  The following equation is	*
C* used:  								*
C*									*
C*                HGFT  =  NINT ( HGHT * 3.28084 )			*
C*									*
C* (Note:  This function rounds to the nearest foot.)			*
C*									*
C* REAL PR_HGMF  ( HGHT )						*
C*									*
C* Input parameters:							*
C*	HGHT		REAL		Height in meters		*
C*									*
C* Output parameters:							*
C*	PR_HGMF		REAL		Height in feet  		*
C**									*
C* Log:									*
C* G. Huffman/GSC	7/88	Build from PR_HTMT			*
C* S. Schotz/GSC	10/89   modify to round to nearest foot		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for invalid data.
C
	IF  ( ERMISS ( hght ) )  THEN
	    PR_HGMF = RMISSD
	  ELSE
C
C*	    Do the conversion.
C
	    PR_HGMF = NINT(hght * 3.28084)
	END IF
C*
	RETURN
	END


!---------------------------------------------------------------------------
!> @brief Compute the intensity of light.
!
!> @param[in] doy: Day of year.
!> @param[in] height: Distance from ground in cm.
!
!> @return intensity: Intensity of light in ergs cm^-2 s^-1.
!---------------------------------------------------------------------------
function light(doy, height) result(intensity)
  real(kind=8) :: doy
  real(kind=8) :: height
  real(kind=8) :: intensity
  real, parameter :: Pi = 3.1415927

  ! Define parameters that are static across a run
  real, parameter :: amplitude = 80.0
  real, parameter :: doy_offset = 0.0

  ! Calculate intensity
  intensity = amplitude * height * (1.0 + SIN(2.0 * Pi * (doy - doy_offset) / 365))
end function light


*DECK DFNORM
      DOUBLE PRECISION FUNCTION DFNORM (N, A, W)
C-----------------------------------------------------------------------
C This function computes the norm of a full N by N matrix,
C stored in the array A, that is consistent with the weighted max-norm
C on vectors, with weights stored in the array W:
C   DFNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) )
C-----------------------------------------------------------------------
      INTEGER N,   I, J
      DOUBLE PRECISION A,   W, AN, SUM
      DIMENSION A(N,N), W(N)
      AN = 0.0D0
      DO 20 I = 1,N
        SUM = 0.0D0
        DO 10 J = 1,N
 10       SUM = SUM + ABS(A(I,J))/W(J)
        AN = MAX(AN,SUM*W(I))
 20     CONTINUE
      DFNORM = AN
      RETURN
C----------------------- End of Function DFNORM ------------------------
      END


C Quick portable random number generator from Numerical Recipes
C
      REAL FUNCTION RANF(IDUM)
      IMPLICIT NONE
C
C Returns a uniform random deviate between 0.0 and 1.0.
C Set IDUM to any negative value to initialise or reinitialise the
C sequence.
C
      INTEGER M,IA,IC,IFF,IDUM,J,IR,IY
      REAL    RM
      PARAMETER (M=714025, IA=1366,IC=150889,RM=1./M)
      DIMENSION IR(97)
      DATA IFF /0/
C
      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
        IFF=1
        IDUM=MOD(IC-IDUM,M)
        DO 11 J=1,97
          IDUM=MOD(IA*IDUM+IC,M)
          IR(J)=IDUM
 11     CONTINUE
        IDUM=MOD(IA*IDUM+IC,M)
        IY=IDUM
      ENDIF
      J=1+(97*IY)/M
      IF (J.GT.97.OR.J.LT.1) STOP
      IY=IR(J)
      RANF=IY*RM
      IDUM=MOD(IA*IDUM+IC,M)
      IR(J)=IDUM
      RETURN
      END


C$Procedure DVNORM ( Derivative of vector norm )

       DOUBLE PRECISION FUNCTION DVNORM( STATE )

C$ Abstract
C
C     Function to calculate the derivative of the norm of a 3-vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     DERIVATIVE
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      STATE ( 6 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     STATE      I   A 6-vector composed of three coordinates and their
C                    derivatives.
C
C$ Detailed_Input
C
C     STATE      A double precision 6-vector, the second three
C                components being the derivatives of the first three
C                with respect to some scalar.
C
C                   STATE =  ( x, dx )
C                                 --
C                                 ds
C
C                A common form for STATE would contain position and
C                velocity.
C
C$ Detailed_Output
C
C     DVNORM     The value of d||x|| corresponding to STATE.
C                             ------
C                               ds
C
C                                   1/2         2    2    2  1/2
C              where ||x|| = < x, x >    =  ( x1 + x2 + x3 )
C
C
C                        v = ( dx1, dx2, dx3 )
C                              ---  ---  ---
C                              ds   ds   ds
C
C                   d||x||   < x, v >
C                   ------ =  ------     =  < xhat, v >
C                     ds            1/2
C                            < x, x >
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C   A common use for this routine is to calculate the time derivative
C   of the radius corresponding to a state vector.
C
C$ Examples
C
C   Any numerical results shown for this example may differ between
C   platforms as the results depend on the SPICE kernels used as input
C   and the machine specific arithmetic implementation.
C
C
C           PROGRAM DVNORM_T
C           IMPLICIT NONE
C
C           DOUBLE PRECISION      X     (3)
C           DOUBLE PRECISION      MAG   (3)
C           DOUBLE PRECISION      DVMAG (3)
C           DOUBLE PRECISION      Y     (6)
C
C           DOUBLE PRECISION      DVNORM
C     C
C     C     Create several 6-vectors (6x1 arrays) with the structure
C     C
C     C        s = |  x  |
C     C            |     |
C     C            |  dx |
C     C            |  -- |
C     C            |  ds |
C     C
C     C      where 'x' is a 3-vector (3x1 array).
C     C
C
C     C
C     C      Create 's' with 'x' of varying magnitudes. Use 'x'
C     C      and '-x' to define the derivative as parallel and
C     C      anti-parallel.
C     C
C           MAG(1) =  -4.D0
C           MAG(2) =   4.D0
C           MAG(3) =  12.D0
C
C           X(1)   = 1.D0
C           X(2)   = DSQRT( 2.D0 )
C           X(3)   = DSQRT( 3.D0 )
C
C     C
C     C     Parallel...
C     C
C           Y(1)   = X(1) * 10.D0**MAG(1)
C           Y(2)   = X(2) * 10.D0**MAG(1)
C           Y(3)   = X(3) * 10.D0**MAG(1)
C           Y(4)   = X(1)
C           Y(5)   = X(2)
C           Y(6)   = X(3)
C
C           WRITE(*,*) 'Parallel x, dx/ds         : ', DVNORM( Y )
C
C     C
C     C     ... anti-parallel...
C     C
C           Y(1)   = X(1) * 10.D0**MAG(2)
C           Y(2)   = X(2) * 10.D0**MAG(2)
C           Y(3)   = X(3) * 10.D0**MAG(2)
C           Y(4)   = -X(1)
C           Y(5)   = -X(2)
C           Y(6)   = -X(3)
C
C           WRITE(*,*) 'Anti-parallel x, dx/ds    : ', DVNORM( Y )
C
C     C
C     C     ... 'x' zero vector
C     C
C           Y(1)   = 0.D0
C           Y(2)   = 0.D0
C           Y(3)   = 0.D0
C           Y(4)   = X(1) * 10.D0**MAG(3)
C           Y(5)   = X(2) * 10.D0**MAG(3)
C           Y(6)   = X(3) * 10.D0**MAG(3)
C
C           WRITE(*,*) 'Zero vector x, large dx/ds: ', DVNORM( Y )
C           END
C
C   The program outputs:
C
C      Parallel x, dx/ds         :   2.44948974
C      Anti-parallel x, dx/ds    :  -2.44948974
C      Zero vector x, large dx/ds:   0.
C
C$ Restrictions
C
C     Error free.
C
C     1) If the first three components of STATE ("x") describes the
C        origin (zero vector) the routine returns zero as the
C        derivative of the vector norm.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     Ed Wright     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 03-MAY-2010 (EDW)
C
C-&

C$ Index_Entries
C
C   derivative of 3-vector norm
C
C-&

C
C     SPICELIB functions.
C
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

C
C     Local Variables.
C
      DOUBLE PRECISION      XHAT ( 3 )

C
C     If "x" describes the zero vector, return zero as the derivative
C     of the vector norm.
C
      IF ( VNORM( STATE(1) ) .EQ. 0.D0 ) THEN

         DVNORM = 0.D0
         RETURN

      END IF

C
C     Construct a unit vector from the x vector data
C     in STATE.
C
      CALL VHAT( STATE(1), XHAT )

C
C     Project the velocity components onto the XHAT vector.
C
C      d ||x||          x
C      -------  = v . -----
C        ds           ||x||
C

      DVNORM = VDOT( STATE(4), XHAT )

      RETURN
      END


recursive function fact(i) result(j)
    integer, intent(in) :: i
    integer :: j
    if (i == 1) then
        j = 1
    else
        j = i * fact(i - 1)
    end if
end function fact


program infinity
    use, intrinsic :: ieee_arithmetic
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    real :: r, x
    real(kind=DP) :: infty
    character(len=20) :: fmt_str = '(A20, E15.7)'

    x = 1.0e20**1.0e20
    print fmt_str, '1.0e20**1.0e20 =', x
    print fmt_str, '-1.0e20**1.0e20 =', -x
    if (ieee_is_finite(x)) then
        print '(A)', '1.0e20**1.0e20 is finite'
    else
        print '(A)', '1.0e20**1.0e20 is infinite'
    end if

    infty = ieee_value(0.0_DP, ieee_positive_inf)
    if (ieee_is_finite(infty)) then
        print '(A)', 'ieee_positive_inf is not infinite'
    else
        print '(A)', 'ieee_positive_inf is infinite'
    end if

    ! The compiler is fairly smart at figuring out when code will lead to
    ! overflow, so we have to deceive it.  Depending on the random value, the
    ! expression may sometimes evaluate to a finite value.
    call random_number(r)
    print fmt_str, '1.0/0.0 =', 1.0/(9.0e-37*r**30)
    print fmt_str, '-1.0/0.0 =', -1.0/(9.0e-37*r**30)
end program infinity


      SUBROUTINE spline(x,y,n,yp1,ypn,y2)
      INTEGER n,NMAX
      REAL*8 yp1,ypn,x(n),y(n),y2(n)
      PARAMETER (NMAX=500)
      INTEGER i,k
      REAL*8 p,qn,sig,un,u(NMAX)
      if (yp1.gt..99e30) then
        y2(1)=0.
        u(1)=0.
      else
        y2(1)=-0.5
        u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif
      do 11 i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2.
        y2(i)=(sig-1.)/p
        u(i)=(6.*((y(i+1)-y(i))/(x(i+
     *1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
     *u(i-1))/p
11    continue
      if (ypn.gt..99e30) then
        qn=0.
        un=0.
      else
        qn=0.5
        un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
      do 12 k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
12    continue
      return
      END

      SUBROUTINE splint(xa,ya,y2a,n,x,y)
      INTEGER n
      REAL*8 x,y,xa(n),y2a(n),ya(n)
      INTEGER k,khi,klo
      REAL*8 a,b,h
      klo=1
      khi=n
1     if (khi-klo.gt.1) then
        k=(khi+klo)/2
        if(xa(k).gt.x)then
          khi=k
        else
          klo=k
        endif
      goto 1
      endif
      h=xa(khi)-xa(klo)
c      if (h.eq.0.) pause 'bad xa input in splint'
      if (h.eq.0.) then
         write (*,*) 'bad xa input in splint'
      endif
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**
     *2)/6.
      return
      END


	REAL*4 FUNCTION PPOWER
     .(ALPHA,N,P0,P1,R,varPHI,ALT)
	IMPLICIT NONE

	REAL*4 ALPHA,N,P0,P1,R,varPHI
	INTEGER*4 ALT
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Power calculations for paired prospective studies with
C	dichotomous outcomes.
C
C  Input (provided by user):
C	ALPHA	Type I error probability for a two sided test
C	N		Sample size
C	P0		Event rate among controls
C	P1		Event rate among experimental subjects
C	R=P1/P0	Relative risk of failure for experimental suiibjects
C			relative to controls
C	PHI		correlation coefficient for failure between paired subjects
C	ALT	=1 	if input requires P0 and P1
C		=2 	if input requires P0 and R
C
C  Output:
C	POWER	Probability of correctly rejecting the null hypothesis
C			that R=1 given N matched pairs of subjects and a type
C			I error probability of ALPHA when the true relative
C			riks equals R.
C
C  Notes:
C   .	This routine was written by Dale Plummer.
C	Designed by William Dupont.
C   .	Reference:
C	    Schlesselman, JJ:  "Case-Control Studies:  Design, Conduct,
C	    Analysis", New York:  Oxford U. Press 1982
C	See also:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
	REAL ZCRVALUE
	DOUBLE PRECISION PHI
C
C  Locals
C
	REAL K,BETA,ZALPHA,Q1,Q0,P10,P01,PA,QA,XP1
C
C-Code------------------------------------------------------------------
C
C	Copy or calculate P1 to local variable.
C
	IF (ALT.EQ.2) THEN
		XP1=R*P0
	ELSE
		XP1=P1
	END IF
C
C    Solve for power.
C
	ZALPHA=ZCRVALUE(ALPHA/2.)
	Q1=1.-XP1
	Q0=1.-P0
	P10=XP1*Q0 - varPHI*SQRT(XP1*Q1*P0*Q0)
	P01=Q1*P0 - varPHI*SQRT(XP1*Q1*P0*Q0)
	PA=P10/(P01+P10)
	QA=1.-PA
	K=N*(P01+P10)
	BETA=PHI((.5-PA+ZALPHA/(2.*SQRT(K)))/SQRT(PA*QA/K)) -
     . PHI((.5-PA-ZALPHA/(2.*SQRT(K)))/SQRT(PA*QA/K))
	PPOWER=1.-BETA
C
C  Done.
C
	RETURN
	END


!***********************************************************************
!* FFT Routines:
!*   FFT_S - In-place FFT
!*   FFT_SN - Out-of-place FFT
!*   FFT_SD - Out-of-place FFT that returns DFT only
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      SUBROUTINE FFT_S( Y, Y_MAG, Y_PHS, NLP_U, NLP, Y_DFT, NLP_2,
     & DEL, PAD_FAC, M_MIN, IOS )

!***********************************************************************
!* Computes the DFT Magnitude and Phase of a Series
!* . Overwrites NLP and DEL
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NLP_U ! Data array upper index limit

      INTEGER NLP ! Index of last data point

      INTEGER NLP_2 ! Power-of-2 DFT array last point index (>= NLP)

      REAL Y(0:NLP) ! Data array (send Y(0))

      REAL Y_MAG(0:NLP_U) ! DFT magnitude output array (send Y_MAG(0))

      REAL Y_PHS(0:NLP_U) ! DFT phase output array (send Y_PHS(0))

      COMPLEX Y_DFT(0:NLP_2-1) ! DFT output array (send Y_DFT(0))

      REAL DEL ! X-axis step of data (>0)

      REAL PAD_FAC ! Desired minimum length padding factor

      INTEGER M_MIN ! Min power of 2 for DFT length (2**M_MIN <= NLP_2)

      INTEGER IOS ! Status flag returned

      ! Perform the in-place DFT
      CALL FFT_SN( Y, Y_MAG, Y_PHS, NLP_U, NLP, Y_DFT, NLP_2,
     & DEL, PAD_FAC, M_MIN, NLP, DEL, IOS )

      RETURN
      END

      SUBROUTINE FFT_SN( Y, Y_MAG, Y_PHS, NLP_U, NLP, Y_DFT, NLP_2,
     & DEL, PAD_FAC, M_MIN, NLP_OUT, DEL_OUT, IOS )

!***********************************************************************
!* Computes the DFT Magnitude and Phase of a Series
!*
!* Language: Fortran
!*
!* Author: Jeff Marcus
!*         Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NLP_U ! Data array upper index limit

      INTEGER NLP ! Index of last data point

      INTEGER NLP_2 ! Power-of-2 DFT array last point index (>= NLP)

      REAL Y(0:NLP) ! Data array (send Y(0))

      REAL Y_MAG(0:NLP_U) ! DFT magnitude output array (send Y_MAG(0))

      REAL Y_PHS(0:NLP_U) ! DFT phase output array (send Y_PHS(0))

      COMPLEX Y_DFT(0:NLP_2-1) ! DFT output array (send Y_DFT(0))

      REAL DEL ! X-axis step of data (>0)

      REAL PAD_FAC ! Desired minimum length padding factor

      INTEGER M_MIN ! Min power of 2 for DFT length (2**M_MIN <= NLP_2)

      INTEGER NLP_OUT ! Index of last output data point

      REAL DEL_OUT ! X-axis output frequency step of data (>0)

      INTEGER IOS ! Status flag returned

      ! Variables ______________________________________________________

      INTEGER I

      REAL PI, Y_R, Y_I

      COMPLEX Y_D

      ! Compute the DFT
      CALL FFT_SD( Y, NLP, Y_DFT, NLP_2,
     & DEL, PAD_FAC, M_MIN, NLP_OUT, DEL_OUT, IOS )
      IF ( IOS .NE. 0 ) RETURN

      ! Compute magnitude and phase data
      PI = 4.0 * ATAN( 1.0 )
      NLP_OUT = MIN( NLP_OUT, NLP_U )
      DO I = 0, NLP_OUT
        Y_D = Y_DFT(I)
        Y_R = REAL( Y_D )
        Y_I = AIMAG( Y_D )
        Y_MAG(I) = CABS( Y_D )
        IF ( ABS( Y_I ) .LT. 1.E10 * ABS( Y_R ) ) THEN ! Phase in deg
          Y_PHS(I) = ATAN( Y_I / Y_R ) * 180. / PI
        ELSE ! Set phase = 90 degrees
          Y_PHS(I) = 90.
        END IF
      END DO

      RETURN
      END

      SUBROUTINE FFT_SD( Y, NLP, Y_DFT, NLP_2,
     & DEL, PAD_FAC, M_MIN, NLP_OUT, DEL_OUT, IOS )

!***********************************************************************
!* Computes the Complex DFT of a Series
!*
!* Language: Fortran
!*
!* Author: Jeff Marcus
!*         Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NLP ! Index of last data point

      INTEGER NLP_2 ! Power-of-2 DFT array last point index (>= NLP)

      REAL Y(0:NLP) ! Data array (send Y(0))

      COMPLEX Y_DFT(0:NLP_2-1) ! DFT output array (send Y_DFT(0))

      REAL DEL ! X-axis step of data (>0)

      REAL PAD_FAC ! Desired minimum length padding factor

      INTEGER M_MIN ! Min power of 2 for DFT length (2**M_MIN <= NLP_2)

      INTEGER NLP_OUT ! Index of last output data point

      REAL DEL_OUT ! X-axis output frequency step of data (>0)

      INTEGER IOS ! Status flag returned

      ! Variables ______________________________________________________

      INTEGER I, M, M_MAX, NPT, NPT2

      ! Check input fields
      IF ( NLP .LE. 0 ) THEN ! No data error
        IOS = 1
        RETURN
      END IF
      IF ( NLP .GE. NLP_2 ) THEN ! DFT array too small
        IOS = 2
        RETURN
      END IF
      IOS = 0

      ! Set up FFT dimensions
      M_MAX = INT( ( LOG( REAL( NLP_2 ) ) / LOG( 2. ) ) *
     & ( 1. + 2.E-7 ) )
      NPT = NLP + 1
      M = INT(
     & ( ( LOG( NPT * MAX( PAD_FAC, 1. ) ) / LOG( 2. ) ) + 1. ) *
     & ( 1. + 2.E-7 ) )
      M = MIN( MAX( M, M_MIN ), M_MAX )
      NPT2 = 2**M

      ! Initialize complex array and pad to a power of 2 length
      DO I = 0, NLP ! Initialize
        Y_DFT(I) = CMPLX( Y(I), 0. )
      END DO
      DO I = NLP+1, NPT2-1 ! Pad zeros
        Y_DFT(I) = CMPLX( 0., 0. )
      END DO

      ! Compute using FFT
      CALL COMPUTE_FFT( Y_DFT, M )

      ! Prepare output fields
      NLP_OUT = NPT2 / 2 ! Limit to Nyquist frequency
      DEL_OUT = 1.0 / ( DEL * NPT2 ) ! Frequency step

      RETURN
      END

      SUBROUTINE COMPUTE_FFT( A, M )

!***********************************************************************
!* Computes Radix 2, In-Place FFT
!***********************************************************************

      ! Arguments ______________________________________________________

      COMPLEX A(*) ! DFT output array

      INTEGER M ! Power of 2 DFT length

      ! Variables ______________________________________________________

      INTEGER N, NV2, NM1, I, IP, J, K, L, LE, LE1

      REAL PI

      COMPLEX U, W, T

      ! Initializations
      PI = 4. * ATAN( 1. )
      N = 2**M
      NV2 = N / 2
      NM1 = N - 1
      J = 1

      DO I = 1, NM1
        IF ( I .LT. J ) THEN ! Swap A_i and A_j
          T = A(J)
          A(J) = A(I)
          A(I) = T
        END IF
        K = NV2
        DO WHILE ( K .LT. J )
          J = J - K
          K = K / 2
        END DO
        J = J + K
      END DO

      DO L = 1, M
        LE = 2**L
        LE1 = LE / 2
        U = ( 1., 0. )
        W = CMPLX( COS(PI/LE1), SIN(PI/LE1) )
        DO J = 1, LE1
          DO I = J, N, LE
            IP = I + LE1
            T = A(IP) * U
            A(IP) = A(I) - T
            A(I) = A(I) + T
          END DO
          U = U * W
        END DO
      END DO

      RETURN
      END


module operator_overloading_01_overload_asterisk_m
    implicit none
    public operator (*)

    interface operator (*)
        module procedure logical_and
    end interface

    interface operator (+)
        module procedure bin_add
    end interface
contains
    pure logical function logical_and(log1, log2)
        logical, intent (in) :: log1, log2

        logical_and = (log1 .and. log2)
    end function

    pure integer function bin_add(log1, log2)
        logical, intent (in) :: log1, log2

        if( log1 .and. log2 ) then
            bin_add = 2
        elseif( .not. log1 .and. .not. log2 ) then
            bin_add = 0
        else
            bin_add = 1
        endif
    end function
end module

program operator_overloading_01
  use operator_overloading_01_overload_asterisk_m
  implicit none
  logical, parameter :: T = .true., F = .false.

  print *, "T*T:", T*T  ! Yields: T
  print *, "T*F:", T*F  ! Yields: F
  print *, "F*T:", F*T  ! Yields: F
  print *, "F*F:", F*F  ! Yields: F
  print *, "T+T:", T+T  ! Yields: 2
  print *, "T+F:", T+F  ! Yields: 1
  print *, "F+T:", F+T  ! Yields: 1
  print *, "F+F:", F+F  ! Yields: 0
end program


!!!! hello_stdcl.f90

	program main

	use iso_c_binding
	use stdcl

	implicit none

	integer(C_INT) :: n = 64
	type(C_PTR) :: cp
	integer(C_INT) :: devnum = 0
	type(C_PTR) :: clh
	type(C_PTR) :: krn
	type(C_PTR) :: p_aa, p_b, p_c
	real(C_FLOAT), pointer :: aa(:,:), b(:), c(:)
	integer :: i,j
	type(clndrange_struct), target :: ndr
	integer(C_INT) :: rc
	type(C_PTR) :: ev

	!!!! use default contexts, if no GPU use CPU
	if (C_ASSOCIATED(stdgpu)) then
		cp = stdgpu
	else
		cp = stdcpu
	endif

	!!!! build CL program, get kernel
   krn = clsym(cp,C_NULL_PTR,"matvecmult_kern"//C_NULL_CHAR,0);

   !!!! allocate OpenCL device-sharable memory, associate with fortran pointers
   p_aa = clmalloc(cp,int8(n*n*4),0);
	call C_F_POINTER(p_aa,aa,[n,n])

   p_b = clmalloc(cp,int8(n*4),0);
	call C_F_POINTER(p_b,b,[n])

   p_c = clmalloc(cp,int8(n*4),0);
	call C_F_POINTER(p_c,c,[n])

   !!!! initialize vectors a[] and b[], zero c[]
	do i = 1,n
		do j = 1,n
			aa(i,j) = 1.1 * (i-1) * (j-1)
		end do
	end do

	do i = 1,n
		b(i) = 2.2 * (i-1)
	end do

	do i = 1,n
		c(i) = 0.0
	end do

   !!!! define the computational domain and workgroup size
   ndr = clndrange_init1d( 0, n, 64)

   !!!! non-blocking sync vectors a and b to device memory (copy to GPU)
   ev = clmsync(cp,devnum,p_aa,CL_MEM_DEVICE+CL_EVENT_NOWAIT)
   ev = clmsync(cp,devnum,p_b,CL_MEM_DEVICE+CL_EVENT_NOWAIT)

   !!!! set the kernel arguments
   rc = clarg_set(cp,krn,0,n);
   rc = clarg_set_global(cp,krn,1,p_aa);
   rc = clarg_set_global(cp,krn,2,p_b);
   rc = clarg_set_global(cp,krn,3,p_c);

   !!!! non-blocking fork of the OpenCL kernel to execute on the GPU
	ev = clfork(cp,devnum,krn,C_LOC(ndr),CL_EVENT_NOWAIT)

   !!!! non-blocking sync vector c to host memory (copy back to host)
	ev = clmsync(cp,devnum,p_c,CL_MEM_HOST+CL_EVENT_NOWAIT)

   !!!! force execution of operations in command queue (non-blocking call)
	rc = clflush(cp,devnum,0)

   !!!! block on completion of operations in command queue
	ev = clwait(cp,devnum,CL_ALL_EVENT)

	do i = 1,n
		write(*,*) i,b(i),c(i)
	end do

   rc = clfree(p_aa)
   rc = clfree(p_b)
   rc = clfree(p_c)

	end


program problem_5

!! What is the highest seat ID on a boarding pass?

use aoc_utilities
use iso_fortran_env

implicit none

integer :: iunit, istat, n_lines, i, istart, iend, j, irow, icol, id
character(len=10) :: row
integer,dimension(:),allocatable :: ids

open(newunit=iunit, file='input.txt', iostat=istat)
if (istat /= 0) error stop ' error reading file'
n_lines = number_of_lines_in_file(iunit)
allocate(ids(n_lines))

do i = 1, n_lines
    read(iunit, '(A10)') row

    istart = 0
    iend   = 127
    irow = find(row(1:7), istart, iend, 'FB')

    istart = 0
    iend   = 7
    icol = find(row(8:10), istart, iend, 'LR')

    id = irow * 8 + icol
    ids(i) = id

    !write(*,*) irow, icol, id

end do

write(*,*) 'max id: ', maxval(ids)

! part b:
write(*,*) ''
call sort_ascending(ids)
do i = 2, n_lines
    if (ids(i) - ids(i-1) == 2) then
        write(*,*) 'seat id: ', ids(i) - 1
        stop
    end if
end do

contains
    function find(row, istart, iend, lower_upper) result(irow)

    implicit none

    character(len=*),intent(in) :: row
    integer,intent(in) :: istart, iend
    character(len=2),intent(in) :: lower_upper
    integer :: irow

    integer :: istart_, iend_
    istart_ = istart
    iend_   = iend
    do j = 1, len(row)
        if (row(j:j) == lower_upper(1:1)) then ! lower
            iend_ = istart_ + (iend_-istart_-1)/2
        elseif (row(j:j) == lower_upper(2:2)) then ! upper
            istart_ = istart_ + (iend_-istart_-1)/2 + 1
        else
            error stop 'invalid char: '//row(j:j)
        end if
    end do
    irow = istart_
    end function find

end program problem_5


  SUBROUTINE Jacobi(a,n,np,d,v,nrot)
  IMPLICIT NONE
  INTEGER n,np,nrot,NMAX
  REAL a(np,np),d(np),v(np,np)
  PARAMETER (NMAX=500)
! Computes all eigenvalues and eigenvectors of a real symmetric matrix a,
! which is of size n by n, stored in a physical np by np array. On output,
! elements of a above the diagonal are destroyed. d returns the eigenvalues
! of a in its  rst n elements. v is a matrix with the same logical and
! physical dimensions as a, whose columns contain, on output, the normalized
! eigenvectors of a. nrot returns the number of Jacobi rotations that were
! required.
  INTEGER i,ip,iq,j
  REAL c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)

  do ip=1,n     ! Initialize to the identity matrix.
    do iq=1,n
      v(ip,iq)=0.
    end do
    v(ip,ip)=1.
  end do

  do ip=1,n
    b(ip)=a(ip,ip) ! Initialize b and d to the diagonal of a.
    d(ip)=b(ip)
    z(ip)=0.       ! This vector will accumulate terms of the form
                   ! tapq as in equation (11.1.14).
  end do

  nrot=0
  do i=1,50

    sm=0.
    do ip=1,n-1 ! Sum o -diagonal elements.
      do iq=ip+1,n
        sm=sm+abs(a(ip,iq))
      end do
    end do
    if(sm.eq.0.) return  ! The normal return, which relies on quadratic
                         !  convergence to machine under ow.
    if(i.lt.4) then
      tresh=0.2*sm/n**2  ! ...on the  rst three sweeps.
    else
      tresh=0.           ! ...thereafter.
    endif

    do ip=1,n-1
      do iq=ip+1,n
        g=100.*abs(a(ip,iq))     ! After four sweeps, skip the rotation if the
                                 ! offdiagonal element is small.
        if((i.gt.4).and.(abs(d(ip))+g.eq.abs(d(ip))) &
           .and.(abs(d(iq))+g.eq.abs(d(iq)))) then
          a(ip,iq)=0.
        else if(abs(a(ip,iq)).gt.tresh) then
          h=d(iq)-d(ip)
          if(abs(h)+g.eq.abs(h)) then
            t=a(ip,iq)/h         ! t = 1/(2 theta)
          else
            theta=0.5*h/a(ip,iq) ! Equation (11.1.10).
            t=1./(abs(theta)+sqrt(1.+theta**2))
            if(theta.lt.0.) t=-t
          endif
          c=1./sqrt(1+t**2)
          s=t*c
          tau=s/(1.+c)
          h=t*a(ip,iq)
          z(ip)=z(ip)-h
          z(iq)=z(iq)+h
          d(ip)=d(ip)-h
          d(iq)=d(iq)+h
          a(ip,iq)=0.
          do j=1,ip-1     ! Case of rotations 1   j <p.
            g=a(j,ip)
            h=a(j,iq)
            a(j,ip)=g-s*(h+g*tau)
            a(j,iq)=h+s*(g-h*tau)
          end do
          do j=ip+1,iq-1  ! Case of rotations p <j<q.
            g=a(ip,j)
            h=a(j,iq)
            a(ip,j)=g-s*(h+g*tau)
            a(j,iq)=h+s*(g-h*tau)
          end do
          do j=iq+1,n     ! Case of rotations q <j   n.
            g=a(ip,j)
            h=a(iq,j)
            a(ip,j)=g-s*(h+g*tau)
            a(iq,j)=h+s*(g-h*tau)
          end do
          do j=1,n
            g=v(j,ip)
            h=v(j,iq)
            v(j,ip)=g-s*(h+g*tau)
            v(j,iq)=h+s*(g-h*tau)
          end do
          nrot=nrot+1
        endif
      end do
    end do

    do ip=1,n
      b(ip)=b(ip)+z(ip)
      d(ip)=b(ip)          ! Update d with the sum of tapq, z(ip)=0.
                           ! and reinitialize z.
    end do
  end do

  write(*,*) 'too many iterations in jacobi'

  return

  END SUBROUTINE Jacobi


! =================================================
!   Jocobi iteration (line) method to solve linear
!       equation system 'Ax = b'.
! =================================================

subroutine iter_ja_l(A, b, x, iter_cr, iter_max)

    use coordinates, only: Nx, Ny
    use log_config,  only: log_conv_show
    implicit none

    integer*4, parameter     :: n = Nx*Ny
    real*8,    intent(in)    :: A(n,n)
    real*8,    intent(in)    :: b(n)
    real*8,    intent(inout) :: x(n)
    real*8,    intent(in)    :: iter_cr
    integer*4, intent(in)    :: iter_max

    real*8    :: x0(n)
    real*8    :: iter_err
    integer*4 :: iter_cnt
    integer*4 :: I, J, P

    real*8    :: aa(Ny), bb(Ny), cc(Ny), dd(Ny)
    real*8    :: xx(Ny)

    call random_seed()
    call random_number(x0)
    iter_cnt = 1
    do while (iter_cnt < iter_max)

        do I = 1, Nx

            aa(1) = 0.
            do J = 2, Ny
                P = (I - 1)*Ny + J
                aa(J) = A(P,P-1)
            end do

            do J = 1, Ny - 1
                P = (I - 1)*Ny + J
                cc(J) = A(P,P+1)
            end do
            cc(Ny) = 0.

            do J = 1, Ny
                P = (I - 1)*Ny + J
                bb(J) = A(P,P)
                if (I == 1)      then
                    dd(J) = A(P,P+Nx)*x0(P+Nx) + b(P)
                elseif (I == Nx) then
                    dd(J) = A(P,P-Nx)*x0(P-Nx) + b(P)
                else
                    dd(J) = A(P,P-Nx)*x0(P-Nx) &
                        & + A(P,P+Nx)*x0(P+Nx) + b(P)
                end if
            end do

            call TDMA(Ny, aa, bb, cc, dd, xx)
            do J = 1, Ny
                P = (I - 1)*Ny + J
                x(P) = xx(J)
            end do

        end do

        ! do I = 1, n
        !     write(*,*) x(I)
        ! end do
        ! stop

        ! Update: x -> x0
        iter_err = maxval(abs(x - x0)/x0)
        if (log_conv_show) print *, "", iter_cnt,  iter_err
        if (iter_err < iter_cr) exit

        x0 = x
        iter_cnt = iter_cnt + 1

    end do

end subroutine


! Saturation vapor pressure and mixing ratio.
! Based on Flatau et.al, (JAM, 1992:1507)
!

real function esatw(t)
implicit none
real t	! temperature (K)
real a0,a1,a2,a3,a4,a5,a6,a7,a8
data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
!	6.105851, 0.4440316, 0.1430341e-1, &
!        0.2641412e-3, 0.2995057e-5, 0.2031998e-7, &
!        0.6936113e-10, 0.2564861e-13,-0.3704404e-15/
     	6.11239921, 0.443987641, 0.142986287e-1, &
       0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
       0.640689451e-10, -0.952447341e-13,-0.976195544e-15/
real dt
dt = max(-80.,t-273.16)
esatw = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
end

real function qsatw(t,p)
implicit none
real t	! temperature (K)
real p	! pressure    (mb)
real esat,esatw
esat = esatw(t)
qsatw = 0.622 * esat/max(esat,p-esat)
end

real function dtesatw(t)
implicit none
real t	! temperature (K)
real a0,a1,a2,a3,a4,a5,a6,a7,a8
data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
          0.443956472, 0.285976452e-1, 0.794747212e-3, &
          0.121167162e-4, 0.103167413e-6, 0.385208005e-9, &
         -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/
real dt
dt = max(-80.,t-273.16)
dtesatw = a0 + dt* (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
end

real function dtqsatw(t,p)
implicit none
real t	! temperature (K)
real p	! pressure    (mb)
real dtesatw
dtqsatw=0.622*dtesatw(t)/p
end

real function esati(t)
implicit none
real t	! temperature (K)
real a0,a1,a2,a3,a4,a5,a6,a7,a8
data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
	6.11147274, 0.503160820, 0.188439774e-1, &
        0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
        0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
real dt
real esatw
if(t.gt.273.15) then
  esati = esatw(t)
else if(t.gt.185.) then
  dt = t-273.16
  esati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
else   ! use some additional interpolation below 184K
  dt = max(-100.,t-273.16)
  esati = 0.00763685 + dt*(0.000151069+dt*7.48215e-07)
end if
end

real function qsati(t,p)
implicit none
real t	! temperature (K)
real p	! pressure    (mb)
real esat,esati
esat=esati(t)
qsati=0.622 * esat/max(esat,p-esat)
end

real function dtesati(t)
implicit none
real t	! temperature (K)
real a0,a1,a2,a3,a4,a5,a6,a7,a8
data a0,a1,a2,a3,a4,a5,a6,a7,a8 / &
	0.503223089, 0.377174432e-1,0.126710138e-2, &
	0.249065913e-4, 0.312668753e-6, 0.255653718e-8, &
	0.132073448e-10, 0.390204672e-13, 0.497275778e-16/
real dt
real dtesatw
if(t.gt.273.15) then
  dtesati = dtesatw(t)
else if(t.gt.185.) then
  dt = t-273.16
  dtesati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
else  ! use additional interpolation below 185K
  dt = max(-100.,t-273.16)
  dtesati = 0.0013186 + dt*(2.60269e-05+dt*1.28676e-07)
end if
end

real function dtqsati(t,p)
implicit none
real t	! temperature (K)
real p	! pressure    (mb)
real dtesati
dtqsati=0.622*dtesati(t)/p
end


      program t
      implicit none
      real,dimension(8)::a=(/1,2,3,4,5,6,7,8/)
      print '(f3.0)',cumm_sum(a)
      contains
      recursive function cumm_sum(array) result (c_sum)
      real array(:),c_sum(size(array))
      integer n
      n=size(array)
      if (n.le.1) then
         c_sum=array
      else
       n=n/2
       c_sum(:n)=cumm_sum(array(:n))
       c_sum(n+1:)=c_sum(n)+cumm_sum(array(n+1:))
      endif
      end function cumm_sum
      end program t


    program demo_product
    implicit none
    character(len=*),parameter :: all='(*(g0,1x))' ! a handy format
    character(len=1),parameter :: nl=new_line('a')

    NO_DIM: block
    !    If DIM is not specified, the result is the product of all the
    !    selected array elements.
    integer :: i,n, p1, p2
    integer,allocatable :: array(:)
       ! all elements are selected by default
       do n=1,10
          print all, 'factorial of ',n,' is ', product([(real(i),i=1,n)])
       enddo

       ! using a mask
       array=[10,12,13,15,20,25,30]
       p1=product(array, mask=mod(array, 2)==1) ! only odd elements
       p2=product(array, mask=mod(array, 2)/=1) ! only even elements
       print all, nl,'product of all elements',product(array) ! all elements
       print all, ' odd * even =',nl,p1,'*',p2,'=',p1*p2

       ! NOTE: If ARRAY is a zero-sized array, the result is equal to one
       print all
       print all, 'zero-sized array=>',product([integer :: ])
       ! NOTE: If nothing in the mask is true, this also results in a null
       !       array
       print all, 'all elements have a false mask=>',product(array,mask=.false.)

    endblock NO_DIM

    WITH_DIM: block
    integer :: rect(2,3)
    integer :: box(2,3,4)

    !  lets fill a few arrays
       rect = reshape([ &
         1, 2, 3,       &
         4, 5, 6        &
       ],shape(rect),order=[2,1])
       call print_matrix_int('rect',rect)

    !  Find the product of each column in RECT.
       print all, 'product of columns=',product(rect, dim = 1)

    ! Find the product of each row in RECT.
       print all, 'product of rows=',product(rect, dim = 2)

    ! now lets try a box
       box(:,:,1)=rect
       box(:,:,2)=rect*(+10)
       box(:,:,3)=rect*(-10)
       box(:,:,4)=rect*2
       ! lets look at the values
       call print_matrix_int('box 1',box(:,:,1))
       call print_matrix_int('box 2',box(:,:,2))
       call print_matrix_int('box 3',box(:,:,3))
       call print_matrix_int('box 4',box(:,:,4))

       ! remember without dim= even a box produces a scalar
       print all, 'no dim gives a scalar',product(real(box))

       ! only one plane has negative values, so note all the "1" values
       ! for vectors with no elements
       call print_matrix_int('negative values',product(box,mask=box < 0,dim=1))

    !   If DIM is specified and ARRAY has rank greater than one, the
    !   result is a new array in which dimension DIM has been eliminated.

       ! pick a dimension to multiply though
       call print_matrix_int('dim=1',product(box,dim=1))

       call print_matrix_int('dim=2',product(box,dim=2))

       call print_matrix_int('dim=3',product(box,dim=3))

    endblock WITH_DIM

    contains

    subroutine print_matrix_int(title,arr)
    implicit none

    !@(#) print small 2d integer arrays in row-column format

    character(len=*),intent(in)  :: title
    integer,intent(in)           :: arr(:,:)
    integer                      :: i
    character(len=:),allocatable :: biggest

       print all
       print all, trim(title),':(',shape(arr),')'  ! print title
       biggest='           '  ! make buffer to write integer into
       ! find how many characters to use for integers
       write(biggest,'(i0)')ceiling(log10(real(maxval(abs(arr)))))+2
       ! use this format to write a row
       biggest='(" > [",*(i'//trim(biggest)//':,","))'
       ! print one row of array at a time
       do i=1,size(arr,dim=1)
          write(*,fmt=biggest,advance='no')arr(i,:)
          write(*,'(" ]")')
       enddo

    end subroutine print_matrix_int

    end program demo_product


! a thread safe random number generator
module numz
!*************************************
! description:
    ! basic types module, included in all other routines
!*************************************
    integer, parameter:: b8 = selected_real_kind(p=12) ! basic real types
    integer, parameter:: b4 = selected_real_kind(p=4)
end module
module ran_mod
 contains
    function ran1(idum)
! returns a uniform random number between 0 and 1
! see numerical recipes
! press,flannery,teukolsky & vetterling
! cambridge university press 1986 pp 191-2-3
    use numz
    implicit none
    real(b8) ran1
    integer, intent(inout), optional :: idum
    integer m1,m2,m3,ia1,ia2,ia3,ic1,ic2,ic3
    integer iff
    integer ix1,ix2,ix3,j
    real(b8) r(97),rm1,rm2
    parameter (m1=259200,ia1=7141,ic1=54773)
    parameter (m2=134456,ia2=8121,ic2=28411)
    parameter (m3=243000,ia3=4561,ic3=51349)
    data iff /0/
!$OMP THREADPRIVATE(iff,ix1,ix2,ix3,j,r,rm1,rm2)
    save iff,ix1,ix2,ix3,j,r,rm1,rm2
    if(present(idum))then
        if (idum<0.or.iff.eq.0)then
            rm1=1.0_b8/m1
            rm2=1.0_b8/m2
            iff=1
            ix1=mod(ic1-idum,m1)
            ix1=mod(ia1*ix1+ic1,m1)
            ix2=mod(ix1,m2)
            ix1=mod(ia1*ix1+ic1,m1)
            ix3=mod(ix1,m3)
            do  j=1,97
              ix1=mod(ia1*ix1+ic1,m1)
              ix2=mod(ia2*ix2+ic2,m2)
              r(j)=(float(ix1)+float(ix2)*rm2)*rm1
            enddo
            idum=1
        endif
    endif
    ix1=mod(ia1*ix1+ic1,m1)
    ix2=mod(ia2*ix2+ic2,m2)
    ix3=mod(ia3*ix3+ic3,m3)
    j=1+(97*ix3)/m3
    if(j>97.or.j<1)then
    write(*,*)' error in ran1 j=',j
    stop
    endif
    ran1=r(j)
    r(j)=(float(ix1)+float(ix2)*rm2)*rm1
    return
    end function ran1

    function gasdev()
        use numz
!        interface ran1
!            function ran1(idum)
!                use numz
!                integer, intent(inout), optional :: idum
!                real(b8) ran1
!            end function ran1
!        end interface
        implicit none
        real(b8) gasdev
        integer iset
        real(b8) fac,gset,rsq,v1,v2
        save iset,gset
        data iset/0/
        if (iset.eq.0) then
     1        v1=2.*ran1()-1.
            v2=2.*ran1()-1.
            rsq=v1**2+v2**2
            if(rsq.ge.1..or.rsq.eq.0.)goto 1
            fac=sqrt(-2.*log(rsq)/rsq)
            gset=v1*fac
            gasdev=v2*fac
            iset=1
        else
            gasdev=gset
            iset=0
        endif
        return
    end function gasdev

    function norml(mean,sigma)
        use numz
        implicit none
        real(b8) norml
        real(b8) mean,sigma
        norml = gasdev() * sigma + mean
    end function norml

    function spread(min,max)
        use numz
        implicit none
        real(b8) spread
        real(b8) min,max
        spread=(max - min) * ran1() + min
    end function spread

end module ran_mod

program doit
   use numz
   use ran_mod
   real(b8) x
   integer omp_get_thread_num,myt
   read(*,*)iseed
!$OMP parallel
!$OMP critical
   myt=omp_get_thread_num()
   jseed=-abs(iseed)
   jseed=jseed-myt
   x=ran1(jseed)
        write(*,'("inside critical myt=",i4,f12.8)')myt,x
!$OMP end critical
!$OMP end parallel

!$OMP parallel
!$OMP critical
  myt=omp_get_thread_num()
  write(*,*)" for thread ",myt
  do i=1,20000
    x=ran1()
 !     write(*,*)i,x
   enddo
   write(*,'("final for ",i4,i8,f12.8)')myt,i-1,x
!$OMP end critical
!$OMP end parallel
end program