      SUBROUTINE DRFT1 (A, MODE, M, MS, S)
c>> 1997-03-31 DFFT1 Krogh  Increased KEDIM, more sine table checks.
c>> 1996-01-23 DRFT1 Krogh  Changes to simplify conversion to C.
C>> 1994-11-11 DRFT1 Krogh  Declared all vars.
c>> 1994-10-20 DRFT1 Krogh  Changes to use M77CON
c>> 1989-05-07 DRFT1 FTK & CLL
c>> 1989-04-21 FTK & CLL
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c
c     This subroutine computes Fourier transforms of real data using
c     the Cooley-Tukey fast Fourier transform.
c
c     Variables in the calling sequence have the following types
      DOUBLE PRECISION A(*), S(*)
      INTEGER          M, MS
      CHARACTER        MODE
c
c     Programmed by Fred T. Krogh at the Jet Propulsion Laboratory,
c     Pasadena, Calif.   August 1, 1969.
c     Revised for portability by Krogh -- January 22, 1988
c
c     In describing the usage the following notation is used
c     N = 2 ** M
c     W = EXP(2*PI*I/N), where I = SQRT(-1) and PI = 3.14159...
c
c     The usage is as follows
c
c A() is an array of function values if one is doing Fourier analysis,
c  and is an array of Fourier coefficients if one is doing Fourier
c  synthesis.  In our description here we assume that A is a real
c  array with dimension A(N) when A contains the real data, X, and
c  that A is a complex array with dimension A(N/2) when A contains
c  complex Fourier coefficients, C.  (C(k) for k > N/2 need not be
c  saved since for 0 < k < N, C(N-k) = conjugate of C(k).  It is
c  assumed that the imaginary part of a complex number is stored
c  in the cell immediately following its real part, except that
c  A(1) = C(0), and A(2) = C(N/2).  This is possible since these
c  values of C are real and by doing this both X and C require the
c  same storage in A. Of course the storage required for A can be
c  reserved by the user in any way that works.
c
c MODE  Selects Synthesis or Analysis.
c  If MODE = 'A' or 'a', do Fourier analysis, which amounts to setting
c  C(k) = sum for j=0 to N-1 of X(j)*T(M,j,k), for k = 0, N/2
c  with  T(M,j,k) = (1/N) * W ** (-j*k).
c  If MODE = 'S' or 's', do Fourier synthesis, which amounts to setting
c  X(j) = sum for k=0 to N-1 of C(k)*T(M,j,k), for j = 0, N - 1
c  with  T(M,j,k) = W ** (j*k)
c  (Recall that C(N-k) is the conjugate of C(k).)
c
c M is used to indicate N = 2**M, the number of real points.  The
c  number of points must satisfy 1 .le. N .le. 2**21.
c  M = 0 gives an immediate return.
c
c MS gives the state of the sine table.  If MS > 0, there are NT =
c    2 ** (MS-2) good entries in the sine table.  On the initial call,
c    MS must be set to 0, and when the return is made, it will be set
c    to M, which is the value of MS required for computing a
c    transform of size N.  If MS = -1, the sine table will be computed
c    as for the case MS = 0, and then a return to the user will be made
c    with MS set as before, but no transform will be computed.  This
c    option is useful if the user would like access to the sine table
c    before computing the FFT.
c    On detected errors the error message subrs are called and
c    execution stops.  If the user overrides the stop to cause
c    continuation, then this subr will return with MS = -2.
c
c S() is a vector, S(j) = sin(pi*j/2*NT)), j = 1, 2, ..., NT-1, where
c  NT is defined in the description of MS above.  S is computed by the
c  subroutine if M .gt. MS.  (If S is altered, set MS=0 so that S
c  is recomputed.)
c
c     ------------------------------------------------------------------
c                Notes on COMMON, PARAMETER's, and local variables
c
c     MMAX is the largest value allowed for M
c     The dimension of KE must be at least as large as MMAX-1.
c     The named common CDFFTC is used for communication between this
c     subroutine and the subroutine DFFT which computes a one
c     dimensional complex Fourier transform and computes the sine table.
c     The use of the variables in CDFFTC is contained in the listing
c     of DFFT.
c
c     ANAL = .TRUE. when doing Fourier analysis, and .false. otherwise.
c
c     N1 = 2 ** M
c     ------------------------------------------------------------------
c--D replaces "?": ?RFT1, ?FFT, C?FFTC
c     Both versions use ERMSG, IERM1
c     and need ERFIN, IERV1
c     ------------------------------------------------------------------
      INTEGER    MMAX
      INTEGER I, II, II1, II2, IR, IR1, IR2
      INTEGER J, JDIF, JJ
      INTEGER K1, K1N, KN2
      INTEGER L
      INTEGER MA, MSI
      INTEGER N1, N1P, KEDIM

      DOUBLE PRECISION FN, HALF
      DOUBLE PRECISION SPI4, T, TI, TT, TTI, TWO, WI, WR

      LOGICAL ANAL
      CHARACTER MSG1*19

      PARAMETER (TWO = 2.D0)
      PARAMETER (HALF = .5D0)
      PARAMETER (SPI4 = .70710 67811 86547 52440 08443 62104 8490D0)
      EQUIVALENCE (ILAST, N1)
c Common variables
      PARAMETER (KEDIM=30)
      LOGICAL NEEDST
      INTEGER MT, NT, MM, KS, ILAST, KE(KEDIM), KEE(KEDIM+1)
c Note that KEE(1) is equivalent to ILAST.
      EQUIVALENCE (KE(1), KEE(2))
      COMMON /CDFFTC/ NEEDST, MT, NT, MM, KS, ILAST, KE
      SAVE /CDFFTC/
      PARAMETER (MMAX = KEDIM+1)
      DATA MSG1 / 'Bad MODE.  MODE =  ' /

c     ------------------------------------------------------------------
c
      if( MODE .eq. 'A' .or. MODE .eq. 'a') then
         ANAL = .true.
      else if( MODE .eq. 'S' .or. MODE .eq. 's') then
         ANAL = .false.
      else
         MSG1(19:19) = MODE
         call ERMSG('DRFT1', 2, 2, MSG1, '.')
         MS = -2
         return
      end if
      MA = M
      IF (MA .GT. MMAX .or. MA .lt. 0) THEN
c                            Fatal error, default is to stop in IERM1
         CALL IERM1 ('DRFT1', 1, 2,
     *   'Require 0 .le. M .le. 31', 'M', M, '.')
         MS = -2
         RETURN
      END IF
      MSI = MS
      NEEDST = MA .GT. MSI
      if (.NOT. NEEDST) then
c  Check internal parameters to catch certain user errors.
         if (MT .lt. KEDIM) then
            if (MA .le. MT + 2) then
c              Skip sine table computation if all appears O.K.
               if (MT .le. 0) go to 10
               if (abs(S(NT/2) - SPI4) .le. 1.D-7) go to 10
            end if
         end if
         NEEDST = .true.
         call ERMSG('DRFT1', 3, 1,
     1      'Invalid sine table (re)computed', '.')
      end if
      MS = MA
      MT = MA - 2
      CALL DFFT (A, A, S)
c                   Return if user requested it.
      IF (MSI .EQ. -1) RETURN
c                   All setup for computation now
   10 IF (MA .NE. 0) THEN
         MM = MA - 1
         N1 = 2 ** MA
         N1P = N1 + 2
         KN2 = N1 / 2
         JDIF = (4 * NT) / N1
         KS = 2
         IF (ANAL) THEN
c                               Set flags for Fourier analysis
            IR = 2
            II = 1
            FN = HALF / DBLE(N1)
c           Doing Fourier analysis, so multiply by 2 ** M
            DO 20 I = 1, N1
               A(I) = A(I) * FN
   20       CONTINUE
         ELSE
c                              Set flags for Fourier synthesis
            IR = 1
            II = 2
            GO TO 50
         END IF

c                              Compute complex Fourier transform
   30    DO 40 L = 1, MM
            KEE(L+1) = KEE(L) / 2
   40    CONTINUE
         CALL DFFT (A(IR), A(II), S)
c                              End of computing complex transform
c
         IF (.NOT. ANAL) GO TO 70
c
c        Beginning of calculations relating coefficients of real data
c        with coefficients of associated complex data
c
c        Special case --  K1 = 0
   50    T = A(1) + A(2)
         TI = A(1) - A(2)
         IF (ANAL) THEN
            T = TWO * T
            TI = TWO * TI
         END IF
         A(1) = T
         A(2) = TI
         IF (MM .GT. 0) THEN
c                           Special kase -- K1 = N1 / 4
            A(KN2+1) = TWO * A(KN2+1)
            A(KN2+2) = -TWO * A(KN2+2)
            IF (MM .GT. 1) THEN
               J = 0
               DO 60 K1 = 3, KN2, 2
                  K1N = N1P - K1
                  IF (ANAL) THEN
                     IR1 = K1N
                     IR2 = K1
                  ELSE
                     IR1 = K1
                     IR2 = K1N
                  END IF
                  II2 = IR2 + 1
                  II1 = IR1 + 1
                  J = J + JDIF
                  WI = S(J)
                  JJ = NT - J
                  WR = S(JJ)
                  T = A(IR1) - A(IR2)
                  TI = A(II1) + A(II2)
                  TT = T * WI + TI * WR
                  TTI = T * WR - TI * WI
                  T = A(IR1) + A(IR2)
                  TI = A(II1) - A(II2)
                  A(IR1) = T - TT
                  A(IR2) = T + TT
                  A(II1) = TTI + TI
                  A(II2) = TTI - TI
   60          CONTINUE
            END IF
         END IF
         IF (.NOT. ANAL) GO TO 30
      END IF
   70 RETURN
c
      END


program test
implicit none

integer :: j, divisions
real :: ix, I, f
real :: step
divisions = 100000.
step = 1. / divisions
I = 0.
do j = 0, divisions
   !ix = (j + 0.5) * step
   ix = j * step
   I = I + f(ix) * step
   open(1, file = 'data1.dat',status = 'unknown')
   write (1,*) "ix =", ix, "delatI", f(ix) * step, I
end do
close (1)
print *, I
end program test

function f(x) result(expr)
real :: x , expr
expr = 4.0 / (1.0 + x ** 2)
end function f


    subroutine rk4(y,dydx,n,x,h,yout)
!   *********************************
    implicit none
    integer, parameter :: nmax=4000
    integer n,i
    double precision y(n),dydx(n),yout(n),yt(n),dyt(n),dym(n)
    double precision h,hh,h6,x,xh

    hh=h*0.5
    h6=h/6.
    xh=x+hh

    call derivs(x,y,n,dydx)

    do 11 i=1,n
        yt(i)=y(i)+hh*dydx(i)
   11 continue

    call derivs(xh,yt,n,dyt)

    do 12 i=1,n
        yt(i)=y(i)+hh*dyt(i)
   12 continue

    call derivs(xh,yt,n,dym)

    do 13 i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
   13 continue

    call derivs(x+h,yt,n,dyt)

    do 14 i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
   14 continue

    return
    end


********************************************************************************
C     Fortranification of AMIDOL's SIR-Gillespie.py
********************************************************************************

********************************************************************************
C     Input Variables:
C     S        Susceptible population
C     I        Infected population
C     R        Recovered population
C     gamma    Rate of recovery from an infection
C     rho      Basic reproduction Number
C
C     State Variables:
C     beta          Rate of infection
C     rateInfect    Current state dependent rate of infection
C     rateRecover   Current state dependent rate of recovery
C
C     Output Variables:
C     S        Susceptible population
C     I        Infected population
C     R        Recovered population
C     totalRates    Sum of total rates; taking advantage of Markovian identities
C                       to improve performance.
********************************************************************************
      subroutine model(S, I, R, gamma, rho,
     &                 totalRates)
      integer S, I, R

      double precision rateInfect, rateRecover, totalRates, gamma, rho
      double precision, parameter :: beta = rho * gamma !

      rateInfect = beta * S * I / (S + I + R)
      rateRecover = gamma * I
      totalRates = rateInfect + rateRecover

      ! Determine which event fired.  With probability rateInfect/totalRates
      ! the next event is infection.
      if (rand() < (rateInfect/totalRates)) then
          ! Delta for infection
          S = S - 1
          I = I + 1
      ! Determine the event fired.  With probability rateRecover/totalRates
      ! the next event is recovery.
      else
          ! Delta for recovery
          I = I - 1
          R = R + 1
      endif
      end subroutine model

********************************************************************************
C     Input Variables:
C     S        Susceptible population
C     I        Infected population
C     R        Recovered population
C     gamma    Rate of recovery from an infection
C     rho      Basic reproduction Number
C
C     State Variables:
C     Tmax     Maximum time for the simulation
C     t        Initial time for the simulation
C     dt       next inter-event time
C     n_S      current number of susceptible members
C     n_I      current number of infected members
C     n_R      current number of recovered members
C     totalRates    Sum of total rates; taking advantage of Markovian identities
C                       to improve performance.
C     totalRuns     Total number of trajectories to generate for the analysis
C
C     Output Variables:
C     MeanS    Measures of Mean for S
C     MeanI    Measures of Mean for I
C     MeanR    Measures of Mean for R
C     VarS     Measures of Variance for S
C     VarI     Measures of Variance for I
C     VarR     Measures of Variance for R
********************************************************************************
      subroutine solver(S, I, R, gamma, rho)
        integer S, I, R
        integer, parameter :: Tmax = 100, total_runs = 1000
        double precision gamma, rho
        double precision, parameter :: beta = rho * gamma !
        double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
        double precision, dimension(0:Tmax) :: VarS, VarI, VarR
        integer, dimension(0:Tmax) :: samples

        integer j, runs, runs1, sample_idx, samp, n_S, n_I, n_R
        double precision totalRates, dt, t

        do j = 0, Tmax    ! Initialize the mean and variance arrays
           MeanS(j) = 0
           MeanI(j) = 0.0
           MeanR(j) = 0.0

           VarS(j) = 0.0
           VarI(j) = 0.0
           VarR(j) = 0.0

           samples(j) = j
        end do

        do runs = 0, total_runs-1
           t = 0.0    ! Restart the event clock

           ! main Gillespie loop
           sample_idx = 0
           do while (t .le. Tmax .and. I .gt. 0)
              n_S = S
              n_I = I
              n_R = R

              call model(S, I, R, gamma, rho, totalRates)

              dt = -log(1.0-rand())/totalRates  ! next inter-event time
              t = t + dt          !  Advance the system clock

              ! Calculate all measures up to the current time t using
              ! Welford's one pass algorithm
              do while (sample_idx < Tmax .and. t > samples(sample_idx))
                 samp = samples(sample_idx)
                 runs1 = runs+1
                 MeanS(samp) = MeanS(samp)+(n_S-MeanS(samp))/(runs1)
                 VarS(samp) = VarS(samp) + runs/(runs1) *
     &                          (n_S-MeanS(samp))*(n_S-MeanS(samp))

                 MeanI(samp) = MeanI(samp)+(n_I-MeanI(samp))/(runs1)
                 VarI(samp) = VarI(samp) + runs/(runs1) *
     &                          (n_I-MeanI(samp))*(n_I-MeanI(samp))

                 MeanR(samp) = MeanR(samp) + (n_R - MeanR(samp))/(runs1)
                 VarR(samp) = VarR(samp) + runs/(runs1) *
     &                          (n_R-MeanR(samp))*(n_R-MeanR(samp))
                 sample_idx = sample_idx+1
              end do
           end do

           ! After all events have been processed, clean up by evaluating all remaining measures.
           do while (sample_idx < Tmax)
              samp = samples(sample_idx)
              runs1 = runs+1
              MeanS(samp) = MeanS(samp)+(n_S-MeanS(samp))/(runs1)
              VarS(samp) = VarS(samp) + runs/(runs1) *
     &                       (n_S-MeanS(samp))*(n_S-MeanS(samp))

              MeanI(samp) = MeanI(samp)+(n_I-MeanI(samp))/(runs1)
              VarI(samp) = VarI(samp) + runs/(runs1) *
     &                       (n_I-MeanI(samp))*(n_I-MeanI(samp))

              MeanR(samp) = MeanR(samp) + (n_R - MeanR(samp))/(runs1)
              VarR(samp) = VarR(samp) + runs/(runs1) *
     &                       (n_R-MeanR(samp))*(n_R-MeanR(samp))
              sample_idx = sample_idx + 1
           end do
        end do
      end subroutine solver

********************************************************************************
C     Model Variables:
C     S        Susceptible population
C     I        Infected population
C     R        Recovered population
C     gamma    Rate of recovery from an infection
C     rho      Basic reproduction Number
C
C     Solver Variables:
C     Tmax     Maximum time for the simulation
C     MeanS    Measures of Mean for S
C     MeanI    Measures of Mean for I
C     MeanR    Measures of Mean for R
C     VarS     Measures of Variance for S
C     VarI     Measures of Variance for I
C     VarR     Measures of Variance for R
********************************************************************************
      program main
!     Model inputs
      integer, parameter :: S = 500, I = 10, R = 0, Tmax = 100
      double precision, parameter :: gamma = 1.0/3.0, rho = 2.0

      call solver(S, I, R, gamma, rho)
      end program main


module beta_module

integer,parameter :: dp=kind(1.d0)
real, parameter :: Pi=3.14159265358979323846264338327950288419716939937510
real(dp) :: t_tmp,U_tmp

contains
function integrand(x) result(res)

real(dp),intent(in) :: x
real(dp) :: res
real(dp) :: num,den

num = bessel_j0(x)*bessel_j1(x)
den = x*(1.0_dp + exp(x*U_tmp/2.0_dp/t_tmp))

res = num/den

end function

function f(x) result(res)

real(dp),intent(in) :: x
real(dp) :: res
real(dp) :: a,b

integer,parameter :: limit=1000
integer,parameter :: lenw=limit*4
real(dp) :: abserr
real(dp),parameter :: epsabs=0.0_dp
real(dp),parameter :: epsrel=0.00001_dp
integer :: ier
integer :: iwork(limit)
integer,parameter :: inf=1
integer :: last
integer :: neval
real(dp) :: work(lenw)

! double, quadrature de Gauss pour integrer de 0 a inf. (inf = 1
! equivaut a infini
call dqagi(integrand,0.0_dp,inf,epsabs,epsrel,a,abserr,neval, &
           ier,limit,lenw,last,iwork,work)

b = -sin(Pi/x)*2.0_dp*t_tmp*x/Pi

res = b + 4.0_dp*t_tmp*a

end function

end module beta_module


! Objetivo: Interpolar e extrapolar a funcao

PROGRAM interpo_extrapo

   USE nrtype
   USE nrutil
   USE nr, ONLY: polint
   IMPLICIT none
   INTEGER :: xi, cont_pontos, lim_inicial = 1, lim_final = 4
   INTEGER, PARAMETER :: dados_pontos = 7, dados_grafico = 8
   INTEGER, PARAMETER :: intervalo_x = 11, num_pontos = 1000, lim_inicial_max=8
   REAL :: x_ponto, y_funcao_original, x_in_ex, y_grau3, y_grau10, dy
   REAL, PARAMETER :: incremento_x_ponto = 0.2
   REAL :: vie_x(intervalo_x) = 0., f(intervalo_x) = 0.
!vie_x significa valores igualmente espacados de x
   REAL, PARAMETER :: x_inicial = -1., x_final = 1.
   REAL, PARAMETER :: primeiro_x_interpo = -1.2, ultimo_x_interpo = 1.2
   REAL, PARAMETER :: incremento_x_interpo = (ultimo_x_interpo-&
                                       primeiro_x_interpo)/real(num_pontos)

!Abrir os arquivos para escrever os dados
   OPEN(dados_pontos, file="dados_pontos.dat")
   OPEN(dados_grafico,file="dados_grafico.dat")
!Calcular os valores igualmente espacados da funcao no intervalo  de -1 a 1
   x_ponto = x_inicial
   DO xi = 1, intervalo_x
      vie_x(xi) = x_ponto
      f(xi) = 0.5*(1.+tanh(6.*x_ponto))
      WRITE(dados_pontos, *) vie_x(xi), f(xi)
!Escrever cada par x e y correspondentes a funcao
      x_ponto = x_ponto + incremento_x_ponto
   END DO

!Iniciar a interpolacao e extrapolacao dos valores
   x_in_ex = primeiro_x_interpo
   DO cont_pontos = 1, num_pontos

!Determinar os intervalos para fazer a interpolacao e a extrapolacao
!com o polinomio de grau 3
      IF( x_in_ex > vie_x(lim_final-1) ) THEN
         lim_inicial = lim_inicial+1
         lim_final = lim_final+1
         IF( lim_final > intervalo_x ) THEN
            lim_inicial = lim_inicial_max
            lim_final = intervalo_x
         END IF
      END IF

!Interpolar e extrapolar com um polinomio de grau 3
      CALL polint(vie_x(lim_inicial:lim_final), f(lim_inicial:lim_final),&
                                                 x_in_ex, y_grau3, dy)
!Interpolar e extrapolar com um polinomio de grau 10
      CALL polint(vie_x, f, x_in_ex, y_grau10, dy)
!Calcular os valores da funcao original
      y_funcao_original = 0.5*(1.+tanh(6.*x_in_ex))
!Escrever os valores da funcao nos arquivos
      WRITE(dados_grafico, *) x_in_ex, y_grau10, y_grau3, y_funcao_original
      x_in_ex = x_in_ex + incremento_x_interpo
   END DO

   CLOSE(dados_pontos)
   CLOSE(dados_grafico)

END PROGRAM interpo_extrapo


program load_balancing
    use :: mpi
    implicit none
    integer :: size, rank, n, ierr, lbound, ubound, i
    character(len=1024) :: buffer

    call MPI_Init(ierr)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
    if (rank == 0) then
        if (command_argument_count() >= 1) then
            call get_command_argument(1, buffer)
            read (buffer, '(I10)') n
        else
            n = 1003
        end if
    end if
    call MPI_Bcast(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

    call compute_bounds(size, rank, n, lbound, ubound)
    do i = 0, size - 1
        if (rank == i) print '(I3, 2I10)', rank, lbound, ubound
        call MPI_Barrier(MPI_COMM_WORLD, ierr)
    end do

    call MPI_Finalize(ierr)

contains

    subroutine compute_bounds(size, rank, n, lbound, ubound)
        implicit none
        integer, intent(in) :: size, rank, n
        integer, intent(out) :: lbound, ubound
        integer :: chunk_size, rest
        chunk_size = n/size
        rest = mod(n, size)
        lbound = min(rank, size - rest)*chunk_size + &
                 max(0, rank - (size - rest))*(chunk_size + 1)
        ubound = lbound + chunk_size
        if (rank >= size - rest) ubound = ubound + 1
        lbound = lbound + 1
    end subroutine compute_bounds

end program load_balancing


      real function dotproduct(n,x,y)

      real x(n), y(n)
      real s
      integer i

      s=0.
      do  100 i =1,n
         s= s+x(i)*y(i)
 100  continue

      dotproduct =s
      end

      program demo1

      parameter (idim = 90)
      real  v1(idim), v2(idim), result

      do i = 1,idim
         v1(i) = float(i)
         v2(i) = 2.
      enddo

      result = dotproduct(idim,v1,v2)
      print *,"result =", result
      end


program tarefab
    implicit real*8 (a-h,o-z)

    ! arquivo de saida
    open(10, file='saida-b-10407962')

    ! extremos de integração
    a = 0d0
    b = 1d0

    ! valor exato da integral definida
    exato = fzao(b)-fzao(a)

    ! loop que calculo a aproximação para cada valor de n
    do j = 2, 12
        ! como no projeto n é multiplo de 2, julguei fazer dessa forma
        n = 2**j
        desvio_trapezio = abs(exato - trapezio(f, a, b, n))
        desvio_simpson = abs(exato - simpson(f, a, b, n))
        desvio_bode = abs(exato - bode(f, a, b, n))

        ! escreve os desvios no arquivo de saida
        write(10,*) (b-a)/n, desvio_trapezio, desvio_simpson, desvio_bode
    end do

    close(10)
    ! escreve na tela o valor exato
    write(*,'(A,5F0.11)') 'Valor exato: ', exato

contains

    ! função que desejamos integrar
    function f(x)
        parameter (pi = 4*datan(1d0))
        f = dexp(x/2)*dcos(pi*x)
        return
    end function f

    ! integral analitica
    function fzao(x)
        parameter (pi = 4*datan(1d0))
        fzao = (2*dexp(x/2)*(dcos(pi*x) + 2*pi*dsin(pi*x))) / (1 + 4*pi**2)
        return
    end function fzao

    ! método do trapezio
    function trapezio(f, a, b, n)
        h = (b-a)/n
        trapezio = 0d0

        do i = 1, n-1, 2
            x = a + i*h
            trapezio = trapezio + ( f(x -h) +2*f(x) +f(x +h) ) * h/2
        end do

        return
    end function trapezio

    ! método de simpson 1/3
    function simpson(f, a, b, n)
        h = (b-a)/n
        simpson = 0d0

        do i = 1, n-1, 2
            x = a + i*h
            simpson = simpson + ( f(x -h) +4*f(x) +f(x +h) ) * h/3
        end do

        return
    end function simpson

    ! método de bode
    function bode(f, a, b, n)
        h = (b-a)/n
        bode = 0d0

        do i = 0, n-4, 4
            x = a + i*h
            bode = bode + ( 7*f(x) +32*f(x +h) +12*f(x +2*h) +32*f(x +3*h) +7*f(x +4*h) ) * 2*h/45
        end do

        return
    end function bode

end program tarefab


! The goal of the trajectory analysis procedures herein is to estimate the error in each simulation.
! Assuming the data is uncorrelated, the mean, variance, standard deviation and error on the mean are given
! by simple expressions.
! Assuming the data is correlated, it is necessary to estimate the correlation and attempt to correct the error estimate

MODULE StatisticalFunctions

  ! #DES: Subprograms for statistical analysis of MD data sets

  IMPLICIT NONE
  REAL(8), PARAMETER :: ROOT2PI = 2.50662827463d0

CONTAINS

!*

  PURE REAL(8) FUNCTION mean(x,mask)

    ! #DES: Compute the mean of a 1D array of real(8) numbers
    !       including only those for whom mask(i) is true

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    LOGICAL, INTENT(IN), OPTIONAL :: mask(:)
    INTEGER :: n

    IF (PRESENT(mask)) THEN
      n = COUNT(mask)
    ELSE
      n = SIZE(x)
    ENDIF

    IF (n > 0) THEN
      IF (PRESENT(mask)) THEN
        mean = SUM(x,mask=mask) / n
      ELSE
        mean = SUM(x) / n
      ENDIF
    ELSE
      mean = 0.0d0
    ENDIF

  END FUNCTION mean

!*

  PURE REAL(8) FUNCTION variance(x,mask)

    ! #DES: Compute the variance of a 1D array of real(8) numbers, assuming the entire population is present

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    LOGICAL, INTENT(IN), OPTIONAL :: mask(:)
    INTEGER :: n
    REAL(8) :: difference(SIZE(x))

    IF (PRESENT(mask)) THEN
      n = COUNT(mask)
    ELSE
      n = SIZE(x)
    ENDIF

    IF (n > 0) THEN

      difference(:) = x(:) - mean(x)

      IF (PRESENT(mask)) THEN
        variance = SUM(difference(:)*difference(:),mask=mask) / n
      ELSE
        variance = SUM(difference(:)*difference(:)) / n
      ENDIF
    ELSE
      variance = 0.0d0
    ENDIF

  END FUNCTION variance

!*

  PURE REAL(8) FUNCTION varianceOfMean(x,mask)

    ! #DES: Calculate the variance of the mean assuming no correlation present in data set

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    LOGICAL, INTENT(IN),OPTIONAL :: mask(:)
    INTEGER :: n

    IF (PRESENT(mask)) THEN
      n = COUNT(mask)
    ELSE
      n = SIZE(x)
    ENDIF

    IF (n > 0) THEN
      IF (PRESENT(mask)) THEN
        varianceOfMean = variance(x,mask=mask) / n
      ELSE
        varianceOfMean = variance(x) / n
      ENDIF
    ELSE
      varianceOfMean = 0.0d0
    ENDIF

  END FUNCTION varianceOfMean

!*

  FUNCTION histogram(binEdges,input)

    ! #DES: Produce a histogram of the data 'input' using the binEdges provided

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: input(:), binEdges(:)
    INTEGER :: i, bin, nBins
    REAL(8) :: x(SIZE(binEdges)-1)
    INTEGER :: histogram(SIZE(binEdges)-1)

    nBins = SIZE(binEdges) - 1
    x(:) = binEdges(1:nBins) + ((binEdges(1:nBins) - binEdges(2:nBins+1) / 2.0d0))

    ! Count the populations
    histogram(:) = 0
    DO i = 1, SIZE(input)
      DO bin = 1, nBins
        IF ((input(i) >= binEdges(bin)) .AND. (input(i) < binEdges(bin+1))) THEN
          histogram(bin) = histogram(bin) + 1
          EXIT
        ELSE IF (input(i) == binEdges(SIZE(binEdges))) THEN
          histogram(nBins) = histogram(nBins) + 1
          EXIT
        ENDIF
      ENDDO
    ENDDO

  END FUNCTION histogram

!*

  FUNCTION gaussianDistribution(mean, var, input)

    ! #DES: generate values of the Gaussian distribution with 'mean' and 'var' at points in 'input'
    IMPLICIT NONE

    REAL(8), INTENT(IN) :: mean, var, input(:)
    REAL(8) :: gaussianDistribution(SIZE(input))
    REAL(8) :: coeff, var2, diff(SIZE(input))
    INTEGER :: i

    IF (var > 0) THEN

      coeff = SQRT(var) * ROOT2PI
      var2 = 2.0d0 * var

      diff(:) = input(:) - mean
      DO i = 1, SIZE(input)
        gaussianDistribution(i) = EXP(-1.0d0*((diff(i)*diff(i)) / var2))
      END DO
      gaussianDistribution(:) = gaussianDistribution(:) / coeff

    ELSE
      STOP "ERROR - gaussianDistribution - variance is -ve: "
    ENDIF

  END FUNCTION gaussianDistribution

!*

  FUNCTION runningMean(input,mask)

    ! #DES: Compute the running mean of a set of data for visualising equilibration of simulations

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: input(:)
    LOGICAL, INTENT(IN), OPTIONAL :: mask(:)
    REAL(8) :: runningMean(SIZE(input))
    INTEGER :: i

    IF (PRESENT(mask) .EQV. .FALSE.) THEN
      !each output point is the mean after that many timesteps
      DO i = 1, SIZE(input)
        runningMean(i) = mean(input(1:i))
      ENDDO
    ELSE
      DO i = 1, SIZE(input)
        runningMean(i) = mean(input(1:i),mask(1:i))
      ENDDO
    ENDIF

  END FUNCTION runningMean

!*

  ! Generate values of variance of <A> for all values of T
  SUBROUTINE EstimateC(data)

    ! #DES: Compute all autocorrelation functions of the input 'data' and use to compute estimates of var(<A>)

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: data(:)
    INTEGER :: cutoff, t, n
    REAL(8) :: var(0:SIZE(data(:))-2), sumTerm(1:SIZE(data(:))-2)
    REAL(8) :: c0, ct, num, den

    n = SIZE(data)

    !Compute the correlation functions and their sum
    c0 = c_t(0,data)

    !Summed term is over correlation functions with t = 1, N-1 (has no 0th entry)
    sumTerm(:) = 0.0d0
    sumTerm(1) = (1.0d0 - (1.0d0/n)) * c_t(1,data)

    DO t = 2, n-2
      ct = c_t(t,data)
      sumTerm(t) = sumTerm(t-1) + ((1.0d0 - (t/DBLE(n))) * ct)
    ENDDO

    var(0) = c0 / (n-1)
    WRITE(21,'(I10,1X,F20.10,I10,F20.10)') 0+1, SQRT(var(0))

    !Compute the variance of the mean as a function of the cutoff: T in {0,1,...,N-1}
    DO cutoff = 1, n-2

      !num / den must always be positive since sqrt is taken
      num = c0 + (2.0d0 * sumTerm(cutoff))
      den = n - 2*cutoff - 1 + ( DBLE(cutoff*(cutoff+1)) / n )
      var(cutoff) = num / den

      IF (var(cutoff) > 0.0d0) THEN
        WRITE(21,'(I10,1X,5F20.10)') cutoff+1, SQRT(var(cutoff))
      ENDIF

    ENDDO

    STOP

  END SUBROUTINE EstimateC

!*

  !Eq. 8 in Flyvbjerg & Petersen, J. Chem. Phys., 91, 461 (1989)
  REAL(8) FUNCTION c_t(t,data)

    ! #DES: Evaluate the t'th autocorrelation function of the data

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: t
    REAL(8), INTENT(IN) :: data(:)
    REAL(8) :: total, average
    INTEGER :: n, k

    n = SIZE(data)
    IF ((n - t) > 0) THEN

      average = mean(data(:))
      total = 0.0d0
      DO k = 1, n-t
        total = total + ((data(k) - average) * (data(k+t) - average))
      ENDDO
      c_t = total / DBLE(n-t)

    ELSE
      STOP "ERROR - c_t - Infinite correlation function"
    ENDIF

  END FUNCTION c_t

!*

  !Use the FP method to determine the standard deviation on the mean of correlated data
  !Can also return sigma(<A>) as function of num. of block transforms for visual inspection
  REAL(8) FUNCTION FlyvbjergPetersen(x)

    ! #DES: Use the Flyvjerg-Petersen method to determine the stdev on the mean of the data set as a function of T

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    REAL(8), ALLOCATABLE :: xPrime(:), copy(:)
    INTEGER :: nPrime, step
    REAL(8) :: T(SIZE(x)), sigma(SIZE(x)), error(SIZE(x))
    REAL(8) :: finalValue, c0prime
    LOGICAL :: converged
    !To store data per blocking transform need to know how many can be done.

    nPrime = SIZE(x)

    converged = .FALSE.
    finalValue = -1.0d0
    ALLOCATE(xPrime(SIZE(x)))
    xPrime(:) = x(:)

    step = 1
    DO WHILE (nPrime >= 2)

      c0prime = c0(xPrime)
      T(step) = 0.5d0 * ((2.0d0**(step-1)) - 1)
      sigma(step) = StDevMean(c0prime,nPrime)
      error(step) = StDevMeanError(c0prime,nPrime)

      !WRITE(*,*) T(step) + 1, sigma(step), error(step)

      IF (step > 1) THEN
        IF ((converged .EQV. .FALSE.) .AND. (ABS(sigma(step) - sigma(step-1)) < error(step-1))) THEN
          finalValue = sigma(step)
          converged = .TRUE.
        ENDIF
      ENDIF

      ALLOCATE(copy(SIZE(xPrime))); copy(:) = xPrime(:)
      DEALLOCATE(xPrime); ALLOCATE(xPrime(nPrime/2))
      xPrime = BlockTransform(copy(1:nPrime-MOD(nPrime,2))) !discard the last point if nPrime is odd
      DEALLOCATE(copy)
      nPrime = SIZE(xPrime)
      step = step + 1

    ENDDO

    DEALLOCATE(xPrime)

    FlyvbjergPetersen = finalValue

  END FUNCTION FlyvbjergPetersen

!*

  FUNCTION BlockTransform(x)

    ! #DES: Perform the blocking transform on the data (Eq. 20, 21)

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    REAL(8) :: BlockTransform(SIZE(x)/2) !rounds down
    INTEGER :: n, i

      n = SIZE(x)
      IF (MOD(n,2) /= 0) STOP "ERROR - BlockTransform"
      DO i = 1, n/2 !rounds down
        BlockTransform(i) = 0.5d0 * (x((2*i)-1)+x(2*i))
      ENDDO

  END FUNCTION BlockTransform

!*

  PURE REAL(8) FUNCTION c0(x)

    ! #DES: Compute the 0th autocorrelation function (the variance)

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: x(:)
    REAL(8) :: difference(SIZE(x))
    INTEGER :: n

    n = SIZE(x)
    IF (n > 0) THEN
      difference(:) = x(:) - mean(x)
      c0 = SUM(difference*difference) / n
    ELSE
      c0 = 0.0d0
    ENDIF

  END FUNCTION c0

!*

  !Compute the standard deviation of the mean from the FP quantities
  !Domain of function is (0,+inf)
  REAL(8) FUNCTION StDevMean(c_0,n)

    ! #DES: Compute the stdev of the mean from the FP quantities

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: c_0
    INTEGER, INTENT(IN) :: n

    IF (((n-1) > 0) .AND. (c_0 >= 0)) THEN
      StDevMean = SQRT(c_0 / (n-1))
    ELSE
      STOP "ERROR - StDevMean - negative variance"
    ENDIF

  END FUNCTION StDevMean

!*

  REAL(8) FUNCTION StDevMeanError(c_0,n)

    ! #DES: Compute error in the stdev of the mean from FP quantities

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: c_0
    INTEGER, INTENT(IN) :: n

    IF ((n-1) > 0) THEN
      StDevMeanError = StDevMean(c_0,n) * (1.0d0 / SQRT(2.0d0 * (n-1)))
    ELSE
      STOP "ERROR - StDevMeanError - sqrt of -ve number"
    ENDIF

  END FUNCTION StDevMeanError

END MODULE StatisticalFunctions


      FUNCTION FACTLN(N)

!PURPOSE: Compute ln(factorial) - adapted from Numerical Recipes

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      INTEGER*4     N                   !Order of factorial
      REAL*8        FACTLN              !ln(N!) returned

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*8        A(100)
      INTEGER*4     IA(100)

!FUNCTION DEFINITIONS:

      REAL*8        DGAMMLN

!DATA STATEMENTS:

      DATA          A/100*-1.0D0/,IA/100*0/

!CODE:

      IF ( N.LE.99 ) THEN
        IF ( IA(N+1).EQ.0 ) THEN
          IA(N+1) = 1
          A(N+1) = DGAMMLN(N+1.0)
        END IF
        FACTLN = A(N+1)
      ELSE
        FACTLN = DGAMMLN(N+1.0)
      END IF
      RETURN
      END


!
!     ------------------------------------------------------------------
!               L I N E Q N
!     ------------------------------------------------------------------
!
!        This routine is a modification of the one in "Computer Methods
!     for Mathematical Computation" by Forsythe, Malcolm, and Moler
!     (Prentice Hall, 1975)
!
      SUBROUTINE LINEQN(NDIM, N, A, B)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NDIM
      INTEGER , INTENT(IN) :: N
      REAL(DOUBLE) , INTENT(INOUT) :: A(NDIM,*)
      REAL(DOUBLE) , INTENT(INOUT) :: B(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NM1, K, KP1, M, I, J
      REAL(DOUBLE) :: T
!-----------------------------------------------
!
!     SOLVE A SYSTEM OF LINEAR EQUATIONS A*X = B
!
!     INPUT..
!
!        NDIM = DECLARED ROW DIMENSION OF THE ARRAY CONTAINING  A.
!        N = ORDER OF THE MATRIX
!        A =  COEFFICIENT MATRIX
!        B = CONSTANT VECTOR
!
!     OUTPUT..
!
!        B = SOLUTION VECTOR
!
      NM1 = N - 1
!
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
      DO K = 1, NM1
         KP1 = K + 1
!
!        FIND PIVOT
!
         M = K
         DO I = KP1, N
            IF (DABS(A(I,K)) <= DABS(A(M,K))) CYCLE
            M = I
         END DO
         T = A(M,K)
         A(M,K) = A(K,K)
         A(K,K) = T
!
!        SKIP STEP IF PIVOT IS ZERO
!
         IF (T == 0.0D0) CYCLE
!
!        COMPUTE MULTIPLIERS
!
         A(KP1:N,K) = -A(KP1:N,K)/T
!
!        INTERCHANGE AND ELIMINATE BY COLUMNS
!
         DO J = KP1, N
            T = A(M,J)
            A(M,J) = A(K,J)
            A(K,J) = T
            IF (T == 0.0D0) CYCLE
            A(KP1:N,J) = A(KP1:N,J) + A(KP1:N,K)*T
         END DO
         T = B(M)
         B(M) = B(K)
         B(K) = T
         IF (T == 0.0D0) CYCLE
         B(KP1:N) = B(KP1:N) + A(KP1:N,K)*T
      END DO
!
!     BACK SUBSTITUTION
!
      DO K = N, 2, -1
         IF (A(K,K) == 0.D0) THEN
            B(K) = 0.D0
         ELSE
            B(K) = B(K)/A(K,K)
         ENDIF
         T = -B(K)
         B(:K-1) = B(:K-1) + A(:K-1,K)*T
      END DO
      B(1) = B(1)/A(1,1)
      RETURN
      END SUBROUTINE LINEQN


*
*     ------------------------------------------------------------------
*               L I N E Q N
*     ------------------------------------------------------------------
*
*        This routine is a modification of the one in "Computer Methods
*     for Mathematical Computation" by Forsythe, Malcolm, and Moler
*     (Prentice Hall, 1975)
*
      SUBROUTINE LINEQN(NDIM,N,A,B)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NDIM,*),B(*)
*
*     SOLVE A SYSTEM OF LINEAR EQUATIONS A*X = B
*
*     INPUT..
*
*        NDIM = DECLARED ROW DIMENSION OF THE ARRAY CONTAINING  A.
*        N = ORDER OF THE MATRIX
*        A =  COEFFICIENT MATRIX
*        B = CONSTANT VECTOR
*
*     OUTPUT..
*
*        B = SOLUTION VECTOR
*
      NM1 = N-1
*
*
*     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
*
      DO 35 K = 1,NM1
         KP1= K+1
*
*        FIND PIVOT
*
         M = K
         DO 15 I = KP1,N
            IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I
   15    CONTINUE
         T = A(M,K)
         A(M,K) = A(K,K)
         A(K,K) = T
*
*        SKIP STEP IF PIVOT IS ZERO
*
         IF (T .EQ. 0.0D0) GO TO 35
*
*        COMPUTE MULTIPLIERS
*
         DO 20 I = KP1,N
             A(I,K) = -A(I,K)/T
   20    CONTINUE
*
*        INTERCHANGE AND ELIMINATE BY COLUMNS
*
         DO 30 J = KP1,N
             T = A(M,J)
             A(M,J) = A(K,J)
             A(K,J) = T
             IF (T .EQ. 0.0D0) GO TO 30
             DO 25 I = KP1,N
                A(I,J) = A(I,J) + A(I,K)*T
   25        CONTINUE
   30    CONTINUE
          T = B(M)
          B(M) = B(K)
          B(K) = T
          IF (T .EQ. 0.0D0) GO TO 35
          DO 32 I = KP1, N
              B(I) = B(I) + A(I,K)*T
   32     CONTINUE
   35 CONTINUE
*
*     BACK SUBSTITUTION
*
      DO 40 K = N,2,-1
        IF (A(K,K) .EQ. 0.D0) THEN
             B(K) = 0.D0
          ELSE
             B(K) = B(K)/A(K,K)
        END IF
         T = -B(K)
         DO 41 I = 1, K-1
             B(I) = B(I) + A(I,K)*T
   41    CONTINUE
   40 CONTINUE
   50 B(1) = B(1)/A(1,1)
      RETURN
      END


      double precision function DSIN1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 DSIN1 Krogh  Moved external statement up for mangle.
c>>   1994-10-20 DSIN1 Krogh  Changes to use M77CON
c>>   1993-07-21 DSIN1 WV Snyder JPL Original code
c
c     Compute (X - SIN(X)) / X**2.
c     Use Taylor's series when |X| < CUT (an internal parameter).
c     Use the intrinsic function otherwise.
c
c--D replaces "?": ?SIN1
      double precision X
      external D1MACH
      double precision CUT, D1MACH, ROUND, S, X2
      parameter (CUT=0.125d0)
      integer M, N
      save N
      data N /-1/
c
      if (n .lt. 0) then
         round = d1mach(4)
         n = 1
         s = 1.0d0
10       if (s .gt. round) then
            s = s * cut * cut / ((2*n)*(2*n+1))
            n = n + 1
            go to 10
         end if
      end if
      if (abs(x) .lt. cut) then
         x2 = x*x
         m = 2*n
         s = 1.0d0 - x2/(m*(m+1))
20       if (m .gt. 4) then
            m = m - 2
            s = 1.0d0 - s*x2/(m*(m+1))
            go to 20
         end if
         dsin1 = s/6.0d0
      else
         dsin1 = (x - sin(x)) / x**3
      end if
      return
      end


SUBROUTINE orbk_frame (r,v, Rrtn)

! ----------------------------------------------------------------------
! SUBROUTINE: orbk_frame.f90
! ----------------------------------------------------------------------
! Purpose:
!  Rotation matrix from inertial to orbital frame
! ----------------------------------------------------------------------
! Input arguments:
! - r: 			position vector (m) in inertial frame
! - v: 			velocity vector (m/sec) in inertial frame
!
! Output arguments:
! - Rrtn : 		Rotation matrix from inertial to orbital frame
! ----------------------------------------------------------------------
! Note 1:
!  Orbital frame components:
!  radial, along-track (tangential) and cross-track (normal)  [r t n]
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia           10 May 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_arr
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: r(3), v(3)
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: Rrtn(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: kepler(9), GM, i_deg, Omega_asc_deg, omega_per_deg
      REAL (KIND = prec_q) :: deg2rad
      REAL (KIND = prec_q) :: Rz_Omega_asc(3,3), Rz_omega_per(3,3), Rx_i(3,3), R12(3,3)
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus, pflag
! ----------------------------------------------------------------------

      deg2rad = PI_global / 180.D0

      GM = GM_gfm

      ! Kepler elements
      CALL kepler_z2k (r, v , GM, kepler)

      i_deg = kepler(3)
      Omega_asc_deg = kepler(4)
	  omega_per_deg = kepler(5)

! Rotation matrix for Omega (right ascension of the ascending node)
      Rz_Omega_asc(1,1:3) = (/  cos(Omega_asc_deg * deg2rad),  sin(Omega_asc_deg * deg2rad),	0.D0 /)
      Rz_Omega_asc(2,1:3) = (/ -sin(Omega_asc_deg * deg2rad),  cos(Omega_asc_deg * deg2rad),	0.D0 /)
      Rz_Omega_asc(3,1:3) = (/ 				0.D0, 							0.D0, 			1.D0 /)

! Rotation matrix for omega (argument of perigee)
      Rz_omega_per(1,1:3) = (/  cos(omega_per_deg * deg2rad),  sin(omega_per_deg * deg2rad),	0.D0 /)
      Rz_omega_per(2,1:3) = (/ -sin(omega_per_deg * deg2rad),  cos(omega_per_deg * deg2rad),	0.D0 /)
      Rz_omega_per(3,1:3) = (/ 				0.D0, 							0.D0, 				1.D0 /)

! Rotation matrix for orbit plane's inclination (i)
      Rx_i(1,1:3) = (/ 1.D0,			0.D0,					0.D0 		 /)
      Rx_i(2,1:3) = (/ 0.D0,	 cos(i_deg * deg2rad),	sin(i_deg * deg2rad) /)
      Rx_i(3,1:3) = (/ 0.D0,	-sin(i_deg * deg2rad),	cos(i_deg * deg2rad) /)

! ----------------------------------------------------------------------
! Rotation matrix from Inertial to orbital frame
! Rrtn = Rz_omega_per * Rx_i * Rz_Omega_asc
! ----------------------------------------------------------------------
      ALLOCATE (R1(3,3), STAT = AllocateStatus)
      ALLOCATE (R2(3,3), STAT = AllocateStatus)
      ALLOCATE (R3(3,3), STAT = AllocateStatus)

      R1 = Rz_omega_per
      R2 = Rx_i
      CALL matrix_RxR

      R12 = R3

      DEALLOCATE (R1, STAT = DeAllocateStatus)
      DEALLOCATE (R2, STAT = DeAllocateStatus)
      DEALLOCATE (R3, STAT = DeAllocateStatus)
! ----------------------------------------------------------------------

      ALLOCATE (R1(3,3), STAT = AllocateStatus)
      ALLOCATE (R2(3,3), STAT = AllocateStatus)
      ALLOCATE (R3(3,3), STAT = AllocateStatus)

      R1 = R12
      R2 = Rz_Omega_asc
      CALL matrix_RxR

	  Rrtn = R3

      DEALLOCATE (R1, STAT = DeAllocateStatus)
      DEALLOCATE (R2, STAT = DeAllocateStatus)
      DEALLOCATE (R3, STAT = DeAllocateStatus)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
Rrtn(1,1) =  cos(Omega_asc_deg * deg2rad) * cos(omega_per_deg * deg2rad) &
            -sin(Omega_asc_deg * deg2rad) * cos(i_deg * deg2rad) * sin(omega_per_deg * deg2rad)

Rrtn(1,2) =  sin(Omega_asc_deg * deg2rad) * cos(omega_per_deg * deg2rad) &
            +cos(Omega_asc_deg * deg2rad) * cos(i_deg * deg2rad) * sin(omega_per_deg * deg2rad)

Rrtn(1,3) =  sin(i_deg * deg2rad) * sin(omega_per_deg * deg2rad)

Rrtn(2,1) = -cos(Omega_asc_deg * deg2rad) * sin(omega_per_deg * deg2rad) &
            -sin(Omega_asc_deg * deg2rad) * cos(i_deg * deg2rad) * cos(omega_per_deg * deg2rad)

Rrtn(2,2) = -sin(Omega_asc_deg * deg2rad) * sin(omega_per_deg * deg2rad) &
            +cos(Omega_asc_deg * deg2rad) * cos(i_deg * deg2rad) * cos(omega_per_deg * deg2rad)

Rrtn(2,3) =  sin(i_deg * deg2rad) * cos(omega_per_deg * deg2rad)

Rrtn(3,1) =  sin(Omega_asc_deg * deg2rad) * sin(i_deg * deg2rad)
Rrtn(3,2) = -cos(Omega_asc_deg * deg2rad) * sin(i_deg * deg2rad)
Rrtn(3,3) =  cos(i_deg * deg2rad)
! ----------------------------------------------------------------------

end


      SUBROUTINE DCFINDIF(Q,R,NPTS,QMSG,RMSG,ICYC,IEND,QQ,RR,NPTS1,
     +                    DQDR,IER)

c perform a centered finite difference:
c .   dq/dr ==> partial(q)/partial(r) ==>
c .             dqdr(n) = (q(n+1)-q(n-1))/(r(n+1)-r(n-1))

c NCL: dqdr = center_finite_diff (q,r,rCyclic,opt)
c .           rCyclic = True/False
c .           opt     = unused
c .           wrapper: if rCyclic=True   set iend=0
c .           wrapper: if rCyclic=False  set iend=1

c Nomenclature:
c .   q     - input vector [variable to be differenced]
c .   r     - input vector [spatial or temporal coordinates]
c .   npts  - number of points
c .   qmsg  - msg value for q
c .   rmsg  - msg value for r [currently not used]
c .   icyc  - =1 if data are cyclic in the "r" coordinate
c .   iend  - only used if data are not cyclic in the "r" coordinate
c .           =1 if the end points of are to be approximated
c .              via a one-sided difference scheme
c .           =0 if the end points of are to be returned as rmsg
c .   dqdr  - result
c .   ier   - error code

      IMPLICIT NONE
c                                     input arguments
      INTEGER NPTS,NPTS1,ICYC,IEND
      DOUBLE PRECISION Q(NPTS),R(NPTS),QMSG,RMSG
c                                     output
      INTEGER IER
      DOUBLE PRECISION DQDR(NPTS)
      DOUBLE PRECISION QQ(0:NPTS1),RR(0:NPTS1)
      INTEGER N,NSTRT,NLAST

      IER = 0
c                                    not enough points
      IF (NPTS.LE.2) THEN
          IER = 1
      END IF
c                                    conflicting options
      IF (ICYC.EQ.1 .AND. IEND.NE.0) THEN
          IER = 2
      END IF
      IF (IER.NE.0) RETURN
c                                    initialize
      DO N = 1,NPTS
          DQDR(N) = QMSG
          QQ(N) = Q(N)
          RR(N) = R(N)
      END DO
c                                    add points if cyclic
      NSTRT = 2
      NLAST = NPTS - 1
      IF (ICYC.EQ.1) THEN
          NSTRT = 1
          NLAST = NPTS
          QQ(0) = QQ(NPTS)
          RR(0) = RR(1) - (RR(2)-RR(1))
          QQ(NPTS+1) = QQ(1)
          RR(NPTS+1) = RR(NPTS) + (RR(NPTS)-RR(NPTS-1))
      END IF
c                                    centered finite differences
      DO N = NSTRT,NLAST
          IF (QQ(N-1).NE.QMSG .AND. QQ(N+1).NE.QMSG) THEN
              DQDR(N) = (QQ(N+1)-QQ(N-1))/ (RR(N+1)-RR(N-1))
          END IF
      END DO
c                                    if not cyclic
c                                    how to treat end-points
c                                    3 Mar 2006 [added qmsg checks]
      IF (ICYC.NE.1 .AND. IEND.EQ.1) THEN
         IF (QQ(1).NE.QMSG .AND. QQ(2).NE.QMSG) THEN
             DQDR(1) = (QQ(2)-QQ(1))/ (RR(2)-RR(1))
         END IF
         IF (QQ(NPTS).NE.QMSG .AND. QQ(NPTS-1).NE.QMSG) THEN
             DQDR(NPTS) = (QQ(NPTS)-QQ(NPTS-1))/ (RR(NPTS)-RR(NPTS-1))
         END IF
      END IF

      RETURN
      END


module matrixSolver
  implicit none

  private
  integer, parameter :: dp = kind(0.d0)

  public :: tridiagonalSolver

contains

  subroutine tridiagonalSolver(a,b,c,f,u)
    implicit none
    integer :: i, n
    real(dp) :: a(:), b(:), c(:), f(:), u(:), bp
    real(dp), allocatable :: cp(:)

    n = size(a,1)
    allocate(cp(n))
    bp = b(1)
    u(1) = f(1)/bp
    do i=2,n
      cp(i) = c(i-1)/bp
      bp = b(i) - a(i)*cp(i)
      u(i) = (f(i) - a(i)*u(i-1))/bp
    end do
    do i=n-1,1,-1
      u(i) = u(i) - cp(i+1)*u(i+1)
    end do
    deallocate(cp)
  end subroutine tridiagonalSolver

end module


	FUNCTION PR_DRCT  ( ux, vx )
C************************************************************************
C* PR_DRCT								*
C*									*
C* This function computes DRCT from Ux and Vx, both of which must	*
C* be either meters/sec or knots.  The following equation is used:	*
C*									*
C*              DRCT = ATAN2 ( -UX, -VX ) * RTD				*
C*									*
C* REAL PR_DRCT  ( UX, VX )						*
C*									*
C* Input parameters:							*
C*	UX		REAL		U component of velocity		*
C*	VX		REAL    	V component of velocity		*
C*									*
C* Output parameters:							*
C*	PR_DRCT		REAL		Wind direction in degrees	*
C**									*
C* Log:									*
C* I. Graffman/CSC	8/83	Original source code			*
C* M. Goodman/RDS  	8/84	Renamed PR_DRCT 			*
C* M. desJardins/GSFC	1/86	Corrected uwnd=0 problem		*
C*				Added parameter statements		*
C* I. Graffman/RDS	12/87	GEMPAK4 documentation			*
C* G. Huffman/GSC       7/88    Documentation; U, V names; north=360	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Find bad data.
C
	IF  ( ERMISS (ux) .or. ERMISS (vx) )  THEN
	    PR_DRCT = RMISSD
	  ELSE IF  ( ( vx .EQ. 0. ) .and. ( ux .eq. 0. ) )  THEN
	    PR_DRCT = 0.
	  ELSE
	    PR_DRCT = ATAN2 ( -ux, -vx ) * RTD
	    IF  ( PR_DRCT .le. 0. )  PR_DRCT = PR_DRCT + 360.
	END IF
C*
	RETURN
	END


c Truong Dang added 02-11-2016
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccc                                                            ccc
ccc  purpose: Inverse computation of a matrix                  ccc
ccc                                                            ccc
ccc  Input and output varibles:                                ccc
ccc          input         n  size of matrix                   ccc
ccc          input         a  input matrix                     ccc
ccc          output        y  output inverse matrix            ccc
ccc                                                            ccc
ccc  Use:                                                      ccc
ccc          ludcmp        LU docomposition                    ccc
ccc          lubksb        find inverse of matrix by columns   ccc
ccc                                                            ccc
ccc  Warning: After matinv(a,n,y) is called, the input matrix  ccc
ccc           'a' would be changed (used as working space)     ccc
ccc           unless it is a diagnal matix. So if 'a' is       ccc
ccc           not a diagnal matrix and will be used after      ccc
ccc           calling matinv.f, 'a' should be saved before     ccc
ccc           calling matinv.f.                                ccc
ccc                                                            ccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine matinv(a,n,y)
      implicit none
c
      integer(4)::n,i,j
      real(8):: a(n,n),y(n,n),d
      integer(4)::indx(n)
      y=0.
      do i=1,n
        y(i,i)=1.
      end do
      call ludcmp(a,n,n,indx,d)
      do j=1,n
        call lubksb(a,n,n,indx,y(1,j))
      end do
c
      return
      end
c
      SUBROUTINE ludcmp(a,n,np,indx,d)
      implicit none
      INTEGER(4):: n,np,indx(n),NMAX
      REAL(8):: d,a(np,np),TINY
      PARAMETER (NMAX=100,TINY=1.0e-20)
      INTEGER(4):: i,imax,j,k
      REAL(8):: aamax,dum,sum,vv(n)
      d=1.0d0
      do 12 i=1,n
        aamax=0.
        do 11 j=1,n
          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
11      continue
        if (aamax.eq.0.) print*, 'singular matrix in ludcmp'
        vv(i)=1./aamax
12    continue
      do 19 j=1,n
        do 14 i=1,j-1
          sum=a(i,j)
          do 13 k=1,i-1
            sum=sum-a(i,k)*a(k,j)
13        continue
          a(i,j)=sum
14      continue
        aamax=0.
        do 16 i=j,n
          sum=a(i,j)
          do 15 k=1,j-1
            sum=sum-a(i,k)*a(k,j)
15        continue
          a(i,j)=sum
          dum=vv(i)*abs(sum)
          if (dum.ge.aamax) then
            imax=i
            aamax=dum
          endif
16      continue
        if (j.ne.imax)then
          do 17 k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
17        continue
          d=-d
          vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(a(j,j).eq.0.)a(j,j)=TINY
        if(j.ne.n)then
          dum=1./a(j,j)
          do 18 i=j+1,n
            a(i,j)=a(i,j)*dum
18        continue
        endif
19    continue
      return
      END
c
      SUBROUTINE lubksb(a,n,np,indx,b)
      implicit none
      INTEGER(4):: n,np,indx(n)
      REAL(8):: a(np,np),b(n)
      INTEGER(4):: i,ii,j,ll
      REAL(8):: sum
      ii=0
      do 12 i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do 11 j=ii,i-1
            sum=sum-a(i,j)*b(j)
11        continue
        else if (sum.ne.0.) then
          ii=i
        endif
        b(i)=sum
12    continue
      do 14 i=n,1,-1
        sum=b(i)
        do 13 j=i+1,n
          sum=sum-a(i,j)*b(j)
13      continue
        b(i)=sum/a(i,i)
14    continue
      return
      END


 	Program oscillator
 	Implicit none
c declarations
c n: number of equations
	Real*8 dist, min, max, t, y(5)
	Integer	n
	n=2
C starting and end points
        min=0.0D0
        max=10.0D0
C time step
        dist=0.1D0
C initial position
        y(1)=0.2
C initial velocity
        y(2)=0.0

c open file to output
        Open(6, File='rk4.dat')
c do n steps of Runga-Kutta algorithm
	Do t=min, max, dist
	  Call rk4(t, dist, y, n)
          Write (6,100) t, y(1)
 	enddo
c
	Close(6)
	Stop 'data saved in rk4.dat'
100     format(2f14.6)
        End
c------------------------end of main program------------------------
c
c fourth-order Runge-Kutta subroutine
	Subroutine rk4(x, xstep, y, n)
	Implicit none
c declarations
	Real*8 func, h, x, xstep, y(1)
        Real*8 k1(5), k2(5),k3(5), k4(5), t1(5), t2(5), t3(5)
     	Integer i, n
C half step size
     	h=xstep/2.D0
	Do i = 1,n
	   k1(i) = xstep * func(x, y, i)
	   t1(i) = y(i) + 0.5*k1(i)
   	enddo
	Do i = 1,n
	   k2(i) = xstep * func(x+h, t1, i)
	   t2(i) = y(i) + 0.5*k2(i)
   	enddo
	Do i = 1,n
	   k3(i) = xstep * func(x+h, t2, i)
	   t3(i) = y(i) + k3(i)
   	enddo
	Do i = 1,n
	   k4(i) = xstep * func(x+xstep, t3, i)
	   y(i) = y(i) + (k1(i) + (2.*(k2(i) + k3(i))) + k4(i))/6.0
   	enddo
c
	Return
	End

c function which returns the func
	Function func(t, temp, i)
C 2 function components: dx/dt = v(t),   dv/dt = -w**2*x(t) -a*v
C the second term is damping term
	Implicit none
c declarations
	Real*8 func, t, temp(2), omega, alpha
	Integer i
	data omega /3.13d0/
	data alpha /0.5d0/
c
	If (i .EQ. 1) func=temp(2)
	If (i .EQ. 2) func=-temp(1) * omega**2
	Return
	End


subroutine spaceevenly(start, finish, number, arrayout)
    implicit none

    integer, intent(in) :: start, finish
    real(kind=8), intent(in) :: number
    real(kind=8) :: div
    real(kind=8), dimension(0:finish), intent(out) :: arrayout
    integer :: i

    div = number / ((finish-1) - (start-1))

    do i=start, finish
        arrayout(i) = div * i
    end do

end subroutine spaceevenly

subroutine write_csv (unit_number, filename, p, nx, ny)
    implicit none
    integer,  intent(in) :: unit_number
    character(len = *),  intent(in) :: filename
    integer, intent(in) :: nx, ny
    real(kind=8), intent(in), dimension(nx,ny) :: p
    integer :: i, j

10  format (i1)
15  format (f10.5,",")
20  format ("")

    open(unit=unit_number, file=filename)
    do i=1, nx
        do j=1, ny
            write(unit=unit_number, fmt=15, advance="no"), p(i,j)
        end do
        write(unit=unit_number,fmt=20)
    end do

    close(unit=unit_number)

end subroutine

program l10
    use pyplot_module, only : pyplot

    implicit none

    type(pyplot) :: plt

    integer, parameter :: nx = 50, ny = 50, nt = 100
    integer, parameter :: xmin = 0, xmax = 2, ymin = 0, ymax = 1
    real(kind=8) :: dx = real(xmax - xmin) / real(nx - 1)
    real(kind=8) :: dy = real(ymax - ymin) / real(ny - 1)
    integer :: i, j, time, istat
    real(kind=8),dimension(nx) :: y, x
    real(kind=8), dimension(nx, ny) :: p, pd, b
    real(kind=8) :: F1term, S2term, numerator, denominator
    real(kind=8) :: source_term, derivYpow2, derivXpow2
    character:: input

    ! Initialize arrays
    do i=1,nx
        do j=1, ny
            p(i,j) = 0
            pd(i,j) = 0
            b(i,j) = 0
        end do
    end do

    do i=1, nx
        y(i) = 0
        x(i) = 0
    end do

    !!!!! NOT WORKING !!
    !!!!! Inserts NaN into arrays and cant plot porperly.
    !!!!! Values correct, verified via csv plot
    ! Generate values for y
    call spaceevenly(1, ny, ymax, y)
    ! Generate values for x
    call spaceevenly(1, nx, xmax , x)

    b(int(ny/4),int(nx/4)) = 100
    b(int(3*ny/4),int(3*nx/4)) = -100

    derivYpow2 = dy**2
	derivXpow2 = dx**2

    time = nt
    do time = 1, time
            pd = p
            do j=2, nx-1
                do i=2, ny-1

                    F1term = p(j, i + 1) + p(j, i - 1)
                    S2term = p(j + 1, i) + p(j - 1, i)
                    source_term = b(j,i) * derivXpow2 * derivYpow2

                    numerator = (derivYpow2 * F1term) + (derivXpow2 * S2term) - source_term
                    denominator = 2 * (derivXpow2 + derivYpow2)

                    p(j,i) = numerator / denominator

                    p(1,j) = 0
                    p(nx,j) = 0
                    p(i,1) = 0
                    p(i,ny) = 0

                    p(1,1) = 0
                    p(1,nx) = 0
                    p(ny,1) = 0
                    p(ny,nx) = 0

                end do
            end do
    end do

        ! write csv
    call write_csv(1, "l10.csv", p, nx, ny)

    ! Plotting
    call plt%initialize(grid=.true.,&
                        title='Plot of p',legend=.false.,mplot3d=.true.,use_colormap=.true.)

    call plt%plot_surface(y,x,p,label='value of p', istat=istat, &
                            cmap="cm.cividis")

    call plt%savefig('l10.png', &
                      pyfile='l10.py', &
                      dpi='200',istat=istat)

    print*, "Plotting done "

    print*, "ready"
    read*, input

end program l10


      FUNCTION enorm (n, x)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER n
      REAL(rprec), DIMENSION(n) :: x
      REAL(rprec) :: enorm
!-----------------------------------------------
!
!     FUNCTION enorm
!
!     given an n-vector x, this FUNCTION calculates the
!     euclidean norm of x.
!
!
!     the FUNCTION statement is
!
!       FUNCTION enorm(n,x)
!
!     WHERE
!
!       n is a positive INTEGER input variable.
!
!       x is an input array of length n.
!
      enorm = SQRT (SUM(x(:n)*x(:n)))

      END FUNCTION enorm


FUNCTION norm(x)RESULT(l2n)
!
! THis function calculates the l2 norm of vector x
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x(:)
 REAL(iwp)::l2n
 l2n=SQRT(SUM(x**2))
RETURN
END FUNCTION norm


! Euler1 in Fortran90

program euler1
    integer :: euler

    print*, euler(999)
end

function euler(size)
    integer euler, size
    euler = 0

    do i = 0, size
        if (modulo(i,3)==0 .or. modulo(i,5)==0) then
            euler = euler + i
        end if
    end do
end


! Solve the Poisson problem
!     u_{xx} + u_{yy} = f(x, y)   x \in \Omega = [0, pi] x [0, pi]
! with
!     u(0, y) = u(pi, y) = 0
!     u(x, 0) = 2 sin x
!     u(x, pi) = -2 sin x
! and
!     f(x, y) = -20 sin x cos 3 y
! using Jacobi iterations and MPI.  For simplicity we will assume that we
! will use a uniform discretization.

program jacobi_2d_mpi

    use mpi

    implicit none

    ! Problem paramters
    real(kind=8), parameter :: PI = 3.141592654d0;
    real(kind=8) :: a = 0.d0, b = PI;

    ! MPI variables
    integer :: num_procs, rank, rank_num_points, error, request
    integer :: start_index, end_index
    integer, dimension(MPI_STATUS_SIZE) :: status

    ! Numerical parameters
    integer, parameter :: MAX_ITERATIONS = 2**16
    integer, parameter :: PRINT_INTERVAL = 1000

    ! Work arrays
    real(kind=8), allocatable :: u_old(:, :)
    real(kind=8), allocatable :: u(:, :)
    real(kind=8), allocatable :: f(:, :)

    ! IO
    character(len=12) :: file_name
    integer, parameter :: IO_UNIT = 42

    ! Locals
    integer :: i, j, N
    integer :: num_points
    real(kind=8) :: x, y, dx, dy, tolerance, du_max, du_max_proc

    ! Initialize MPI
    call MPI_init(error)
    call MPI_comm_size(MPI_COMM_WORLD, num_procs, error)
    call MPI_comm_rank(MPI_COMM_WORLD, rank, error)

    ! Discretization
    num_points = 100
    dx = (b - a) / real(num_points + 1, kind=8)
    dy = dx
    tolerance = 0.1d0 * dx**2

    ! Break up into horizontal strips
    rank_num_points = (num_points + num_procs - 1) / num_procs
    start_index = rank * rank_num_points + 1
    end_index = min((rank + 1) * rank_num_points, num_points)
    rank_num_points = end_index - start_index + 1

    ! Diagnostic: tell the user which points will be handled by which task
    print '("Rank ",i2," = (",i6,", ",i6,")")', rank, start_index, end_index

    ! Allocate memory for the arrays
    allocate(u_old(0:num_points + 1, start_index - 1:end_index + 1))
    allocate(u(0:num_points + 1, start_index - 1:end_index + 1))
    allocate(f(0:num_points + 1, start_index - 1:end_index + 1))

    ! Fill in f and initial guess for u
    do i=1, num_points
        x = dx * real(i, kind=8) + a
        do j=start_index, end_index
            y = dy * real(j + start_index + 1, kind=8) + b
            f(i, j) = -20.d0 * sin(x) * cos(3.d0 * y)
            u(i, j) = -20.d0
        end do
    end do

    ! Set boundary values
    ! Set bottom boundary (rank 0)
    if (rank == 0) then
        do i=0, num_points + 1
            x = dx * real(i, kind=8) + a
            u(i, 0) = 2.0 * sin(x)
        end do
    end if

    ! Set left and right edges (all ranks)
    do j=start_index, end_index
        u(0, j) = 0.d0
        u(num_points + 1, j) = 0.d0
    end do

    ! Set top boundary (num_proces - 1 rank)
    if (rank == num_procs - 1) then
        do i=0, num_points + 1
            x = dx * real(i, kind=8) + a
            u(i, num_points + 1) = -2.0 * sin(x)
        end do
    end if

    !* Jacobi Iteration *!
    du_max = 0.d0
    do N=1, MAX_ITERATIONS
        ! Copy internal values into old array
        u_old = u

        ! Communication of halo values
        ! Send data up (right +) tag = 1
        if (rank < num_procs - 1) then
            call MPI_isend(u_old(:, end_index), num_points + 2, MPI_DOUBLE_PRECISION, &
                            rank + 1, 1, MPI_COMM_WORLD, request, error)
        end if
        ! Send data down (left -) tag = 2
        if (rank > 0) then
            call MPI_isend(u_old(:, 1), num_points + 2, MPI_DOUBLE_PRECISION, &
                            rank - 1, 2, MPI_COMM_WORLD, request, error)
        end if

        ! Receive data from above (left -) tag = 2
        if (rank < num_procs - 1) then
            call MPI_recv(u_old(:, end_index + 1), num_points + 2, MPI_DOUBLE_PRECISION, &
                            rank + 1, 2, MPI_COMM_WORLD, status, error)
        end if
        ! Recieve data from below (right +) tag = 1
        if (rank > 0) then
            call MPI_recv(u_old(:, 0), num_points + 2, MPI_DOUBLE_PRECISION, &
                            rank - 1, 1, MPI_COMM_WORLD, status, error)
        end if

        ! Perform actual Jacobi
        du_max_proc = 0.d0
        do i=1, num_points
            do j=start_index, end_index
                u(i, j) = 0.25d0 * (u_old(i-1, j) + u_old(i+1, j) + u_old(i, j-1) + u_old(i, j+1) - dx**2 * f(i,j))
                du_max_proc = max(du_max_proc, abs(u(i,j) - u_old(i,j)))
            end do
        end do

        call MPI_allreduce(du_max_proc, du_max, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, error)

        if (rank == 0) then
            if (mod(N, PRINT_INTERVAL) == 0) then
                print '("After ",i8," iterations, du_max = ",d16.6,/)', N, du_max
            end if
        end if

        ! Check for exit tolerance
        if (du_max < tolerance) then
            exit
        end if
    end do

    ! Check for failure
    if (N >= MAX_ITERATIONS) then
        if (rank == 0) then
            print *, "*** Jacobi failed to converge!"
            print *, "***   Reached du_max = ", du_max
            print *, "***   Tolerance = ", tolerance
        end if
        call mpi_finalize(error)
        stop
    end if

    ! Output
    write(file_name, '("jacobi_",i1,".txt")') rank
    open(unit=IO_UNIT, file=file_name, status='replace')
    if (rank == 0) then
        write(IO_UNIT, *) u(:, 0)
    end if
    do j=start_index, end_index
        write(IO_UNIT, *) u(:, j)
    end do
    if (rank == num_procs - 1) then
        write(IO_UNIT, *) u(:, end_index + 1)
    end if
    close(IO_UNIT)

    ! Close out MPI
    call mpi_finalize(error)

end program jacobi_2d_mpi


module Q_mod
  implicit none

  type quaternion
    real :: a, b, c, d
  end type

  public :: norm, neg, conj
  public :: operator (+)
  public :: operator (*)

  private ::  q_plus_q, q_plus_r, r_plus_q, &
              q_mult_q, q_mult_r, r_mult_q, &
              norm_q, neg_q, conj_q

  interface norm
    module procedure norm_q
  end interface

  interface neg
    module procedure neg_q
  end interface

  interface conj
    module procedure conj_q
  end interface

  interface operator (+)
    module procedure q_plus_q, q_plus_r, r_plus_q
  end interface

  interface operator (*)
    module procedure q_mult_q, q_mult_r, r_mult_q
  end interface

contains

function norm_q(x) result(res)
  real :: res
  type (quaternion), intent (in) :: x

  res = sqrt(x%a*x%a + x%b*x%b + x%c*x%c + x%d*x%d)

end function norm_q

function neg_q(x) result(res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x

  res%a = -x%a
  res%b = -x%b
  res%c = -x%c
  res%d = -x%d

end function neg_q

function conj_q(x) result(res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x

  res%a = x%a
  res%b = -x%b
  res%c = -x%c
  res%d = -x%d

end function conj_q

function q_plus_q(x, y) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x, y

  res%a = x%a + y%a
  res%b = x%b + y%b
  res%c = x%c + y%c
  res%d = x%d + y%d

end function q_plus_q

function q_plus_r(x, r) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x
  real, intent(in) :: r

   res = x
   res%a = x%a + r

end function q_plus_r

function r_plus_q(r, x) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x
  real, intent(in) :: r

   res = x
   res%a = x%a + r

end function r_plus_q

function q_mult_q(x, y) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x, y

   res%a = x%a*y%a - x%b*y%b - x%c*y%c - x%d*y%d
   res%b = x%a*y%b + x%b*y%a + x%c*y%d - x%d*y%c
   res%c = x%a*y%c - x%b*y%d + x%c*y%a + x%d*y%b
   res%d = x%a*y%d + x%b*y%c - x%c*y%b + x%d*y%a

end function q_mult_q

function q_mult_r(x, r) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x
  real, intent(in) ::  r

   res%a = x%a*r
   res%b = x%b*r
   res%c = x%c*r
   res%d = x%d*r

end function q_mult_r

function r_mult_q(r, x) result (res)
  type (quaternion) :: res
  type (quaternion), intent (in) :: x
  real, intent(in) ::  r

   res%a = x%a*r
   res%b = x%b*r
   res%c = x%c*r
   res%d = x%d*r

end function r_mult_q
end module Q_mod

program Quaternions
  use Q_mod
  implicit none

  real :: r = 7.0
  type(quaternion) :: q, q1, q2

  q  = quaternion(1, 2, 3, 4)
  q1 = quaternion(2, 3, 4, 5)
  q2 = quaternion(3, 4, 5, 6)

  write(*, "(a, 4f8.3)") "             q = ", q
  write(*, "(a, 4f8.3)") "            q1 = ", q1
  write(*, "(a, 4f8.3)") "            q2 = ", q2
  write(*, "(a, f8.3)")  "             r = ", r
  write(*, "(a, f8.3)")  "     Norm of q = ", norm(q)
  write(*, "(a, 4f8.3)") " Negative of q = ", neg(q)
  write(*, "(a, 4f8.3)") "Conjugate of q = ", conj(q)
  write(*, "(a, 4f8.3)") "         q + r = ", q + r
  write(*, "(a, 4f8.3)") "         r + q = ", r + q
  write(*, "(a, 4f8.3)") "       q1 + q2 = ", q1 + q2
  write(*, "(a, 4f8.3)") "         q * r = ", q * r
  write(*, "(a, 4f8.3)") "         r * q = ", r * q
  write(*, "(a, 4f8.3)") "       q1 * q2 = ", q1 * q2
  write(*, "(a, 4f8.3)") "       q2 * q1 = ", q2 * q1

end program


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

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter :: M = 48
    integer(ip), parameter :: N = 53
    integer(ip), parameter :: IDIMF = M + 2
    integer(ip)            :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)               :: f(IDIMF, N)
    real(wp), dimension(N) :: bda, bdb, y
    real(wp)               :: a, b, c, d
    real(wp)               :: dx, dy, x(M), bdc(1), bdd(1)
    real(wp)               :: elmbda, pertrb
    real(wp), parameter    :: PI2 = PI**2
    real(wp), parameter    :: ZERO = 0.0_wp, HALF = 0.5_wp, ONE = 1.0_wp
    real(wp), parameter    :: TWO = 2.0_wp, THREE = 3.0_wp

    ! Set domain
    a = ONE
    b = THREE
    c = -ONE
    d = ONE

    ! Set boundary conditions
    mbdcnd = 2
    nbdcnd = 0

    ! Set helmholtz constant
    elmbda = -TWO

    ! Set mesh sizes
    dx = (b - a)/M
    dy = (d - c)/N

    ! Generate and store grid points for computation of boundary data
    ! and the right side of the helmholtz equation.
    do i = 1, M
        x(i) = a + (real(i, kind=wp) - HALF) * dx
    end do

    do j = 1, N
        y(j) = c + (real(j, kind=wp) - HALF) * dy
    end do

    ! Generate boundary data. bdc and bdd are dummy arguments in this example.
    bda = ZERO
    bdb = -PI * cos(PI*y)

    ! Generate right side of equation
    block
        real(wp), parameter :: CONST = -TWO*(PI2 + ONE)

        do i = 1, M
            f(i,:) = CONST*sin(PI*x(i))*cos(PI*y(:))
        end do
    end block

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

    ! Compute discretization error. The exact solution is
    !
    ! u(x, y) = sin(pi*x) * cos(pi*y).
    block
        real(wp), parameter :: KNOWN_ERROR = 0.126000790151959e-2_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M,N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = sin(PI*x(i))*cos(PI*y(j))
            end do
        end do

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

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

end program test_hstcrt


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SPEL1D                                                C
C                                                                      C
C     Returns the mass and stiffness matrices for a 1D element         C
C     with interpolation polynomials of degree N and constant          C
C     parameters RHO and E.                                            C
C                                                                      C
C                                                                      C
C     PARAMETERS       N:   Number of nodes                            C
C                      RHO: Mass density                               C
C                      E:   Stiffness density                          C
C                      SML: Lumped mass matrix                         C
C                      SKL: Stiffness matrix                           C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 28 MAY 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE SPEL1D(N,RHO,E,SML,SKL)
        IMPLICIT REAL*8(A-H,O-Z)
        DIMENSION X_LOB(N), W_LOB(N)
        DIMENSION H(N), DIFH(N)
        DIMENSION SML(N,N),SKL(N,N)

          CALL LOB_NODES(N,X_LOB,W_LOB)
          SML = 0.0
          RHO = 1.0
          DO K=1,N
            XK = X_LOB(K) ! Integration points - GLL
            CALL LOB_POL(N,X_LOB,XK,H,DIFH)
            DO I=1,N
                DO J=1,N
                    SML(I,J) = SML(I,J) + H(I)*H(J)*RHO*W_LOB(K)
                    SKL(I,J) = SKL(I,J) + DIFH(I)*DIFH(J)*E*W_LOB(K)
                END DO
            END DO
          END DO

      END SUBROUTINE SPEL1D

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE UEL_SEM_LOB                                           C
C                                                                      C
C     Returns the mass and stiffness matrices for a 2D element         C
C     with interpolation polynomials of degree NX in the X             C
C     direction and degree NY in the Y direction. For constant         C
C     parameters RHO and E.                                            C
C                                                                      C
C                                                                      C
C     PARAMETERS       N:   Number of nodes                            C
C                      RHO: Mass density                               C
C                      E:   Stiffness density                          C
C                      SML: Lumped mass matrix                         C
C                      SKL: Stiffness matrix                           C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 3 JUNE 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
        SUBROUTINE UEL_SEM_LOB(SKL,SML,NDOFEL,PROPS,NPROPS,NX,NY,COORDS,
     1                         MCRD,JELEM)
            IMPLICIT REAL*8(A-H,O-Z)
            DIMENSION PROPS(NPROPS)
            DIMENSION C(3,3)
            DIMENSION COORDS(MCRD,NX*NY)
            DIMENSION X_LOB(NX), Y_LOB(NY)
            DIMENSION WX_LOB(NX), WY_LOB(NY)
            DIMENSION AJINV(2,2)
            DIMENSION H2D(NX*NY), DH2D(NX*NY,2)
            DIMENSION R(NDOFEL,NDOFEL)
            DIMENSION SML(NDOFEL,NDOFEL),SKL(NDOFEL,NDOFEL)

            E = PROPS(1)
            CPOIS = PROPS(2)
            RHO = PROPS(3)
            CALL LOB_NODES(NX,X_LOB,WX_LOB)
            CALL LOB_NODES(NY,Y_LOB,WY_LOB)

C           Plane Strain
            C(1,1) = (1.0-CPOIS)*E/((1.0-2.0*CPOIS)*(CPOIS+1.0))
            C(1,2) = CPOIS*E/((1.0-2.0*CPOIS)*(CPOIS+1.0))
            C(1,3) = 0.0
            C(2,1) = CPOIS*E/((1.0-2.0*CPOIS)*(CPOIS+1.0))
            C(2,2) = (1.0-CPOIS)*E/((1.0-2.0*CPOIS)*(CPOIS+1.0))
            C(2,3) = 0.0
            C(3,1) = 0.0
            C(3,2) = 0.0
            C(3,3) = E/(CPOIS+1.0)/2.0

C           Plane Stress
C            t = 1.0
C            C(1,1) = t*E/(1-CPOIS**2)
C            C(1,2) = CPOIS*t*E/(1-CPOIS**2)
C            C(1,3) = 0
C            C(2,1) = CPOIS*t*E/(1-CPOIS**2)
C            C(2,2) = t*E/(1-CPOIS**2)
C            C(2,3) = 0
C            C(3,1) = 0
C            C(3,2) = 0
C            C(3,3) = (1-CPOIS)*t*E/(1-CPOIS**2)/2.0E

            SML = 0.0
            SKL = 0.0
            DO IX=1,NX
                X = X_LOB(IX)
                WX = WX_LOB(IX)
                DO IY=1,NY
                    Y = Y_LOB(IY)
                    WY = WY_LOB(IY)
                    CALL LOB_POL2D(NX,NY,X_LOB,Y_LOB,X,Y,H2D,DH2D)
                    CALL JACO(NX,NY,COORDS,DH2D,AJINV,DETJ)
                    CALL INTEGRAND(NX,NY,DH2D,AJINV,C,R)
                    DO II=1,NX*NY  !  Mass matrix
                        SML(2*II-1,2*II-1) = SML(2*II-1,2*II-1) +
     1                                         DETJ*RHO*H2D(II)*WX*WY
                        SML(2*II,2*II) = SML(2*II,2*II) +
     1                                         DETJ*RHO*H2D(II)*WX*WY
                    END DO
                    DO II=1,2*NX*NY  !  Stiffness matrix
                        DO JJ=1,2*NX*NY
                            SKL(II,JJ) = SKL(II,JJ) +
     1                                      DETJ*R(II,JJ)*WX*WY
                        END DO
                   END DO
                END DO
            END DO

        END SUBROUTINE UEL_SEM_LOB

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE JACO                                                  C
C                                                                      C
C     Computes the Jacobian matrix for a NX*NY GLL element.            C
C                                                                      C
C                                                                      C
C     PARAMETERS       NX:   Number of nodes                           C
C                      NY: Number of nodes in Y                        C
C                      COORDS: Array with coordinates for the          C
C                              for the undeformed element.             C
C                      E:   Stiffness density                          C
C                      SML: Lumped mass matrix                         C
C                      SKL: Stiffness matrix                           C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 2 June 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE JACO(NX,NY,COORDS,DH2D,AJINV,DETJ)
        IMPLICIT REAL*8(A-H,O-Z)
        DIMENSION COORDS(2,NX*NY), DH2D(NX*NY,2)
        DIMENSION AJAC(2,2), AJINV(2,2)

            AJAC = 0.0
            DO I=1,NX*NY
                AJAC(1,1) = AJAC(1,1) + COORDS(1,I)*DH2D(I,1)
                AJAC(1,2) = AJAC(1,2) + COORDS(2,I)*DH2D(I,1)
                AJAC(2,1) = AJAC(2,1) + COORDS(1,I)*DH2D(I,2)
                AJAC(2,2) = AJAC(2,2) + COORDS(2,I)*DH2D(I,2)
            END DO

            DETJ = AJAC(1,1)*AJAC(2,2) - AJAC(1,2)*AJAC(2,1)

            AJINV(1,1) =  AJAC(2,2)/DETJ
            AJINV(1,2) = -AJAC(1,2)/DETJ
            AJINV(2,1) = -AJAC(2,1)/DETJ
            AJINV(2,2) =  AJAC(1,1)/DETJ
      END SUBROUTINE JACO

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE INTEGRAND                                             C
C                                                                      C
C     Returns the mass and stiffness matrices for a 1D element         C
C     with interpolation polynomials of degree N and constant          C
C     parameters RHO and E.                                            C
C                                                                      C
C                                                                      C
C     PARAMETERS       N:   Number of nodes                            C
C                      RHO: Mass density                               C
C                      E:   Stiffness density                          C
C                      SML: Lumped mass matrix                         C
C                      SKL: Stiffness matrix                           C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 28 MAY 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE INTEGRAND(NX,NY,DH2D,AJINV,C,R)
        IMPLICIT REAL*8(A-H,O-Z)
        DIMENSION DH2D(NX*NY,2),DHDX(NX*NY,2)
        DIMENSION C(3,3), AJINV(2,2), B(3,2*NX*NY)
        DIMENSION R(2*NX*NY,2*NX*NY)

        DO I=1,2  ! Derivatives interpolator in physical coordinates
            DO J=1,NX*NY
                DHDX(J,I) = DH2D(J,2)*AJINV(I,2)
     1                           + DH2D(J,1)*AJINV(I,1)
            END DO
        END DO

        B = 0.0  ! Displacement to Strains Matrix as Bathe (1995)
        DO I=1,NX*NY
            B(1,2*I-1) = DHDX(I,1)
            B(2,2*I)   = DHDX(I,2)
            B(3,2*I-1) = DHDX(I,2)
            B(3,2*I)   = DHDX(I,1)
        END DO

        DO I=1,2*NX*NY  ! Integrand
            DO J=1,2*NX*NY
                R(I,J) = C(3,3)*B(3,I)*B(3,J) + C(2,3)*B(2,I)*B(3,J)
     1              + C(1,3)*B(1,I)*B(3,J) + B(2,J)*C(3,2)*B(3,I)
     2              + B(1,J)*C(3,1)*B(3,I) + C(2,2)*B(2,I)*B(2,J)
     3              + C(1,2)*B(1,I)*B(2,J) + B(1,J)*C(2,1)*B(2,I)
     4              + C(1,1)*B(1,I)*B(1,J)
            END DO
        END DO

      END SUBROUTINE INTEGRAND

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE LOB_POL                                               C
C                                                                      C
C     Returns the value for the interpolant polynomials                C
C     evaluated at a point X, provided the GLL for the                 C
C     interpolant Lagrange polynomial of order N.                      C
C                                                                      C
C                                                                      C
C     PARAMETERS       N:   Number of nodes                            C
C                      X_LOB: GLL points                               C
C                      X:     Evaluation point                         C
C                      H:     Evaluated interpolator array             C
C                      DIFH:  Evaluated interpolator derivatives       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 28 MAY 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
        SUBROUTINE LOB_POL(N,X_LOB,X,H,DIFH)
            IMPLICIT REAL*8(A-H,O-Z)
            REAL*8 PROD1, PROD2
            DIMENSION X_LOB(N),H(N),DIFH(N)

            DO I = 1,N
                PROD1 = 1.0
                PROD2 = 1.0
                XI = X_LOB(I)
                DO J = 1,N  ! Interpolators
                    IF(I.NE.J) THEN
                        PROD1 = PROD1*(X - X_LOB(J))
                        PROD2 = PROD2*(XI - X_LOB(J))
                    END IF
                END DO
                H(I) = PROD1/PROD2

                DIFH(I)=0.0
                DO J = 1,N ! Interpolator derivatives
                    IF(J.NE.I) THEN
                        PROD1 = 1.0
                        DO K = 1,N
                            IF(K.NE.I .and. K.NE.J) THEN
                                PROD1 = PROD1*(X - X_LOB(K))
                            END IF
                        END DO
                        DIFH(I) = DIFH(I) + PROD1
                    END IF
                END DO
                DIFH(I) = DIFH(I)/PROD2
            END DO
        END SUBROUTINE LOB_POL

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE LOB_POL2D                                             C C                                                                      C
C     Returns the value for the 2D interpolant polynomials and         C
C     its derivaties evaluated at a point (X,Y), provided              C
C     the GLL for the interpolant Lagrange polynomial of               C
C     order N.                                                         C
C                                                                      C
C                                                                      C
C     PARAMETERS       NX:   Number of nodes in X direction            C
C                      NY:   Number of nodes in Y direction            C
C                      X_LOB: GLL points in X direction                C
C                      Y_LOB: GLL points in Y direction                C
C                      X:     Evaluation point 1st component           C
C                      Y:     Evaluation point 2nd component           C
C                      H2D:     Evaluated interpolator array           C
C                      DH2D:  Evaluated interpolator derivatives       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 29 MAY 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
        SUBROUTINE LOB_POL2D(NX,NY,X_LOB,Y_LOB,X,Y,H2D,DH2D)
            IMPLICIT REAL*8(A-H,O-Z)
            REAL*8 PROD1, PROD2
            DIMENSION X_LOB(NX), Y_LOB(NY)
            DIMENSION HX(NX), HY(NY), DIFHX(NX), DIFHY(NY)
            DIMENSION H2D(NX*NY),DH2D(NX*NY,2)

            CALL LOB_POL(NX,X_LOB,X,HX,DIFHX)
            CALL LOB_POL(NY,Y_LOB,Y,HY,DIFHY)

            DO IX=1,NX
                DO IY=1,NY
                    I = IX + (IY-1)*NX
                    H2D(I) = HX(IX)*HY(IY)
                    DH2D(I,1) = DIFHX(IX)*HY(IY)
                    DH2D(I,2) = HX(IX)*DIFHY(IY)
                END DO
            END DO

        END SUBROUTINE LOB_POL2D

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE LOB_NODES                                             C
C                                                                      C
C     Returns the Gauss-Lobatto-Lagrange (GLL) nodes(X) and weights(W) C
C     for an interpolant Lagrange polynomial of order N-1.             C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA - UNIVERSIDAD EAFIT                   C
C     LAST MOD: 28 MAY 2012                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
        SUBROUTINE LOB_NODES(N,X,W)
            IMPLICIT REAL*8(A-H,O-Z)
            DIMENSION X(N), W(N)

            SELECT CASE(N)

              CASE(2)
                X(1) = -1.0D+0
                X(2) = 1.0D+0

                W(1) = 1.0D+0
                W(2) = 1.0D+0

              CASE(3)
                X(1) = -1.0D+0
                X(2) = 0.0D+0
                X(3) = 1.0D+0

                W(1) = 3.3333333333333331D-1
                W(2) = 1.3333333333333333D+0
                W(3) = 3.3333333333333331D-1

              CASE(4)
                X(1) = -1.0D+0
                X(2) = -4.4721359549995793D-1
                X(3) = 4.4721359549995793D-1
                X(4) = 1.0D+0

                W(1) = 1.6666666666666666D-1
                W(2) = 8.3333333333333337D-1
                W(3) = 8.3333333333333326D-1
                W(4) = 1.6666666666666666D-1

              CASE(5)
                X(1) = -1.0D+0
                X(2) = -6.5465367070797709D-1
                X(3) = 0.0D+0
                X(4) = 6.5465367070797709D-1
                X(5) = 1.0D+0

                W(1) = 1.0000000000000001D-1
                W(2) = 5.444444444444444D-1
                W(3) = 7.1111111111111114D-1
                W(4) = 5.4444444444444462D-1
                W(5) = 1.0000000000000001D-1

              CASE(6)
                X(1) = -1.0D+0
                X(2) = -7.6505532392946474D-1
                X(3) = -2.852315164806451D-1
                X(4) = 2.852315164806451D-1
                X(5) = 7.6505532392946474D-1
                X(6) = 1.0D+0

                W(1) = 6.6666666666666666D-2
                W(2) = 3.7847495629784672D-1
                W(3) = 5.5485837703548657D-1
                W(4) = 5.5485837703548657D-1
                W(5) = 3.7847495629784694D-1
                W(6) = 6.6666666666666666D-2

              CASE(7)
                X(1) = -1.0D+0
                X(2) = -8.3022389627856696D-1
                X(3) = -4.6884879347071429D-1
                X(4) = 0.0D+0
                X(5) = 4.6884879347071429D-1
                X(6) = 8.3022389627856696D-1
                X(7) = 1.0D+0

                W(1) = 4.7619047619047616D-2
                W(2) = 2.7682604736156574D-1
                W(3) = 4.3174538120986261D-1
                W(4) = 4.8761904761904762D-1
                W(5) = 4.3174538120986261D-1
                W(6) = 2.7682604736156607D-1
                W(7) = 4.7619047619047616D-2

              CASE(8)
                X(1) = -1.0D+0
                X(2) = -8.7174014850960491D-1
                X(3) = -5.9170018143314462D-1
                X(4) = -2.0929921790247885D-1
                X(5) = 2.0929921790247885D-1
                X(6) = 5.9170018143314451D-1
                X(7) = 8.7174014850960513D-1
                X(8) = 1.0D+0

                W(1) = 3.5714285714285712D-2
                W(2) = 2.1070422714350615D-1
                W(3) = 3.4112269248350408D-1
                W(4) = 4.1245879465870428D-1
                W(5) = 4.1245879465870428D-1
                W(6) = 3.4112269248350435D-1
                W(7) = 2.1070422714350615D-1
                W(8) = 3.5714285714285712D-2

              CASE(9)
                X(1) = -1.0D+0
                X(2) = -8.9975799541145984D-1
                X(3) = -6.7718627951073818D-1
                X(4) = -3.631174638261781D-1
                X(5) = 0.0D+0
                X(6) = 3.6311746382617821D-1
                X(7) = 6.7718627951073807D-1
                X(8) = 8.9975799541145995D-1
                X(9) = 1.0D+0

                W(1) = 2.7777777777777776D-2
                W(2) = 1.6549536156080569D-1
                W(3) = 2.7453871250016099D-1
                W(4) = 3.4642851097304617D-1
                W(5) = 3.7151927437641724D-1
                W(6) = 3.4642851097304606D-1
                W(7) = 2.7453871250016132D-1
                W(8) = 1.654953615608056D-1
                W(9) = 2.7777777777777776D-2

              CASE(10)
                X(1) = -1.0D+0
                X(2) = -9.195339081664603D-1
                X(3) = -7.3877386510550336D-1
                X(4) = -4.7792494981044442D-1
                X(5) = -1.6527895766638703D-1
                X(6) = 1.6527895766638703D-1
                X(7) = 4.7792494981044453D-1
                X(8) = 7.3877386510550502D-1
                X(9) = 9.1953390816645864D-1
                X(10) = 1.0D+0

                W(1) = 2.2222222222222223D-2
                W(2) = 1.3330599085106998D-1
                W(3) = 2.2488934206312614D-1
                W(4) = 2.9204268367968328D-1
                W(5) = 3.2753976118389755D-1
                W(6) = 3.2753976118389755D-1
                W(7) = 2.9204268367968406D-1
                W(8) = 2.2488934206312591D-1
                W(9) = 1.3330599085107009D-1
                W(10) = 2.2222222222222223D-2

              CASE(11)
                X(1) = -1.0D+0
                X(2) = -9.3400143040805805D-1
                X(3) = -7.8448347366314708D-1
                X(4) = -5.6523532699620305D-1
                X(5) = -2.9575813558693925D-1
                X(6) = 0.0D+0
                X(7) = 2.9575813558693936D-1
                X(8) = 5.6523532699620271D-1
                X(9) = 7.8448347366314808D-1
                X(10) = 9.3400143040805716D-1
                X(11) = 1.0D+0

                W(1) = 1.8181818181818181D-2
                W(2) = 1.096122732669947D-1
                W(3) = 1.8716988178030528D-1
                W(4) = 2.4804810426402857D-1
                W(5) = 2.8687912477900762D-1
                W(6) = 3.0021759545569077D-1
                W(7) = 2.8687912477900812D-1
                W(8) = 2.4804810426402779D-1
                W(9) = 1.8716988178030508D-1
                W(10) = 1.0961227326699495D-1
                W(11) = 1.8181818181818181D-2

              CASE DEFAULT
                WRITE(*,*) "N should be in [2,11]."
                STOP

            END SELECT

        END SUBROUTINE LOB_NODES