module loglikelihood_module
    use utils_module, only: dp

        integer :: nDims
        integer :: n_knots
        integer :: nStats

        real(dp), allocatable, dimension(:)   :: theta_saved
        real(dp), allocatable, dimension(:,:) :: spline_data

        real(dp), allocatable, dimension(:)   :: x0
        real(dp), allocatable, dimension(:)   :: y0
        real(dp), allocatable, dimension(:)   :: sigmax
        real(dp), allocatable, dimension(:)   :: sigmay

        real(dp) :: x_min_int, x_max_int
        real(dp) :: x_min, x_max

    contains

    function loglikelihood(theta,phi)
        use utils_module, only: logzero, logincexp,logTwoPi
        implicit none
        real(dp), intent(in),  dimension(:) :: theta         !> Input parameters
        real(dp), intent(out), dimension(:) :: phi           !> Output derived parameters
        real(dp)                            :: loglikelihood ! loglikelihood value to output

        real(dp) :: loglikelihood_temp
        integer :: i_stats
        integer :: i_int
        real(dp) :: x,y

        ! Read in the spline array if necessary
        if(any(theta_saved /= theta ) ) then

            ! Calculate the spline array
            spline_data(:,1) = theta(1:n_knots)
            spline_data(:,2) = theta(n_knots+1:nDims)

            ! Save the current theta
            theta_saved = theta

        end if

        ! Calculate the likelihood
        loglikelihood_temp = logzero
        loglikelihood      = 0d0

        ! Iterate over all points in the file
        do i_stats = 1,nStats

            ! If there's no error in the x variable then this is a lot simpler
            if(sigmax(i_stats) <=0d0) then

                ! calculate the likelihood
                x = x0(i_stats)
                y = linear_interpolate(x,spline_data,0)
                loglikelihood_temp = - log( sigmay(i_stats) ) - logTwoPi/2d0 - ((y-y0(i_stats))/sigmay(i_stats))**2/2d0

            else
                ! Integrate the spline
                loglikelihood_temp = log_exp_int(x0(i_stats),y0(i_stats),sigmax(i_stats),sigmay(i_stats),x_min,x_max)

                ! Normalise via the normalising constants, and the width of the
                ! integral
                loglikelihood_temp = loglikelihood_temp   &
                    - log( sigmay(i_stats) ) - log( sigmax(i_stats) ) - logTwoPi &
                    - log(x_max-x_min)

            end if

            ! Add the likelihood from this point to the total likelihood (note
            ! that this is in fact multiplication)
            loglikelihood = loglikelihood + loglikelihood_temp

        end do

    end function loglikelihood

    ! This function computes the logarithm of:
    !
    ! /xmax
    ! |     exp( - (x-x0)^2/2sx^2 - (y0-f(x))^2/2sy^2 ) dx
    ! /xmin
    !
    ! where f(x) is a linear spline defined by spline_arr.
    !
    ! This is effectively a piecewise linear integral:
    !
    ! /xmax
    ! |     exp( - (x-x0)^2/2sx^2 - (y0-(m x + c))^2/2sy^2 ) dx
    ! /xmin
    !
    ! where m and c change depending on which interval one is in.
    !
    ! Completing the square on the integrand yields:
    !     1   /           \2     1        1
    ! - ----- | x - e s^2 |   - --- f  + --- e
    !   2 s^2 \           /      2        2
    !
    ! where
    !
    ! s = (sx^-2 + m^2 sy^-2)^-(1/2)
    ! e = x0/sx^2 + (y-c) m/ sy^2
    ! f = x0^2 /sx^2 + (y-c)^2 / sy^2
    !
    ! The integral can then be computed with error functions, since
    !
    ! /x2
    ! |      exp( (x-x0)^2/2s^2 ) dx =
    ! /x1
    !
    ! sqrt(pi/2) s ( erf( (x2-x0)/sqrt2 s) - erf( (x1-x0)/sqrt2 s) )
    !
    function log_exp_int(x0,y0,sx,sy,xmin,xmax)
        use utils_module, only: logzero,logincexp
        implicit none

        real(dp), intent(in) :: x0,y0,sx,sy,xmin,xmax
        real(dp) :: log_exp_int

        integer :: i,n
        real(dp) :: m,c,x1,x2,y1,y2

        real(dp) :: s,e,f

        real(dp),parameter :: logsqrtpiby2 = log(sqrt(atan(1d0)*2d0))

        log_exp_int = logzero

        n = size(spline_data,1)

        do i=1,n-1

            ! Here are some useful local variables
            x1 = spline_data(i,1)
            y1 = spline_data(i,2)
            x2 = spline_data(i+1,1)
            y2 = spline_data(i+1,2)

            m = (y2-y1)/(x2-x1)
            c =  y1 - m*x1

            ! Check to see our integration range
            if(x2<xmin) cycle
            if(x1<xmin) x1 = xmin

            if(x1>xmax) cycle
            if(x2>xmax) x2 = xmax

            ! Define the reduced variables
            s  = (1/sx**2 + m**2/sy**2)**(-0.5)
            e  = x0/sx**2 + (y0-c)*m/sy**2
            f  = x0**2 /sx**2 + (y0-c)**2/sy**2

            call logincexp(log_exp_int,&
                logsqrtpiby2 + log(s) +&
                logderf(&
                (x1-e*s**2)/sqrt(2d0)/s ,&
                (x2-e*s**2)/sqrt(2d0)/s  &
                )&
                - f/2 + e**2*s**2/2 &
                )

        end do

    end function log_exp_int

    function logderf(a,b)
        use utils_module, only: logzero
        implicit none
        real(dp),intent(in) :: a,b
        real(dp) logderf

        real(dp) :: erfa,erfb

        erfb = erf(b)
        erfa = erf(a)

        if(erfb<=erfa) then
            logderf = logzero
        else
            logderf = log(erfb-erfa)
        end if

    end function logderf

    function erfapprox(x)
        implicit none
        real(dp), intent(in) :: x
        real(dp) erfapprox

        real(dp), parameter :: pi = atan(1d0)*4d0
        real(dp), parameter :: a = 8*(pi-3)/(3*pi*(4-pi))

        erfapprox = sign(1d0,x)*sqrt(1-exp(-x**2*(4/pi + a*x**2)/(1+a*x**2)))
    end function erfapprox

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

        integer, parameter :: stats_unit = 1000

        integer :: ioerror
        integer :: i_stats

        ! Save the current theta for use next call
        nDims = settings%nDims
        n_knots = nDims/2

        ! Allocate any arrays that need to be allocated
        if(allocated(theta_saved)) deallocate(theta_saved)
        if(allocated(spline_data)) deallocate(spline_data)
        if(allocated(x0)) deallocate(x0)
        if(allocated(y0)) deallocate(y0)
        if(allocated(sigmax)) deallocate(sigmax)
        if(allocated(sigmay)) deallocate(sigmay)

        allocate(theta_saved(nDims),spline_data(n_knots,2))

        ! Find out the number of points
        open(stats_unit,file='data/data.dat')

        nStats = 0
        do
            read(stats_unit,*,iostat=ioerror)
            if( ioerror==0 ) then
                nStats = nStats+1
            else
                exit
            end if
        end do

        close(stats_unit)

        if (nStats == 0) call halt_program('Error reading data/data.dat')

        ! Allocate the data arrays
        allocate(x0(nStats),y0(nStats),sigmax(nStats),sigmay(nStats))

        ! Read in the data array
        open(stats_unit,file='data/data.dat')
        do i_stats=1,nStats
            read(stats_unit,*) x0(i_stats), y0(i_stats), sigmax(i_stats), sigmay(i_stats)
        end do
        close(stats_unit)

        ! Read in the mins and maxs array
        open(stats_unit,file='data/data_min_max.dat')
        read(stats_unit,*) x_min
        read(stats_unit,*) x_max
        close(stats_unit)

    end subroutine setup_loglikelihood

    function linear_interpolate(x,spline_array,deriv) result(y)

        implicit none

        real(dp)            :: y                  ! dependent variable
        real(dp),intent(in) :: x                  ! independent variable
        real(dp),intent(in) :: spline_array(:,:)  ! x coords of interpolation
                                                          ! y coords of interpolation
        integer,         intent(in) :: deriv              ! whether 0 or 1 derivatives

        integer i
        integer :: num_nodes
        real(dp), dimension(size(spline_array,1)) :: x_node
        real(dp), dimension(size(spline_array,1)) :: y_node

        !------------------------------------------------------------------------------
        !
        !                     y_node(2)^                                           +
        !                            <-+->                         ^       +
        !       y_node(1)^      +      v   +                     <-+->
        !              <-+->                   +   ^       +       v y_node(num_nodes)
        !         +      v                       <-+->
        !  +                                       v y_node(3)
        !
        !
        !----------------+-------------+-----------+---------------+-------------------
        !            x_node(1)    x_node(2)      x_node(3)      x_node(num_nodes)
        !
        ! This function constructs a linear interpolation:
        ! http://en.wikipedia.org/wiki/Linear_interpolation
        !
        ! The interpolation points are
        ! {  ( x_node(i) , y_node(i) )  : i=1..num_nodes }
        !
        ! Outside of the range, the function is continued with the previous
        ! gradient
        !

        num_nodes = size(spline_array,1)
        x_node = spline_array(:,1)
        y_node = spline_array(:,2)

        ! We need a positive number of nodes
        if (num_nodes < 1) then
            write(*,*) 'linear_interpolate: cannot have less than 1 node'
            stop
        else if (num_nodes==1) then
            ! If we have only a single node, then this is a 'flat function'
            ! defined only by the y_node
            select case(deriv)
            case(0)
                y=y_node(1)
            case(1)
                y=0d0
            end select
            return
        endif

        ! We should also check that the x values are ordered properly
        do i=2,num_nodes
            if( x_node(i-1)>x_node(i) ) then
                write(*,*) 'linear_interpolate: nodes are not ordered correctly'
                write(*,*) 'x_nodes:', x_node
                stop
            endif
        end do

        ! We proceed from low x to high x.

        ! First consider the case when we're below the bottom x_node
        if ( x <= x_node(1) ) then
            ! we want a 'line continuation' on this side
            select case(deriv)
            case(0)
                y = y_node(1) + (y_node(2)-y_node(1)) * (x-x_node(1)) / (x_node(2)-x_node(1))
            case(1)
                y = (y_node(2)-y_node(1)) / (x_node(2)-x_node(1))
            end select
            return

        endif

        ! Now consider the cases when we're in between
        do i=2,num_nodes
            if ( x <= x_node(i) ) then
                select case(deriv)
                case(0)
                    y = y_node(i-1) + (y_node(i)-y_node(i-1)) * (x-x_node(i-1)) / (x_node(i)-x_node(i-1))
                case(1)
                    y = (y_node(i)-y_node(i-1)) / (x_node(i)-x_node(i-1))
                end select
                return
            endif
        enddo

        ! Finally consider the case when we're above the top x_node
        if ( x >= x_node(num_nodes) ) then
            ! we want a 'line continuation' on this side
            select case(deriv)
            case(0)
                y = y_node(num_nodes-1)                          &
                    + (y_node(num_nodes)-y_node(num_nodes-1))    &
                    * (x-x_node(num_nodes-1))                    &
                    / (x_node(num_nodes)-x_node(num_nodes-1))
            case(1)
                y =   (y_node(num_nodes)-y_node(num_nodes-1))    &
                    / (x_node(num_nodes)-x_node(num_nodes-1))
            end select
            return

        endif

    end function linear_interpolate

end module loglikelihood_module


      SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the matrices A and E of the system pencil
C
C             S =  ( A  B ) - lambda ( E  0 ) ,
C                  ( C  0 )          ( 0  0 )
C
C     corresponding to the descriptor triple (A-lambda E,B,C),
C     to generalized upper Hessenberg form using orthogonal
C     transformations,
C
C          Q' * A * Z = H,   Q' * E * Z = T,
C
C     where H is upper Hessenberg, T is upper triangular, Q and Z
C     are orthogonal, and ' means transpose. The corresponding
C     transformations, written compactly as diag(Q',I) * S * diag(Z,I),
C     are also applied to B and C, getting Q' * B and C * Z.
C
C     The orthogonal matrices Q and Z are determined as products of
C     Givens rotations. They may either be formed explicitly, or they
C     may be postmultiplied into input matrices Q1 and Z1, so that
C
C          Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
C          Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBE    CHARACTER*1
C             Specifies whether E is a general square or an upper
C             triangular matrix, as follows:
C             = 'G':  E is a general square matrix;
C             = 'U':  E is an upper triangular matrix.
C
C     COMPQ   CHARACTER*1
C             Indicates what should be done with matrix Q, as follows:
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'V':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             Indicates what should be done with matrix Z, as follows:
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'V':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, E, and the number of rows of
C             the matrix B.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 0.
C
C     ILO     (input) INTEGER
C     IHI     (input) INTEGER
C             It is assumed that A and E are already upper triangular in
C             rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI could
C             normally be set by a previous call to LAPACK Library
C             routine DGGBAL; otherwise they should be set to 1 and N,
C             respectively.
C             1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
C             If JOBE = 'U', the matrix E is assumed upper triangular.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the upper Hessenberg matrix H = Q' * A * Z. The elements
C             below the first subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the descriptor matrix E. If JOBE = 'U', this
C             matrix is assumed upper triangular.
C             On exit, the leading N-by-N part of this array contains
C             the upper triangular matrix T = Q' * E * Z. The elements
C             below the diagonal are set to zero.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, if M > 0, the leading N-by-M part of this array
C             contains the transformed matrix Q' * B.
C             The array B is not referenced if M = 0.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N) if M > 0;  LDB >= 1 if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, if P > 0, the leading P-by-N part of this array
C             contains the transformed matrix C * Z.
C             The array C is not referenced if P = 0.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'N':  Q is not referenced;
C             If COMPQ = 'I':  on entry, Q need not be set, and on exit
C                              it contains the orthogonal matrix Q,
C                              where Q' is the product of the Givens
C                              transformations which are applied to A,
C                              E, and B on the left;
C             If COMPQ = 'V':  on entry, Q must contain an orthogonal
C                              matrix Q1, and on exit this is
C                              overwritten by Q1*Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N':  Z is not referenced;
C             If COMPZ = 'I':  on entry, Z need not be set, and on exit
C                              it contains the orthogonal matrix Z,
C                              which is the product of the Givens
C                              transformations applied to A, E, and C
C                              on the right;
C             If COMPZ = 'V':  on entry, Z must contain an orthogonal
C                              matrix Z1, and on exit this is
C                              overwritten by Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 1,                          if JOBE = 'U';
C             LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where
C             NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise.
C             For good performance, if JOBE = 'G', LDWORK must generally
C             be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where
C             NB is the optimal block size.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     First, this routine computes the QR factorization of E and applies
C     the transformations to A, B, and possibly Q. Then, the routine
C     reduces A to upper Hessenberg form, preserving E triangular, by
C     an unblocked reduction [1], using two sequences of plane rotations
C     applied alternately from the left and from the right. The
C     corresponding transformations may be accumulated and/or applied
C     to the matrices B and C. If JOBE = 'U', the initial reduction of E
C     to upper triangular form is skipped.
C
C     This routine is a modification and extension of the LAPACK Library
C     routine DGGHRD [2].
C
C     REFERENCES
C
C     [1] Golub, G.H. and van Loan, C.F.
C         Matrix Computations. Third Edition.
C         M. D. Johns Hopkins University Press, Baltimore, 1996.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     CONTRIBUTOR
C
C     D. Sima, University of Bucharest, May 2001.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2001.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, matrix algebra, matrix operations, similarity
C     transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOBE
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ,
     $                   LDWORK, LDZ, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK(  * ), E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC
      INTEGER            IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK
      DOUBLE PRECISION   CS, S, TEMP
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
C
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      UPPER = LSAME( JOBE,  'U' )
      INQ   = LSAME( COMPQ, 'I' )
      ILQ   = LSAME( COMPQ, 'V' ) .OR. INQ
      INZ   = LSAME( COMPZ, 'I' )
      ILZ   = LSAME( COMPZ, 'V' ) .OR. INZ
      WITHB = M.GT.0
      WITHC = P.GT.0
C
      INFO = 0
      IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -7
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN
         INFO = -14
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -18
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -20
      ELSE
         JROW = IHI + 1 - ILO
         JCOL = N + 1 - ILO
         IF( UPPER ) THEN
            MINWRK = 1
            MAXWRK = 1
         ELSE
            IF( ILQ ) THEN
               MINWRK = N
            ELSE
               MINWRK = JCOL
            END IF
            MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) )
         END IF
         IF( LDWORK.LT.MINWRK )
     $      INFO = -22
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01BD', -INFO )
         RETURN
      END IF
C
C     Initialize Q and Z if desired.
C
      IF( INQ )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      IF( INZ )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      IF( N.LE.1 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF( .NOT.UPPER ) THEN
C
C        Reduce E to triangular form (QR decomposition of E).
C
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of real workspace needed at that point in the
C        code, as well as the preferred amount for good performance.
C        NB refers to the optimal block size for the immediately
C        following subroutine, as returned by ILAENV.)
C
C        Workspace: need   IHI+1-ILO+N+1-ILO;
C                   prefer IHI+1-ILO+(N+1-ILO)*NB.
C
         ITAU = 1
         IWRK = ITAU + JROW
         CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ),
     $                DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK )
C
C        Apply the orthogonal transformation to matrices A, B, and Q.
C        Workspace: need   IHI+1-ILO+N+1-ILO;
C                   prefer IHI+1-ILO+(N+1-ILO)*NB.
C
         CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW,
     $                E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ),
     $                LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
         IF ( WITHB ) THEN
C
C           Workspace: need   IHI+1-ILO+M;
C                      prefer IHI+1-ILO+M*NB.
C
            CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW,
     $                   E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ),
     $                   LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
         END IF
C
         IF( ILQ ) THEN
C
C           Workspace: need   IHI+1-ILO+N;
C                      prefer IHI+1-ILO+N*NB.
C
            CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW,
     $                   E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ),
     $                   LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
         END IF
      END IF
C
C     Zero out lower triangle of E.
C
      IF( JROW.GT.1 )
     $   CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO,
     $                E( ILO+1, ILO ), LDE )
C
C     Reduce A and E and apply the transformations to B, C, Q and Z.
C
      DO 20 JCOL = ILO, IHI - 2
C
         DO 10 JROW = IHI, JCOL + 2, -1
C
C           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL).
C
            TEMP = A( JROW-1, JCOL )
            CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S,
     $                   A( JROW-1, JCOL ) )
            A( JROW, JCOL ) = ZERO
            CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
     $                 A( JROW, JCOL+1 ), LDA, CS, S )
            CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE,
     $                 E( JROW, JROW-1 ), LDE, CS, S )
            IF( WITHB )
     $         CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB,
     $                    CS, S )
            IF( ILQ )
     $         CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S )
C
C           Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1).
C
            TEMP = E( JROW, JROW )
            CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S,
     $                   E( JROW, JROW ) )
            E( JROW, JROW-1 ) = ZERO
            CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S )
            CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS,
     $                 S )
            IF( WITHC )
     $         CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S )
            IF( ILZ )
     $         CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S )
   10    CONTINUE
C
   20 CONTINUE
C
      DWORK( 1 ) = MAXWRK
      RETURN
C *** Last line of TG01BD ***
      END


!-----------------------------------------------------------------------
! Update soil temperatures
!-----------------------------------------------------------------------
subroutine SOIL(csoil,Gsoil,ksoil)

use DRIVING, only : &
  dt                  ! Timestep (s)

use GRID, only : &
  Dzsoil,            &! Soil layer thicknesses (m)
  Nsoil               ! Number of soil layers

use STATE_VARIABLES, only : &
  Tsoil               ! Soil layer temperatures (K)

implicit none

real, intent(in) :: &
  csoil(Nsoil),      &! Areal heat capacity of soil (J/K/m^2)
  Gsoil,             &! Heat flux into soil (W/m^2)
  ksoil(Nsoil)        ! Thermal conductivity of soil (W/m/K)

integer :: &
  k                   ! Level counter

real :: &
  a(Nsoil),          &! Below-diagonal matrix elements
  b(Nsoil),          &! Diagonal matrix elements
  c(Nsoil),          &! Above-diagonal matrix elements
  dTs(Nsoil),        &! Temperature increments (k)
  Gs(Nsoil),         &! Thermal conductivity between layers (W/m^2/k)
  rhs(Nsoil)          ! Matrix equation rhs

do k = 1, Nsoil - 1
  Gs(k) = 2 / (Dzsoil(k)/ksoil(k) + Dzsoil(k+1)/ksoil(k+1))
end do
a(1) = 0
b(1) = csoil(1) + Gs(1)*dt
c(1) = - Gs(1)*dt
rhs(1) = (Gsoil - Gs(1)*(Tsoil(1) - Tsoil(2)))*dt
do k = 2, Nsoil - 1
  a(k) = c(k-1)
  b(k) = csoil(k) + (Gs(k-1) + Gs(k))*dt
  c(k) = - Gs(k)*dt
  rhs(k) = Gs(k-1)*(Tsoil(k-1) - Tsoil(k))*dt  &
           + Gs(k)*(Tsoil(k+1) - Tsoil(k))*dt
end do
k = Nsoil
Gs(k) = ksoil(k)/Dzsoil(k)
a(k) = c(k-1)
b(k) = csoil(k) + (Gs(k-1) + Gs(k))*dt
c(k) = 0
rhs(k) = Gs(k-1)*(Tsoil(k-1) - Tsoil(k))*dt
call TRIDIAG(Nsoil,Nsoil,a,b,c,rhs,dTs)
do k = 1, Nsoil
  Tsoil(k) = Tsoil(k) + dTs(k)
end do

end subroutine SOIL


PROGRAM YULETIDE

IMPLICIT NONE

INTEGER :: day, year

WRITE(*, "(A)", ADVANCE="NO") "25th of December is a Sunday in"
DO year = 2008, 2121
   day = Day_of_week(25, 12, year)
   IF (day == 1) WRITE(*, "(I5)", ADVANCE="NO") year
END DO

CONTAINS

FUNCTION Day_of_week(d, m, y)
   INTEGER :: Day_of_week, j, k, mm, yy
   INTEGER, INTENT(IN) :: d, m, y

   mm=m
   yy=y
   IF(mm.le.2) THEN
      mm=mm+12
      yy=yy-1
   END IF
   j = yy / 100
   k = MOD(yy, 100)
   Day_of_week = MOD(d + ((mm+1)*26)/10 + k + k/4 + j/4 + 5*j, 7)
END FUNCTION Day_of_week

END PROGRAM YULETIDE


module maths_module

    use iso_fortran_env, wp => real64
    implicit none

    real (wp), parameter :: c = 299792458.0_wp
    real (wp), parameter :: e = &
        2.7182818284590452353602874713526624977_wp
    real (wp), parameter :: g = 9.812420_wp
    real (wp), parameter :: pi = &
        3.141592653589793238462643383279502884_wp
end module


module type_GaussianGrid

    use, intrinsic :: ISO_Fortran_env, only: &
        stderr => ERROR_UNIT

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

    use type_SphericalGrid, only: &
        SphericalGrid

    use gaussian_latitudes_and_weights_routines, only: &
        compute_gaussian_latitudes_and_weights

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: GaussianGrid

    type, public, extends(SphericalGrid) :: GaussianGrid
        ! Type components
        real(wp), allocatable, public :: gaussian_weights(:)
    contains
        ! Type-bound procedures
        procedure, public  :: assert_initialized => assert_init_gaussian_grid
        procedure, public  :: create => create_gaussian_grid
        procedure, public  :: destroy => destroy_gaussian_grid
        procedure, public, nopass :: get_latitudes_and_gaussian_weights
        procedure, public  :: unformatted_print
        generic,   public  :: assignment (=) => copy_gaussian_grid
        procedure, private :: copy_gaussian_grid
    end type GaussianGrid

    ! Declare user-defined constructor
    interface GaussianGrid
        module procedure gaussian_grid_constructor
    end interface

contains

    function gaussian_grid_constructor(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat ! number of latitudinal points 0 <= theta <= pi
        integer(ip), intent(in) :: nlon ! number of longitudinal points 0 <= phi <= 2*pi
        type(GaussianGrid)      :: return_value

        call return_value%create(nlat, nlon)

    end function gaussian_grid_constructor

    subroutine assert_init_gaussian_grid(self, routine)

        ! Dummy arguments
        class(GaussianGrid), intent(inout) :: self
        character(len=*),    intent(in)    :: routine

        ! Check if object is usable
        select type(self)
            class is (GaussianGrid)
            if (.not.self%initialized) then
                write (stderr, '(a)') &
                    'Uninitialized object of class(GaussianGrid) in '//routine
            end if
        end select

    end subroutine assert_init_gaussian_grid

    subroutine copy_gaussian_grid(self, other)

        ! Dummy arguments
        class(GaussianGrid), intent(out) :: self
        class(GaussianGrid), intent(in)  :: other

        ! Check if object is usable
        if (.not.other%initialized) then
            error stop 'Uninitialized object of class(GaussianGrid): '&
                //'in assignment (=) '
        end if

        !  Make copies
        self%initialized = other%initialized
        self%NUMBER_OF_LONGITUDES = other%NUMBER_OF_LONGITUDES
        self%NUMBER_OF_LATITUDES = other%NUMBER_OF_LATITUDES
        self%LONGITUDINAL_MESH = other%LONGITUDINAL_MESH
        self%latitudes = other%latitudes
        self%longitudes = other%longitudes
        self%gaussian_weights = other%gaussian_weights
        self%grid_type = other%grid_type

    end subroutine copy_gaussian_grid

    subroutine create_gaussian_grid(self, nlat, nlon)

        ! Dummy arguments
        class(GaussianGrid), intent(inout) :: self
        integer(ip),         intent(in)    :: nlat ! number of latitudinal points 0 <= theta <= pi
        integer(ip),         intent(in)    :: nlon ! number of longitudinal points 0 <= phi <= 2*pi

        ! Ensure that object is usable
        call self%destroy()

        ! Set contants
        self%NUMBER_OF_LATITUDES = nlat
        self%NUMBER_OF_LONGITUDES = nlon

        ! Set the gaussian grid type
        allocate (self%grid_type, source='gaussian')

        ! Set longitudinal grid: 0 <= phi <= 2*pi
        call self%get_equally_spaced_longitudes(nlon, self%longitudes)

        ! Set latitudinal grid: 0 <= theta <= pi
        call self%get_latitudes_and_gaussian_weights(nlat, self%latitudes, self%gaussian_weights)

        ! Set initialization flag
        self%initialized = .true.

    end subroutine create_gaussian_grid

    subroutine destroy_gaussian_grid(self)

        ! Dummy arguments
        class(GaussianGrid), intent(inout) :: self

        ! Check initialization flag
        if (.not.self%initialized) return

        !  Release memory
        if (allocated(self%gaussian_weights)) deallocate (self%gaussian_weights)

        call self%destroy_grid()

        ! Reset initialization flag
        self%initialized = .false.

    end subroutine destroy_gaussian_grid

    subroutine get_latitudes_and_gaussian_weights(nlat, gaussian_latitudes, gaussian_weights)

        ! Dummy arguments
        integer(ip),           intent(in)    :: nlat ! number of latitudinal points
        real(wp), allocatable, intent(out)   :: gaussian_latitudes(:) ! latitudinal points: 0 <= theta <= pi
        real(wp), allocatable, intent(out)   :: gaussian_weights(:)

        ! Local variables
        integer(ip)  :: error_flag

        ! Check input argument
        if (nlat <= 0) then
            error stop 'Object of class(GaussianGrid): '&
                //'invalid argument nlat <= 0 '&
                //'in get_equally_spaced_latitudes'
        end if

        ! Allocate memory
        allocate (gaussian_latitudes(nlat))
        allocate (gaussian_weights(nlat))

        ! Compute gaussian weights and latitudes
        call compute_gaussian_latitudes_and_weights( &
            nlat, gaussian_latitudes, gaussian_weights, error_flag)

        ! Address error flag
        select case (error_flag)
            case(0)
                return
            case(1)
                error stop 'Object of class(GaussianGrid) '&
                    //'fails to satisfy nlat >= 0 '&
                    //'in get_latitudes_and_gaussian_weights'
            case default
                error stop 'Object of class(GaussianGrid): '&
                    //'undetermined error in '&
                    //'get_latitudes_and_gaussian_weights'
        end select

    end subroutine get_latitudes_and_gaussian_weights

    subroutine unformatted_print(self, header)

        ! Dummy arguments
        class(GaussianGrid), intent(inout) :: self
        character(len=*),    intent(in)    :: header

        ! Local variables
        integer(ip)  :: file_unit

        ! Check if object is usable
        call self%assert_initialized('unformatted_print')

        ! Write latitudes and longitudes
        call self%print_to_unformatted_binary_files(header)

        ! Write gaussian weights
        associate (wts => self%gaussian_weights)
            open( newunit=file_unit, &
                file=header//'gaussian_weights.dat', &
                status='replace', form='unformatted', &
                action='write', access='stream')
            write (file_unit) wts
            close( file_unit)
        end associate

    end subroutine unformatted_print

end module type_GaussianGrid


! Copyright (c) 2015 Alex Kramer <alkramer@phys.ksu.edu>
! See the LICENSE.txt file in the top-level directory of this distribution.

! Assorted numerical helper functions
! Note: This is a program-independent module
module numerics
  use globvars, only: dp

  implicit none

  private

  public :: numerics_linspace
  public :: numerics_d1
  public :: numerics_d2
  public :: numerics_rk4
  public :: numerics_cmplx_phase
  public :: numerics_trapz

contains

  ! Populate an array with linearly-spaced values between x_min and x_max
  !
  ! x_min :: minimum array value
  ! x_max :: maximum array value
  ! x_arr(:) :: array to populate, must already be allocated
  ! dx :: step size of `x_arr(:)`, given its size and `x_min`, `x_max`
  subroutine numerics_linspace(x_min, x_max, x_arr, dx)

    real(dp), intent(in) :: x_min, x_max
    real(dp), intent(out) :: x_arr(:)
    real(dp), intent(out) :: dx

    integer :: i_x, n_x

    n_x = size(x_arr)
    dx = (x_max - x_min) / n_x

    do i_x = 1, n_x
       x_arr(i_x) = x_min + i_x * dx
    end do

  end subroutine numerics_linspace

  ! Calculate the 1st derivative of a complex array-valued function with
  ! respect to a real-valued coordinate with constant spacing:
  !
  !   f'(x) ~= (f(x + dx) - f(x - dx)) / (2 dx)
  !
  ! arr :: function array
  ! d_arr :: array to populate
  ! dx :: coordinate spacing
  subroutine numerics_d1(arr, d_arr, dx)

    complex(dp), intent(in) :: arr(:)
    complex(dp), intent(inout) :: d_arr(:)
    real(dp), intent(in) :: dx
    integer :: i_x, n_x
    real(dp) :: scale

    n_x = size(arr)
    scale = 1.0_dp / (2.0_dp * dx)

    ! Special edge cases - we assume the grid is fine enough and the function
    ! is smooth enough that this is accurate enough. For the left case:
    !
    !   f(x + h) = arr(2), f(x - h) = arr(1)
    !
    ! For the right case:
    !
    !   f(x + h) = arr(n), f(x - h) = arr(n - 1)
    d_arr(1) = arr(2) - arr(1)
    do i_x = 2, n_x - 1
       d_arr(i_x) = arr(i_x + 1) - arr(i_x - 1)
    end do
    d_arr(n_x) = arr(n_x) - arr(n_x - 1)

    d_arr(:) = scale * d_arr(:)

  end subroutine numerics_d1

  ! Calculate the 2nd derivative of a complex array-valued function with
  ! respect to a real-valued coordinate with constant spacing:
  !
  !   f''(x) ~= (f(x - dx) - 2 f(x) + f(x + dx)) / (dx**2)
  !
  ! arr :: function array
  ! d2_arr :: array to populate
  ! dx :: coordinate spacing
  subroutine numerics_d2(arr, d2_arr, dx)

    complex(dp), intent(in) :: arr(:)
    complex(dp), intent(inout) :: d2_arr(:)
    real(dp), intent(in) :: dx
    integer :: i_x, n_x
    real(dp) :: scale

    n_x = size(arr)
    scale = 1.0_dp / dx**2

    ! Special edge cases - we assume the grid is fine enough and the function
    ! is smooth enough that this is accurate enough. For the left case:
    !
    !   f(x + h) = arr(2), f(x - h) = arr(1)
    !
    ! For the right case:
    !
    !   f(x + h) = arr(n), f(x - h) = arr(n - 1)
    d2_arr(1) = arr(1) + arr(2)
    do i_x = 2, n_x - 1
       d2_arr(i_x) = arr(i_x - 1) - 2 * arr(i_x) + arr(i_x + 1)
    end do
    d2_arr(n_x) = arr(n_x) + arr(n_x - 1)

    d2_arr(:) = scale * d2_arr(:)

  end subroutine numerics_d2

  ! 4th order Runge-Kutta propagator for the first order system of differential
  ! equations dy/dt = f(t, y)
  !
  ! f :: differential equation dy/dt = f(y, t) that returns values of the same
  !   dimension as y
  ! y :: current state array
  ! t :: current time parameter
  ! dt :: time step
  !
  ! Note that the state array is overwritten during propagation.
  subroutine numerics_rk4(f, y, t, dt)
    complex(dp), intent(inout) :: y(:)
    real(dp), intent(in) :: t
    real(dp), intent(in) :: dt

    complex(dp), dimension(size(y)) :: k1, k2, k3, k4

    ! Explicit interface for external differential equation system
    interface

       function f(y, t) result(val)
         import dp
         real(dp) :: t
         complex(dp) :: y(:), val(size(y))
       end function f

    end interface

    k1 = f(y, t)
    k2 = f(y + dt / 2 * k1, t + dt / 2)
    k3 = f(y + dt / 2 * k2, t + dt / 2)
    k4 = f(y + dt * k3, t + dt)

    y = y + dt / 6 * (k1 + 2 * k2 + 2 * k3 + k4)

  end subroutine numerics_rk4

  ! Get the phase of a complex number z = A exp(i phi), where A determines the
  ! magnitude, and phi determines the phase angle.
  real(dp) function numerics_cmplx_phase(z) result(val)
    complex(dp), intent(in) :: z

    val = atan2(aimag(z),real(z))

  end function numerics_cmplx_phase

  real(dp) function numerics_trapz(f_arr, dx) result(val)
    real(dp), intent(in) :: f_arr(:)
    real(dp), intent(in) :: dx

    integer :: i_x
    real(dp) :: trapz_cnst

    trapz_cnst = dx / 2.0_dp
    val = 0.0_dp

    do i_x = 1, size(f_arr) - 1
       val = val + (f_arr(i_x) + f_arr(i_x + 1))
    end do

    val = val * trapz_cnst

  end function numerics_trapz

end module numerics


c    # ----------------------------------------------------------------------------------
c    # Output and diagnostics
c    # ----------------------------------------------------------------------------------
      subroutine user_fort_conservation_check(mx,my,mbc,meqn,
     &      dx,dy,area,q,sum)
      implicit none

      integer mx,my,mbc,meqn
      double precision dx, dy, dxdy
      double precision sum(meqn)
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      include 'fclaw2d_metric_terms.i'

      integer i,j,m
      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      cont = get_context()

      dxdy = dx*dy
      do m = 1,meqn
         if (fclaw2d_map_is_used(cont)) then
            do j = 1,my
               do i = 1,mx
                  sum(m) = sum(m) + q(i,j,m)*area(i,j)
               enddo
            enddo
         else
            do j = 1,my
               do i = 1,mx
                  sum(m) = sum(m) + q(i,j,m)*dx*dy
               enddo
            enddo
         endif
      enddo

      end

c     # Compute area of a patch
      double precision function
     &      fc2d_clawpack46_fort_compute_patch_area
     &      (mx,my, mbc,dx,dy,area)
      implicit none

      integer mx,my, mbc
      double precision dx, dy
      double precision sum

      include 'fclaw2d_metric_terms.i'

      integer i,j,m
      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      cont = get_context()

      if (fclaw2d_map_is_used(cont)) then
         sum = 0
         do j = 1,my
            do i = 1,mx
               sum = sum + area(i,j)
            enddo
         enddo
      else
         sum = dx*dy*mx*my
      endif

      fc2d_clawpack46_fort_compute_patch_area = sum

      end

      subroutine user_fort_compute_error_norm(mx,my,mbc,
     &      meqn,dx,dy,area,error,error_norm)
      implicit none

      integer mx,my,mbc,meqn
      double precision dx, dy, dxdy, eij
      double precision error_norm(meqn,3)
      double precision error(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      include 'fclaw2d_metric_terms.i'

      integer i,j,m
      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      cont = get_context()

c     # error_norm(:) comes in with values;  do not initialize it here!
      dxdy = dx*dy
      do m = 1,meqn
         if (fclaw2d_map_is_used(cont)) then
            do j = 1,my
               do i = 1,mx
                  eij = abs(error(i,j,m))
                  error_norm(m,1) = error_norm(m,1) +
     &                  eij*area(i,j)
                  error_norm(m,2) = error_norm(m,2) +
     &                  eij**2*area(i,j)
                  error_norm(m,3) = max(eij,error_norm(m,3))
               enddo
            enddo
         else
            do j = 1,my
               do i = 1,mx
                  eij = abs(error(i,j,m))
                  error_norm(m,1) = error_norm(m,1) +
     &                  eij*dxdy
                  error_norm(m,2) = error_norm(m,2) +
     &                  eij**2*dxdy
                  error_norm(m,3) = max(eij,error_norm(m,3))
               enddo
            enddo
         endif
      enddo

      end


      program choles
      integer n
      real*8 a(n,n), p(n), x
      integer i, j, k
      do i=1,n
         x = a(i,i)
         do k = 1, i-1
            x = x - a(i,k)**2
         end do
         p(i) = 1.0/sqrt(x)
         do j = i+1, n
            x = a(i,j)
            do k=1,i-1
               x = x - a(j,k) * a(i,k)
            end do
            a(j,i) = x * p(i)
         end do
      end do
      end


module m
implicit none
contains
function pos_first_positive_each_row(x) result(ipos)
! return vector with position of first positive
! element in each row
real, intent(in) :: x(:,:)
integer          :: ipos(size(x,1))
integer          :: i,j
ipos = 0
iloop: do i=1,size(x,1)
   jloop: do j=1,size(x,2)
      if (x(i,j) > 0.0) then
         ipos(i) = j
         cycle iloop ! or write exit jloop
      end if
   end do jloop
end do iloop
end function pos_first_positive_each_row
end module m
!
program test_cycle
use m
integer, parameter :: n1 = 5, n2 = 3
real :: x(n1,n2)
integer :: i,ipos_positive(n1),j
call random_number(x)
x = x - 0.5
ipos_positive = pos_first_positive_each_row(x)
print "(*(a8))","i","x(i,:)"
do i=1,n1
   print "(i8,*(f8.2))",ipos_positive(i),x(i,:)
end do
! print square root of first positive element in each row
print "(/,2a3,*(a14))","i","j","x(i,j)","sqrt(x(i,j))"
do i=1,n1
   j = ipos_positive(i)
   if (j == 0) cycle ! avoid computing sqrt of negative #
   print "(2i3,*(f14.2))",i,j,x(i,j),sqrt(x(i,j))
end do
end program test_cycle
! sample output:
!        i  x(i,:)
!        2   -0.23    0.28   -0.48
!        2   -0.37    0.27   -0.09
!        0   -0.02   -0.06   -0.43
!        1    0.07   -0.20   -0.25
!        0   -0.17   -0.16   -0.13
!
!   i  j        x(i,j)  sqrt(x(i,j))
!   1  2          0.28          0.53
!   2  2          0.27          0.52
!   4  1          0.07          0.27


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine tt_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase,iflag)
!
!     this subroutine solves the implicit equation
!     f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0
!     in order to find Tt when ts , xflow, pt and a are given
!
!     author: Yannick Muller
!
      implicit none
!
      integer inv,icase,i,iflag
!
      real*8 xflow,Tt,Pt,Ts,kappa,r,f,df,a,expon,Tt_old,C,TtzTs,
     &     deltaTt,TtzTs_crit, Qred_crit,Qred,h1,h2,h3,Tt_crit
!
      expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0)
!
      C=dsqrt(2.d0/r*kappa/(kappa-1.d0))
!
!     f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0
!
!     df=-C*Ttdt**expon*(expon/Ts*(TtdT-1)**0.5d0
!     &     -0.5d0*TtdT/Ts*(TtdT-1.d0)**(-0.5d0))
!
      Tt_old=Tt
!
!
      if(xflow.lt.0d0) then
         inv=-1
      else
         inv=1
      endif
!
      if(dabs(xflow).le.1e-9) then
         Tt=Ts
         return
      endif
!
      Qred=abs(xflow)*dsqrt(Tt)/(a*Pt)
!
c      write(*,*) 'epsilon',(Qred/C)**2
!
!     optimised estimate of T static
!
      Tt=Ts*(1+(Qred**2/C**2))
!
!     adiabatic
!
      if(icase.eq.0) then
!
         TtzTs_crit=(kappa+1.d0)/2.d0
!
!     isothermal
!
      else
!
!         if(iflag.ne.3) then
         TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa))
         if(iflag.ne.3) then
            Tt_crit=(A*pt/(dabs(xflow))*C*Ttzts_crit**expon*
     &           (TtzTs_crit-1)**0.5d0)**2
!         if(iflag.ne.3) then
            if(Tt.gt.Tt_crit) then
               Tt=Tt_crit
            endif
         endif
!         Tt=Tt_crit
!         Qred=abs(xflow)*dsqrt(Tt)/(a*Pt)
!
      endif
!
      Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0
!
!
      if(Qred.ge.Qred_crit) then
!
         Tt=Ts*TtzTs_crit
!
         return
!
      endif
      i=0
!
      do
         i=i+1
         Ttzts=Tt/Ts
         h1=Ttzts-1.d0
         h2= dsqrt(h1)
         h3=Ttzts**expon
!
         f=C*h2*h3
!
         df=0.5*inv*xflow/(A*Pt*dsqrt(Tt))
     &        -1/Tt*C*h2*h3*(expon+0.5d0*(h1)**(-1))
!
         f=Qred-f
         deltaTt=-f/df
c         write(*,*) 'deltaTs=',deltaTs
!
         Tt=Tt+deltaTt
c         write(*,*) 'Ts',Ts
!
         if( (((dabs(Tt-Tt_old)/tt_old).le.1.E-8))
     &        .or.((dabs(Tt-Tt_old)).le.1.E-10)
     &    .or.((f.le.1E-5).and.(deltaTt.lt.1E-3))) then
c            write(*,*) 'f=',f
c            write(*,*) 'Ts=',Ts
c            write(*,*) 'i',i
c$$$c            write(*,*) ''
c$$$            write(*,*) 'f',f
c$$$            write(*,*) ''
c$$$            write(*,*) 'Ts',Ts
c$$$            write(*,*) 'Tt',Tt
c$$$            write(*,*) ''
            Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0
            Qred=abs(xflow)*dsqrt(Tt)/(a*Pt)
!
            if((Qred.ge.Qred_crit).and.(iflag.eq.3)) then
!
               Tt=Ts*TtzTs_crit
!
            endif
            exit
         else if((i.gt.40)) then
            Tt=0.99*Ts*TtzTs_crit
c$$$            Tt=1.2*Ts
c$$$            write(*,*) 'Break'
c$$$            write(*,*) 'f',f
c$$$            write(*,*) 'Ts',Ts
c$$$            write(*,*) 'Tt',Tt
c$$$            write(*,*) ''
            exit
         endif
         Tt_old=Tt
      enddo
!
C      write(*,*) 'end of ts_clac.f'
c      write(*,*) ''
      return
      end


subroutine getGamma(x, T, n, m, amk, vk, Rk, Qk, gamma1)
    implicit none

    integer, intent(in) :: n, m
    real(8), dimension(n), intent(in) :: x
    real(8), dimension(m), intent(in) :: Rk, Qk
    integer, dimension(n,m), intent(in) :: vk
    real(8), dimension(m,m), intent(in) ::amk
    real(8), intent(in) :: T
    real(8), dimension(n), intent(out) :: gamma1
    integer :: ii, kk
    real(8) :: sum_rx, sum_qx

    real(8) :: r(n), q(n), e(m,n), beta(n,m), theta(m), s(m),L(n),J(n),ln_gamma_C(n), ln_gamma_R(n), tau(m,m)

    tau = exp(-amk/T)

    do ii=1,n
        r(ii) = sum(vk(ii,:)*Rk(:))
        q(ii) = sum(vk(ii,:)*Qk(:))
    enddo

    sum_rx = sum(x*r)
    sum_qx = sum(x*q)

    ! r, q
    do ii=1,n
        e(:, ii) = vk(ii,:)*Qk(:)/q(ii)
    enddo

    ! beta
    do ii=1, n
        do kk=1, m
            beta(ii,kk) = sum(e(:,ii)*tau(:,kk))
        end do
    end do

    do kk=1,m
        theta(kk) = sum(x*q*e(kk,:))
    end do
    theta = theta/sum_qx

    do kk=1,m
        s(kk) = sum(theta*tau(:,kk))
    end do

    J = r/sum_rx
    L = q/sum_qx
    ln_gamma_C = 1.0_8 - J + log(J) - 5.0_8*q*(1.-J/L+log(J/L))

    do ii=1,n
        ln_gamma_R(ii) = q(ii)*(1.0_8 - sum(theta*beta(ii,:)/s - e(:,ii)*log(beta(ii,:)/s)))
    end do

    gamma1 = exp(ln_gamma_C + ln_gamma_R)

end subroutine

subroutine getGammaTrange(x, T, l, n, m, amk, vk, Rk, Qk, gammas)
    implicit none
    integer, intent(in) :: n, m,l
    real(8), dimension(n), intent(in) :: x
    real(8), dimension(m), intent(in) :: Rk, Qk
    integer, dimension(n,m), intent(in) :: vk
    real(8), dimension(m,m), intent(in) ::amk
    real(8), intent(in) :: T(l)
    real(8), dimension(l,n), intent(out) :: gammas
    integer :: ii
    do ii=1, l
        call getGamma(x,T(ii),n,m,amk,vk,Rk,Qk, gammas(ii,:))
    end do
end subroutine


program MaxSubSeq
  implicit none

  integer, parameter :: an = 11
  integer, dimension(an) :: a = (/ -1, -2, 3, 5, 6, -2, -1, 4, -4, 2, -1 /)

  integer, dimension(an,an) :: mix
  integer :: i, j
  integer, dimension(2) :: m

  forall(i=1:an,j=1:an) mix(i,j) = sum(a(i:j))
  m = maxloc(mix)
  ! a(m(1):m(2)) is the wanted subsequence
  print *, a(m(1):m(2))

end program MaxSubSeq


! FFLAGS="-fopenmp -fPIC -Ofast -ffree-line-length-none" f2py-2.7 -c -m TS_mcm_code_full TS_mcm_code_full.f90 wigner3j_sub.f -lgomp
! scinet: FFLAGS="-openmp -Ofast -fPIC -xhost" f2py --fcompiler=intelem --noopt -c -m TS_mcm_code_full TS_mcm_code_full.f90 wigner3j_sub.f -liomp5

subroutine calc_mcm(cl,cl_cross,cl_pol,wl, mcm, mcm_p, mcm_pp, mcm_mm)
    implicit none
    real(8), intent(in)    :: cl(:),cl_cross(:),cl_pol(:),wl(:)
    real(8), intent(inout) :: mcm(:,:),mcm_p(:,:),mcm_pp(:,:),mcm_mm(:,:)
    real(8), parameter     :: pi = 3.14159265358979323846264d0
    integer :: l1, l2, l3, info, nlmax, lmin, lmax, i
    real(8) :: l1f(2), fac
    real(8) :: thrcof0(2*size(mcm,1)),thrcof1(2*size(mcm,1))
    nlmax = size(mcm,1)-1

    ! l2,l3 are running over 2,lmax, note that it's tempting to make them run over 0,lmax but the wigner3j associated with polarisation
    ! crash for l2,l3 <0 ( |l2-m2| & |l3-m3| has to be greater or equal to zero)
    ! mcm(l2=2,l3=2)=mcm(1,1)
    ! l1 run in all the non zero wigner 3j it can start at 0 so cl(l=n)=cl(n+1) so cl(l=0)=cl(1)

    !$omp parallel do private(l3,l2,l1,fac,info,l1f,thrcof0,thrcof1,lmin,lmax,i) schedule(dynamic)
    do l1 = 2, nlmax
        fac=(2*l1+1)/(4*pi)*wl(l1+1)
        do l2 = 2, nlmax

            call drc3jj(dble(l1),dble(l2),0d0,0d0,l1f(1),l1f(2),thrcof0, size(thrcof0),info)
            call drc3jj(dble(l1),dble(l2),-2d0,2d0,l1f(1),l1f(2),thrcof1, size(thrcof1),info)

            lmin=INT(l1f(1))
            lmax=MIN(nlmax,INT(l1f(2)))

            do l3=lmin,lmax
                i   = l3-lmin+1
                mcm(l1-1,l2-1) =mcm(l1-1,l2-1)+ fac*(cl(l3+1)*thrcof0(i)**2d0)
                mcm_p(l1-1,l2-1) =mcm_p(l1-1,l2-1)+ fac*(cl_cross(l3+1)*thrcof0(i)*thrcof1(i))
                mcm_pp(l1-1,l2-1) =mcm_pp(l1-1,l2-1)+ fac*(cl_pol(l3+1)*thrcof1(i)**2*(1+(-1)**(l1+l2+l3))/2)
                mcm_mm(l1-1,l2-1) =mcm_mm(l1-1,l2-1)+ fac*(cl_pol(l3+1)*thrcof1(i)**2*(1-(-1)**(l1+l2+l3))/2)

            end do
        end do
    end do

end subroutine

subroutine bin_mcm(mcm, binLo,binHi, binsize, mbb)
    ! Bin the given mode coupling matrix mcm(0:lmax,0:lmax) into
    ! mbb(nbin,nbin) using bins of the given binsize
    implicit none
    real(8), intent(in)    :: mcm(:,:)
    integer, intent(in)    :: binLo(:),binHi(:),binsize(:)
    real(8), intent(inout) :: mbb(:,:)
    integer :: b1, b2, l1, l2, lmax
    lmax = size(mcm,1)-1
    mbb  = 0

    do b2=1,size(mbb,1)
        do b1=1,size(mbb,1)
            do l2=binLo(b2),binHi(b2)
                do l1=binLo(b1),binHi(b1)
                    mbb(b1,b2)=mbb(b1,b2) + mcm(l1-1,l2-1)!*l2*(l2+1d0)/(l1*(l1+1d0)) !*mcm(l2-1,l3-1)
                end do
            end do
            mbb(b1,b2) = mbb(b1,b2) / binsize(b2)

        end do
    end do
end subroutine

subroutine binning_matrix(mcm, binLo,binHi, binsize, bbl)
    implicit none
    real(8), intent(in)    :: mcm(:,:)
    integer(8), intent(in)    :: binLo(:),binHi(:),binsize(:)
    real(8), intent(inout) :: bbl(:,:)
    integer(8) :: b2, l1, l2,lmax

    lmax = size(mcm,1)-1
    ! mcm is transposed
    ! compute \sum_{l'} M_l'l
    do l1=2,lmax
        do b2=1,size(binLo)
            do l2=binLo(b2),binHi(b2)
                bbl(l1-1,b2)=bbl(l1-1,b2)+mcm(l1-1,l2-1)
            end do
            bbl(l1-1,b2)=bbl(l1-1,b2)/(binsize(b2)*1d0)
        end do
    end do
end subroutine


      subroutine sqrt_array(vect, vect_len, res)

        implicit none

        integer, intent(in)     :: vect_len
        real(kind=8), intent(in)        :: vect(vect_len)
        real(kind=8), intent(out)       :: res(vect_len)

        integer ::  i

        do i=1,vect_len
            res(i) = sqrt(vect(i))
        enddo

      end subroutine

      subroutine say_hello()

        write(*,*), "Hello from Fortran!"

      end subroutine


      PROGRAM TASSIG
      PARAMETER (PI=3.14159265)
      TEST = 2.0* PI
      WRITE(*,*) TEST
      END


program ch0513
    ! Binary Representation of Different Integer Kind
    ! Type Numbers
    use iso_fortran_env
    implicit none

    integer :: i, j
    integer(int8) :: i1
    integer(int16) :: i2
    integer(int32) :: i3
    character(32) :: i_in_bits = ' '

    print *, ' type in an integer '
    read *, i
    i1 = int(i,int8)
    i2 = int(i,int16)
    i3 = int(i,int32)

    do j = 0, 7
        if (btest(i1,j)) then
            i_in_bits(8-j:8-j) = '1'
        else
            i_in_bits(8-j:8-j) = '0'
        end if
    end do
    print *, '         1         2         3'
    print *, '12345678901234567890123456789012'
    print *, i1
    print *, i_in_bits

    do j = 0, 15
        if (btest(i2,j)) then
            i_in_bits(16-j:16-j) = '1'
        else
            i_in_bits(16-j:16-j) = '0'
        end if
    end do
    print *, i2
    print *, i_in_bits

    do j = 0, 31
        if (btest(i3, j)) then
            i_in_bits(32-j:32-j) = '1'
        else
            i_in_bits(32-j:32-j) = '0'
        end if
    end do
    print *, i3
    print *, i_in_bits
end program


program main5
    use Util
    use Func
    use Matrix
    use Calc
    use Plotlib
    implicit none

    double precision :: XMIN, XMAX, YMIN, YMAX

!   Command-line Args
    integer :: argc

!    ENABLE_DEBUG = .TRUE.

!   Random seed definition
    call init_random_seed()

!   Get Command-Line Args
    argc = iargc()

    if (argc == 0) then
        goto 100
    else
        goto 11
    end if

!   ====== Success ===================================
10  call info(':: Sucesso ::')
    goto 1
!   ====== Errors ====================================
11  call error('Este programa não aceita parâmetross.')
    goto 1
!   ====== Finish ====================================
1   stop
!   ==================================================

100 goto 200

200 call Q2
    goto 300

300 call Q3
    goto 400

400 call Q4
    goto 500

500 call Q5
    goto 600

600 call Q6
    goto 700

700 call Q7
    goto 800

800 call warn(ENDL//":: Complmento ::"//ENDL)
    call QE1; call QE2; call QE3;
    goto 10

!   ===============================

    contains

    subroutine Q2
        implicit none
        integer :: n = 10
        double precision :: a, b, s

        call info("2)"//ENDL//F6_NAME)
        a = 0.0D0
        b = 1.0D0
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")
        call info(":: Integração Polinomial ::")
        s = num_int(f6, a, b, n, kind="polynomial")
        call blue("I1 = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Quadratura de Gauss-Legendre ::")
        s = num_int(f6, a, b, n, kind="gauss-legendre")
        call blue("I1 = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Método de Romberg ::")
        s = num_int(f6, a, b, n, kind="romberg")
        call blue("I1 = ∫f(x) dx ≈ "//DSTR(s))

        a = 0.0D0
        b = 5.0D0
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")
        call info(":: Integração Polinomial ::")
        s = num_int(f6, a, b, n, kind="polynomial")
        call blue("I2 = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Quadratura de Gauss-Legendre ::")
        s = num_int(f6, a, b, n, kind="gauss-legendre")
        call blue("I2 = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Método de Romberg ::")
        s = num_int(f6, a, b, n, kind="romberg")
        call blue("I2 = ∫f(x) dx ≈ "//DSTR(s))

    end subroutine

    subroutine Q3
        implicit none
        integer :: n
        double precision :: a, b, r
        double precision, dimension(INT_N) :: x
        double precision, dimension(4, INT_N) :: y

        type(StringArray), dimension(:), allocatable :: legend, with

        allocate(legend(4), with(4))

        legend(1)%str = 'Polinomial'
        legend(2)%str = 'Gauss-Legendre'
        legend(3)%str = 'Romberg'
        legend(4)%str = 'Adaptativo (Gauss)'

        with(1)%str = 'linespoints'
        with(2)%str = 'linespoints'
        with(3)%str = 'linespoints'
        with(4)%str = 'lines'

        a = 0.00D0
        b = 10.0D0

        call info(ENDL//"3)"//ENDL//F7_NAME)

        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")

        INT_N = 128

        XMIN = 1.0D0
        XMAX = INT_N
        YMIN = -100.0D0
        YMAX = 300.0D0

        x = (/ (n, n=1, INT_N) /)

        call begin_plot(fname='L5-Q3')

        call subplots(2, 1)

        call info(ENDL//"m0 ~ "//F7a_NAME//ENDL)

        r = adapt_int(f7a, a, b, INT_N, tol=1.0D-8, kind="gauss-legendre")

        call info(":: Valor de referência (Integração Adaptativa) tol = 1E-8 ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(r))

        do n = 1, INT_N
            y(:, n) = (/ &
                num_int(f7a, a, b, n, kind="polynomial"), &
!
                num_int(f7a, a, b, n, kind="gauss-legendre"), &
!
                num_int(f7a, a, b, n, kind="romberg"), &
!
                r &
            /)
        end do

        call info(":: Integração Polinomial ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(1, 10)))
        call info(":: Quadratura de Gauss-Legendre ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(2, 10)))
        call info(":: Método de Romberg ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(3, 10)))

        do n = 1, 4
            call subplot(1, 1, x, y(n, :), INT_N)
        end do

        call subplot_config(1, 1, title='m0 = ∫Sσ(ω) dω ≈ '//DSTR(r), xlabel='n', ylabel='m0', grid=.TRUE., &
            legend=legend, with=with, xmin=XMIN, xmax=XMAX, ymin=YMIN, ymax=YMAX)

        call info(ENDL//"m2 ~ "//F7b_NAME//ENDL)

        r = adapt_int(f7b, a, b, INT_N, tol=1.0D-8, kind="gauss-legendre")

        call info(":: Valor de referência (Integração Adaptativa) tol = 1E-8 ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(r))

        do n = 1, INT_N
            y(:, n) = (/ &
                num_int(f7b, a, b, n, kind="polynomial"), &
!
                num_int(f7b, a, b, n, kind="gauss-legendre"), &
!
                num_int(f7b, a, b, n, kind="romberg"), &
!
                r &
            /)
        end do

        call info(":: Integração Polinomial ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(1, 10)))
        call info(":: Quadratura de Gauss-Legendre ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(2, 10)))
        call info(":: Método de Romberg ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(3, 10)))

        do n = 1, 4
            call subplot(2, 1, x, y(n, :), INT_N)
        end do

        call subplot_config(2, 1, title='m2 = ∫ω² Sσ(ω) dω ≈ '//DSTR(r), xlabel='n', ylabel='m2', grid=.TRUE., &
            legend=legend, with=with, xmin=XMIN, xmax=XMAX, ymin=YMIN, ymax=YMAX)

        call render_plot(clean=.TRUE.)
    end subroutine

    subroutine Q4
        implicit none
        integer :: n
        double precision :: a, b, r
        double precision, dimension(INT_N) :: x
        double precision, dimension(4, INT_N) :: y

        type(StringArray), dimension(:), allocatable :: legend, with

        allocate(legend(4), with(4))

        legend(1)%str = 'Polinomial'
        legend(2)%str = 'Gauss-Legendre'
        legend(3)%str = 'Romberg'
        legend(4)%str = 'Adaptativo (Gauss)'

        with(1)%str = 'linespoints'
        with(2)%str = 'linespoints'
        with(3)%str = 'linespoints'
        with(4)%str = 'lines'

        a = 0.00D0
        b = 10.0D0

        call info(ENDL//"4)"//ENDL//F8_NAME)

        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")

        INT_N = 128

        XMIN = 1.0D0
        XMAX = INT_N
        YMIN = -10.0D0
        YMAX = 100.0D0

        x = (/ (n, n=1, INT_N) /)

        call begin_plot(fname='L5-Q4')

        call subplots(2, 1)

        call info(ENDL//"m0 ~ "//F8a_NAME//ENDL)

        r = adapt_int(f8a, a, b, INT_N, tol=1.0D-8, kind="gauss-legendre")

        call info(":: Valor de referência (Integração Adaptativa) tol = 1E-8 ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(r))

        do n = 1, INT_N
            y(:, n) = (/ &
                num_int(f8a, a, b, n, kind="polynomial"), &
!
                num_int(f8a, a, b, n, kind="gauss-legendre"), &
!
                num_int(f8a, a, b, n, kind="romberg"), &
!
                r &
            /)
        end do

        call info(":: Integração Polinomial ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(1, 10)))
        call info(":: Quadratura de Gauss-Legendre ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(2, 10)))
        call info(":: Método de Romberg ::")
        call blue("m0 = ∫Sσ(ω) dω ≈ "//DSTR(y(3, 10)))

        do n = 1, 4
            call subplot(1, 1, x, y(n, :), INT_N)
        end do

        call subplot_config(1, 1, title='m0 = ∫Sσ(ω) dω ≈ '//DSTR(r), xlabel='n', ylabel='m0', grid=.TRUE., &
            legend=legend, with=with, xmin=XMIN, xmax=XMAX, ymin=YMIN, ymax=YMAX)

        call info(ENDL//"m2 ~ "//F8b_NAME//ENDL)

        r = adapt_int(f8b, a, b, INT_N, tol=1.0D-8, kind="gauss-legendre")

        call info(":: Valor de referência (Integração Adaptativa) tol = 1E-8 ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(r))

        do n = 1, INT_N
            y(:, n) = (/ &
                num_int(f8b, a, b, n, kind="polynomial"), &
!
                num_int(f8b, a, b, n, kind="gauss-legendre"), &
!
                num_int(f8b, a, b, n, kind="romberg"), &
!
                r &
            /)
        end do

        call info(":: Integração Polinomial ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(1, 10)))
        call info(":: Quadratura de Gauss-Legendre ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(2, 10)))
        call info(":: Método de Romberg ::")
        call blue("m2 = ∫Sσ(ω) dω ≈ "//DSTR(y(3, 10)))

        do n = 1, 4
            call subplot(2, 1, x, y(n, :), INT_N)
        end do

        call subplot_config(2, 1, title='m2 = ∫ω² Sσ(ω) dω ≈ '//DSTR(r), xlabel='n', ylabel='m2', grid=.TRUE., &
            legend=legend, with=with, xmin=XMIN, xmax=XMAX, ymin=YMIN, ymax=YMAX)

        call render_plot(clean=.TRUE.)
    end subroutine

    subroutine Q5
        implicit none
        integer :: n
        double precision :: a, b, s

        call info(ENDL//"5) "//F9_NAME)
        a = 0.0D0
        b = 4.0D0
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")

        n = 4
        call info(":: Integração Polinomial ::")
        call blue('n = '//STR(n))
        s = num_int(f9, a, b, n, kind="polynomial")
        call blue("A = ∫f(x) dx ≈ "//DSTR(s))

        n = 2
        call info(":: Quadratura de Gauss-Legendre ::")
        call blue('n = '//STR(n))
        s = num_int(f9, a, b, n, kind="gauss-legendre")
        call blue("A = ∫f(x) dx ≈ "//DSTR(s))
    end subroutine

    subroutine Q6
        implicit none
        integer :: n
        double precision :: a, b, s

        n = 10

        call blue('n = '//STR(n))

        call info(ENDL//"6) "//F10_NAME)
        a = 0.0D0
        b = 3.0D0
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")
        call info(":: Integração Polinomial ::")
        s = num_int(f10, a, b, n, kind="polynomial")
        call blue("A = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Quadratura de Gauss-Legendre ::")
        s = num_int(f10, a, b, n, kind="gauss-legendre")
        call blue("A = ∫f(x) dx ≈ "//DSTR(s))
        call info(":: Método de Romberg ::")
        s = num_int(f10, a, b, n, kind="romberg")
        call blue("A = ∫f(x) dx ≈ "//DSTR(s))
    end subroutine

    subroutine Q7
        implicit none
        integer :: n
        double precision :: a, b, r, s

        call info(ENDL//"7)")

        n = 10

        call blue('n = '//STR(n))

        call info("A1 ~ "//F11_NAME)
        a = DNINF
        b = 1.0D0
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")
        call info(":: Quadratura de Gauss-Hermite e de Gauss-Legendre ::")
        r = num_int(f11a, a, -a, n, kind="gauss-hermite")
        s = num_int(f11b, -b, b, n, kind="gauss-legendre")
        call blue("A1 = ∫f(x) dx ≈ "//DSTR(r+s))

        call info("A2 ~ "//F12_NAME)
        a = DNINF
        b = DINF
        call info("[a, b] = ["//DSTR(a)//", "//DSTR(b)//"]")
        call info(":: Quadratura de Gauss-Hermite ::")
        s = num_int(f12, a, b, n, kind="gauss-hermite")
        call blue("A2 = ∫f(x) dx ≈ "//DSTR(s))
    end subroutine

    subroutine QE1
        implicit none
        double precision :: x, y, dy

        x = 3.0D0

        call info(ENDL//'1)')

        call info(FL5_QE1_NAME)
        call info(DFL5_QE1_NAME)

        call info(':: Derivada Analítica ::')
        dy = DFL5_QE1(x)
        call blue("f'("//DSTR(x)//") = "//DSTR(dy))

        call info(":: Diferenças Finitas ::"//ENDL)

        call info(':: Diferença Central (Δx = 1E-2)::')
        y = d(FL5_QE1, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2)::')
        y = d(FL5_QE1, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2)::')
        y = d(FL5_QE1, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(ENDL//":: Extrapolação de Richard ::")

        call info(':: Diferença Central (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Diferença Central (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, p=2.0D0, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, p=2.0D0, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE1, x, dx=1.0D-2, p=2.0D0, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

    end subroutine

    subroutine QE2
        implicit none
        double precision :: x, y, dy

        x = 2.0D0

        call info(ENDL//'2)')

        call info(FL5_QE2_NAME)
        call info(DFL5_QE2_NAME)

        call info(':: Derivada Analítica ::')
        dy = DFL5_QE2(x)
        call blue("f'("//DSTR(x)//") = "//DSTR(dy))

        call info(":: Diferenças Finitas ::"//ENDL)

        call info(':: Diferença Central (Δx = 1E-2)::')
        y = d(FL5_QE2, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2)::')
        y = d(FL5_QE2, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2)::')
        y = d(FL5_QE2, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(ENDL//":: Extrapolação de Richard ::")

        call info(':: Diferença Central (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Diferença Central (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, p=2.0D0, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, p=2.0D0, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE2, x, dx=1.0D-2, p=2.0D0, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))
    end subroutine

    subroutine QE3
        implicit none
        double precision :: x, y, dy

        x = 6.0D0

        call info(ENDL//'3)')

        call info(FL5_QE3_NAME)
        call info(DFL5_QE3_NAME)

        call info(':: Derivada Analítica ::')
        dy = DFL5_QE3(x)
        call blue("f'("//DSTR(x)//") = "//DSTR(dy))

        call info(":: Diferenças Finitas ::"//ENDL)

        call info(':: Diferença Central (Δx = 1E-2)::')
        y = d(FL5_QE3, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2)::')
        y = d(FL5_QE3, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2)::')
        y = d(FL5_QE3, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(ENDL//":: Extrapolação de Richard ::")

        call info(':: Diferença Central (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Diferença Central (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, p=2.0D0, kind='central')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo à frente (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, p=2.0D0, kind='forward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 1)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))

        call info(':: Passo atrás (Δx = 1E-2, p = 2)::')
        y = richard(FL5_QE3, x, dx=1.0D-2, p=2.0D0, kind='backward')
        call blue("f'("//DSTR(x)//") ≈ "//DSTR(dy))
        call blue("|δy| = "//DSTR(DABS(y - dy)))
    end subroutine
end program main5


program testNormSinglePerformance
   use frand123
   use omp_lib
   use, intrinsic :: iso_c_binding, only: c_float, c_int64_t
   implicit none

   type( frand123State_t ) :: state
   integer( kind = c_int64_t ), dimension( 2 ) :: seed
   integer, parameter :: ctr_kind = selected_int_kind( 14 )
   integer( kind = ctr_kind ), parameter :: rounds = 1000 * 1000 * 100
   integer( kind = ctr_kind ) :: i
   real( kind = c_float ), parameter :: mu = 0.d0
   real( kind = c_float ), parameter :: sigma = 1.d0
   real( kind = c_float ), dimension( 2 ) :: buffer
   real( kind = c_float ), dimension( 2 ) :: resArr
   real( kind = c_float ) :: res
   double precision :: startTime, stopTime

   ! serial
   startTime = omp_get_wtime()
   ! initialize state
   seed = (/ 0, 0 /)
   call frand123Init( state, 0, 0, seed)
   ! run for rounds
   resArr = 0.d0
   do i = 1, rounds
      ! generate pair of random variates
      call frand123NormSingle( state, mu, sigma, buffer )
      ! summation
      resArr = resArr + buffer
   enddo
   ! sum up two entries of resArr
   res = sum( resArr ) / rounds
   stopTime = omp_get_wtime()
   write(*,'( "Serial version: result: ", E14.7, ", runtime: ", E11.4 )' ) &
      res, stopTime - startTime

   ! parallel
   startTime = omp_get_wtime();
   !$OMP parallel default( none ) private( buffer, state ) shared( seed, resArr )
   call frand123Init( state, 0, omp_get_thread_num(), seed )
   resArr = 0.d0
   !$OMP do reduction( +: resArr )
   do i = 1, rounds
      ! generate pair of random variates
      call frand123NormSingle( state, mu, sigma, buffer )
      ! summation
      resArr = resArr + buffer
   enddo
   !$OMP end do
   !$OMP end parallel
   ! sum up two entries of resArr
   res = sum( resArr ) / rounds
   stopTime = omp_get_wtime()
   write(*,'( "Parallel version: result: ", E14.7, ", runtime: ", E11.4 )' ) &
      res, stopTime - startTime
end program