! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

! This module contains a more readable version (in Fortran 2008)
! of the linear equation solver implemented as ACM's Algorithm 423

Module mlf_linalg
  Use ieee_arithmetic
  Use iso_c_binding
  IMPLICIT NONE
  PRIVATE

  Public :: DecompMatrix, SolveMatrix

  Interface DecompMatrix
    module procedure DecompMatrixDouble
    module procedure DecompMatrixComplex
  End Interface DecompMatrix

  Interface SolveMatrix
    module procedure SolveMatrixDouble
    module procedure SolveMatrixComplex
  End Interface SolveMatrix
Contains
   Integer Function DecompMatrixDouble(A, IP) Result(K)
    real(c_double), intent(inout) :: A(:,:)
    integer, intent(out) :: IP(:)
    integer :: N, M, J
    real(c_double) :: T
    logical :: P
    N = SIZE(A,2)
    IP(N) = 0
    P = .FALSE.
    Do K = 1, N-1
      M = K - 1 + MAXLOC(ABS(A(K:,K)), DIM = 1)
      IP(K) = M
      If(M /= K) Then
        P = .NOT. P
        T = A(M,K); A(M,K) = A(K,K); A(K,K) = T ! Swap A(K,K) and A(M,K)
      Endif
      If(A(K,K) == 0d0) RETURN
      A(K+1:,K) = -A(K+1:,K)/A(K,K)
      Do J = K+1, N
        T = A(M,J); A(M,J) = A(K,J); A(K,J) = T ! Swap A(M,J) and A(K,J)
        If(A(K,J) /= 0d0) A(K+1:,J) = A(K+1:,J)+A(K+1:,K)*A(K,J)
      End Do
    End Do
    If(A(N,N) /= 0d0) Then
      K = 0
      IP(N) = MERGE(-1, 1, P)
    Endif
  End Function DecompMatrixDouble

  Subroutine SolveMatrixDouble(A, B, IP)
    real(c_double), intent(in) :: A(:,:)
    real(c_double), intent(inout) :: B(:)
    integer, intent(in) :: IP(:)
    integer :: K, N, M
    real(c_double) :: T
    N = SIZE(A,2)
    Do K = 1, N-1
      M = IP(K)
      T = B(M); B(M) = B(K); B(K) = T ! Swap B(M) and B(K)
      B(K+1:) = B(K+1:) + A(K+1:,K)*B(K)
    End Do
    Do K = N, 2, -1
      B(K) = B(K)/A(K,K)
      B(:K-1) = B(:K-1) - A(:K-1, K)*B(K)
    End Do
    B(1) = B(1)/A(1,1)
  End Subroutine SolveMatrixDouble

  Integer Function DecompMatrixComplex(A, IP) Result(K)
    complex(KIND = 8), intent(inout) :: A(:,:)
    integer, intent(out) :: IP(:)
    integer :: N, M, J
    complex(KIND = 8) :: T
    logical :: P
    N = SIZE(A,2)
    IP(N) = 0
    P = .FALSE.
    Do K = 1, N-1
      M = K - 1 + MAXLOC(ABS(A(K:,K)), DIM = 1)
      IP(K) = M
      If(M /= K) Then
        P = .NOT. P
        T = A(M,K); A(M,K) = A(K,K); A(K,K) = T ! Swap A(K,K) and A(M,K)
      Endif
      If(ABS(A(K,K)) == 0d0) RETURN
      A(K+1:,K) = -A(K+1:,K)/A(K,K)
      Do J = K+1, N
        T = A(M,J); A(M,J) = A(K,J); A(K,J) = T ! Swap A(M,J) and A(K,J)
        If(A(K,J) /= 0d0) A(K+1:,J) = A(K+1:,J)+A(K+1:,K)*A(K,J)
      End Do
    End Do
    If(ABS(A(N,N)) > 0d0) Then
      K = 0
      IP(N) = MERGE(-1, 1, P)
    Endif
  End Function DecompMatrixComplex

  Subroutine SolveMatrixComplex(A, B, IP)
    complex(KIND = 8), intent(in) :: A(:,:)
    complex(KIND = 8), intent(inout) :: B(:)
    integer, intent(in) :: IP(:)
    integer :: K, N, M
    complex(KIND = 8) :: T
    N = SIZE(A,2)
    Do K = 1, N-1
      M = IP(K)
      T = B(M); B(M) = B(K); B(K) = T ! Swap B(M) and B(K)
      B(K+1:) = B(K+1:) + A(K+1:,K)*B(K)
    End Do
    Do K = N, 2, -1
      B(K) = B(K)/A(K,K)
      B(:K-1) = B(:K-1) - A(:K-1, K)*B(K)
    End Do
    B(1) = B(1)/A(1,1)
  End Subroutine SolveMatrixComplex

End Module mlf_linalg


FUNCTION julday(dd,mm,yyyy)
!
IMPLICIT NONE
!
! PARAMETER definitions
!
INTEGER,PARAMETER :: igreg = 15 + 31*(10+12*1582)
!
! Function arguments
!
INTEGER :: dd,mm,yyyy
INTEGER :: julday
!
! Local variables
!
REAL*8 :: dble
INTEGER :: int
INTEGER :: ja,jm,jy,y_nw
!
!     + + + purpose + + +
!     in this routine julday returns the julian day number which begins at
!     noon of the calendar date specified by day "dd", month "mm", & year "yyyy"
!     all are integer variables. positive year signifies a.d.; negative, b.c.
!     remember that the year after 1 b.c. was 1 a.d.

!     the following invalid calendar dates are checked for and reported:
!     1. zero year
!     2. dates between 4/10/1582 and 15/10/1582 are specified.
!
!     additional checking for other invalid dates could be added
!     in the future if necessary.
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!     dd - integer value of day in the range 1-31
!     julday - value returned by the julday function. debe added 09/09/09
!     mm - integer value of month in the range 1-12
!     yyyy - integer value of year (negative a.d., positive b.c.)
!
!     + + + parameters + + +
!     gregorian calendar was adopted on oct. 15, 1582.
!
!     + + + local variable definitions + + +
!     dble -
!     int -
!     ja -
!     jm -
!     jy -
!     y_nw -

!     + + + end specifications + + +
!
IF (yyyy.EQ.0) WRITE (*,*) 'there is no year zero'
IF ((yyyy.EQ.1582).AND.(mm.EQ.10).AND.(dd.LT.15).AND.(dd.GT.4)) WRITE (*,*)     &
   & 'this is an invalid date'
IF (yyyy.LT.0) THEN
  y_nw = yyyy + 1
ELSE
  y_nw = yyyy
END IF
IF (mm.GT.2) THEN
  jy = y_nw
  jm = mm + 1
ELSE
  jy = y_nw - 1
  jm = mm + 13
END IF
julday = int(365.25*jy) + int(30.6001*jm) + dd + 1720995
IF (dd+31*(mm+12*y_nw).GE.igreg) THEN
  ja = jy/100
!         ja=int(dble(0.01)*dble(jy))
  julday = julday + 2 - ja + int(dble(0.25)*dble(ja))
END IF
!
END FUNCTION julday

Project Documents/Source Code Original/Julday.f90


| Example of GCD algorithm:

: gcd ( a b -- gcd )
	0; tuck mod gcd ;

: .gcd ( a b -- )
	." GCD of "
	2dup . ." and " . ." is:"
	gcd . cr ;

100 80 .gcd
23 17 .gcd
64 12 .gcd
5 0 .gcd
bye


SUBROUTINE stencil(ain, aout)
      IMPLICIT NONE
      real(kind=8) :: ain(258,258,258)
      real(kind=8) :: aout(258,258,258)

      integer :: i,j,k

      do i=2,258-1
        do j=2,258-1
          do k=2,258-1
            aout(i,j,k) = ain(i,j,k) + (1.0_8/6.0_8) * ( ain(i+1,j,k) + &
                                         ain(i-1,j,k) + &
                                         ain(j+1,j,k) + &
                                         ain(j-1,j,k) + &
                                         ain(k+1,j,k) + &
                                         ain(k-1,j,k) )
          enddo
        enddo
      enddo

END SUBROUTINE


PROGRAM quad_surf
! Fit a quadratic surface to a set of data

USE lsq
IMPLICIT NONE
INTEGER              :: iostatus, n, ier, row, col
INTEGER, PARAMETER   :: nmax = 100
REAL (dp), PARAMETER :: wt = 1.0_dp
REAL (dp)            :: rh, temp, yval, x(nmax,5), y(nmax), xrow(0:5), b(0:5), &
                        yfit(3)

OPEN(UNIT=8, FILE='dry_bulb.dat', STATUS='OLD')
n = 0
CALL startup(5, .TRUE.)
DO
  READ(8, *, IOSTAT=iostatus) rh, temp, yval
  IF (iostatus < 0) EXIT
  IF (iostatus > 0) CYCLE
  n = n + 1
  rh = rh - 70._dp
  temp = temp - 95._dp
  y(n) = yval
  x(n,1) = rh
  x(n,2) = temp
  x(n,3) = rh**2
  x(n,4) = rh*temp
  x(n,5) = temp**2
  xrow(1:5) = x(n,:)
  xrow(0) = 1.0_dp
  CALL includ(wt, xrow, y(n))
END DO

CALL regcf(b, 6, ier)
WRITE(*, *) 'Fitted quadratic surface:'
WRITE(*, '(a, 2f8.3, a, f8.4, a, f8.4, a, f8.4, a, f8.4, a)')  &
         ' Y = ', b(0), b(1), '*X1 ', b(2), '*X2 ', b(3), '*X1^2 ',  &
         b(4), '*X1*X2 ', b(5), '*X2^2'
WRITE(*, *)
WRITE(*, *) 'Fitted values:'
WRITE(*, *) '   %RH          90       95      100'
WRITE(*, *) '-------------------------------------'
DO row = 1, 4
  xrow(0) = 1.0_dp
  xrow(1) = 20.0 - 10.0*row
  xrow(3) = xrow(1)**2
  DO col = 1, 3
    xrow(2) = -10.0 + 5.0*col
    xrow(4) = xrow(1)*xrow(2)
    xrow(5) = xrow(2)**2
    yfit(col) = DOT_PRODUCT( b, xrow )
  END DO
  WRITE(*, '(f8.0, "   ", 3f9.1)') xrow(1) + 70., yfit
END DO

STOP
END PROGRAM quad_surf


module initial_conditions_mod
  use physical_params_mod
  use field_mod
  implicit none
  private

  !> Amplitude of initial oscillations in stream function
  !! Used by invoke_init_stream_fn_kernel()
  REAL(go_wp), PARAMETER :: A = 1.0D6
  !> 2PI/{m,n}
  REAL(go_wp), SAVE  :: di, dj

  PUBLIC init_initial_condition_params
  PUBLIC invoke_init_stream_fn_kernel
  PUBLIC init_pressure
  PUBLIC init_velocity_u
  PUBLIC init_velocity_v

CONTAINS

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

  !> \brief Set-up parameters related to the model domain which
  !! are stored in this module. We could compute these on the
  !! fly in init_stream_fn_code() and init_pressure() and
  !! rely on compiler magic to make sure they're not
  !! recomputed for every grid point.
  SUBROUTINE init_initial_condition_params(pfld)
    IMPLICIT none
    type(r2d_field), intent(in) :: pfld

    di = TPI/pfld%internal%nx
    dj = TPI/pfld%internal%ny

  END SUBROUTINE init_initial_condition_params

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

  subroutine invoke_init_stream_fn_kernel(psifld)
    implicit none
    type(r2d_field), intent(inout) :: psifld
    ! Locals
    integer :: idim1, idim2
    integer :: i, j

    idim1 = SIZE(psifld%data, 1)
    idim2 = SIZE(psifld%data, 2)

    ! Loop over 'columns'
    DO J=1, idim2
      DO I=1, idim1

        CALL init_stream_fn_code(i, j, psifld%data)

      END DO
    END DO

  CONTAINS

    SUBROUTINE init_stream_fn_code(i, j, psi)
      IMPLICIT none
      !> The grid point (column) to act on
      INTEGER,      INTENT(in)                  :: i, j
      !> Array holding the stream function values
      REAL(KIND=8), INTENT(out), DIMENSION(:,:) :: psi

      ! di = 2Pi/(Extent of mesh in x)
      ! dj = 2Pi/(Extent of mesh in y)
      ! Original code:
      !      PSI(I,J) = A*SIN((I-.5d0)*DI)*SIN((J-.5d0)*DJ)
      ! Psi is on F points. Our first internal F point is at 3,3
      ! rather than 2,2 so shift appropriately.
      PSI(I,J) = A*SIN((I-1.5d0)*DI)*SIN((J-1.5d0)*DJ)

    END SUBROUTINE init_stream_fn_code

  END SUBROUTINE invoke_init_stream_fn_kernel

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

  SUBROUTINE init_pressure(pfld)
    IMPLICIT none
    type(r2d_field), target, intent(inout) :: pfld
    REAL(KIND=go_wp), DIMENSION(:,:), pointer :: p
    ! Locals
    INTEGER :: i, j, idim1, idim2
    !> Extent in x of model domain
    REAL(go_wp) :: el
    !> Computed amplitude of initial oscillations in
    !! pressure field.
    REAL(go_wp) :: pcf

    p => pfld%data

    EL = pfld%internal%nx * pfld%grid%dx
    PCF = PI*PI*A*A/(EL*EL)

    idim1 = SIZE(pfld%data, 1)
    idim2 = SIZE(pfld%data, 2)

    ! di = 2Pi/(Extent of mesh in x) where extent is from namelist
    ! dj = 2Pi/(Extent of mesh in y)   "     "     "   "     "
    DO J=1,idim2
       DO I=1, idim1
! Original code:
!          P(I,J) = PCF*(COS(2.0d0*(I-1)*DI)   &
!               +COS(2.0d0*(J-1)*DJ))+50000.d0
! Our first internal T pt is at 2,2 rather than 1,1 so we shift
! the expression appropriately:
          P(I,J) = PCF*(COS(2.0d0*(I-2)*DI)   &
               +COS(2.0d0*(J-2)*DJ))+50000.d0
       END DO
    END DO

  END SUBROUTINE init_pressure

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

  subroutine init_velocity_u(ufld, psifld)
    implicit none
    ! The horizontal velocity field to initialise
    type(r2d_field), intent(inout), target :: ufld
    ! The stream function used in the initialisation
    type(r2d_field), intent(in),    target :: psifld
    ! Locals
    real(kind=go_wp), pointer, dimension(:,:) :: u, psi
    integer  :: j
    real(go_wp) :: dy

    u => ufld%data
    psi => psifld%data

    ! dy is a property of the mesh
    dy = ufld%grid%dy

    do J=1,ufld%internal%ystop
       U(:,J) = -(PSI(:,j+1) - PSI(:,j))/dy
    end do

  end subroutine init_velocity_u

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

  SUBROUTINE init_velocity_v(vfld, psifld)
    implicit none
    ! The vertical velocity field to initialise
    type(r2d_field), intent(inout), target :: vfld
    ! The stream function used in the initialisation
    type(r2d_field), intent(in),    target :: psifld
    ! Locals
    real(kind=go_wp), pointer, dimension(:,:) :: v, psi
    integer  :: I
    real(go_wp) :: dx

    v => vfld%data
    psi => psifld%data

    dx = vfld%grid%dx

    do I=1, vfld%internal%xstop
       v(I,:) = (psi(i+1,:) - psi(i,:))/dx
    end do

  end subroutine init_velocity_v

end module initial_conditions_mod


avg1 = mean(x)
avg2 = mean(y)
res = SUM((x(:) - avg1)*(y(:) - avg2))
res = res / REAL(SIZE(x)-1,prec)


program Sierpinski_triangle
  implicit none

  call Triangle(4)

contains

subroutine Triangle(n)
  implicit none
  integer, parameter :: i64 = selected_int_kind(18)
  integer, intent(in) :: n
  integer :: i, k
  integer(i64) :: c

  do i = 0, n*4-1
    c = 1
    write(*, "(a)", advance="no") repeat(" ", 2 * (n*4 - 1 - i))
    do k = 0, i
      if(mod(c, 2) == 0) then
        write(*, "(a)", advance="no") "    "
      else
        write(*, "(a)", advance="no") "  * "
      end if
      c = c * (i - k) / (k + 1)
    end do
    write(*,*)
  end do
end subroutine Triangle
end program Sierpinski_triangle


PROGRAM me1xb

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =========================================================
!       Purpose: This program computes the exponential integral
!                E1(x) using subroutine E1XB
!       Input :  x  --- Argument of E1(x)  ( x > 0 )
!       Output:  E1 --- E1(x)
!       Example:
!                  x          E1(x)
!                -------------------------
!                 0.0     .1000000000+301
!                 1.0     .2193839344E+00
!                 2.0     .4890051071E-01
!                 3.0     .1304838109E-01
!                 4.0     .3779352410E-02
!                 5.0     .1148295591E-02
!       =========================================================

DOUBLE PRECISION :: e1,x
WRITE(*,*)'Please enter x '
!        READ(*,*) X
x=5.0
WRITE(*,*)'   x          E1(x)'
WRITE(*,*)' -------------------------'
CALL e1xb(x,e1)
WRITE(*,10)x,e1
10      FORMAT(1X,f5.1,e20.10)
END PROGRAM me1xb

SUBROUTINE e1xb(x,e1)

!       ============================================
!       Purpose: Compute exponential integral E1(x)
!       Input :  x  --- Argument of E1(x)
!       Output:  E1 --- E1(x)  ( x > 0 )
!       ============================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: e1
IMPLICIT DOUBLE PRECISION (a-h,o-z)
IF (x == 0.0) THEN
  e1=1.0D+300
ELSE IF (x <= 1.0) THEN
  e1=1.0D0
  r=1.0D0
  DO  k=1,25
    r=-r*k*x/(k+1.0D0)**2
    e1=e1+r
    IF (DABS(r) <= DABS(e1)*1.0D-15) EXIT
  END DO
  15         ga=0.5772156649015328D0
  e1=-ga-DLOG(x)+x*e1
ELSE
  m=20+INT(80.0/x)
  t0=0.0D0
  DO  k=m,1,-1
    t0=k/(1.0D0+k/(x+t0))
  END DO
  t=1.0D0/(x+t0)
  e1=DEXP(-x)*t
END IF
RETURN
END SUBROUTINE e1xb


C   File: array-to-func_02.f
C   This test is an example of passing arrays to a function (subroutine)
C   as arguments twice. In other words, the arrays are declared in the
C   main and passed to subroutine (function) gillespie to
C   update_mean_var.
C
C   The code was sampled from SIR-Gillespie.f

      subroutine update_mean_var(meanS, varS, k, n, runs)
      integer, parameter :: Tmax = 100
      double precision, dimension(0:Tmax) :: meanS, varS
      integer k, n, runs

      meanS(k) = meanS(k) + (n - meanS(k))/(runs+1)
      varS(k) = varS(k) + runs/(runs+1) * (n-meanS(k))*(n-meanS(k))

      return
      end subroutine update_mean_var

      subroutine gillespie(meanS, varS)
      integer, parameter :: Tmax = 100, k = 0, n = 0, runs = 50
      double precision, dimension(0:Tmax) :: meanS, varS

      meanS(k) = 100
      varS(k) = 200
      call update_mean_var(meanS, varS, k, n, runs)

      end subroutine gillespie

      program main
      implicit none

      integer, parameter :: Tmax = 100
      double precision, dimension(0:Tmax) :: meanS, varS

      call gillespie(meanS, varS)

      end program main


*DECK DRJ
      DOUBLE PRECISION FUNCTION DRJ (X, Y, Z, P, IER)
C***BEGIN PROLOGUE  DRJ
C***PURPOSE  Compute the incomplete or complete (X or Y or Z is zero)
C            elliptic integral of the 3rd kind.  For X, Y, and Z non-
C            negative, at most one of them zero, and P positive,
C             RJ(X,Y,Z,P) = Integral from zero to infinity of
C                              -1/2     -1/2     -1/2     -1
C                    (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RJ-S, DRJ-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRJ
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRJ(X,Y,Z,P) = Integral from zero to infinity of
C
C                                -1/2     -1/2     -1/2     -1
C                      (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt,
C
C          where X, Y, and Z are nonnegative, at most one of them is
C          zero, and P is positive.  If X or Y or Z is zero, the
C          integral is COMPLETE.  The duplication theorem is iterated
C          until the variables are nearly equal, and the function is
C          then expanded in Taylor series to fifth order.
C
C
C   2.     Calling Sequence
C          DRJ( X, Y, Z, P, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C          Z      - Double precision, nonnegative variable
C
C          P      - Double precision, positive variable
C
C
C          On  Return    (values assigned by the DRJ routine)
C
C          DRJ     - Double precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z, P are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the DRJ routine
C
C              Value assigned         Error Message printed
C              IER = 1                MIN(X,Y,Z) .LT. 0.0D0
C                  = 2                MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM
C                  = 3                MAX(X,Y,Z,P) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C
C          LOLIM and UPLIM determine the valid range of X, Y, Z, and P
C
C          LOLIM is not less than the cube root of the value
C          of LOLIM used in the routine for DRC.
C
C          UPLIM is not greater than 0.3 times the cube root of
C          the value of UPLIM used in the routine for DRC.
C
C
C                     Acceptable values for:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   2.0D-26     3.0D+24
C                     CDC 6000/7000 SERIES :   5.0D-98     3.0D+106
C                     UNIVAC 1100 SERIES   :   5.0D-103    6.0D+101
C                     CRAY                 :   1.32D-822   1.4D+821
C                     VAX 11 SERIES        :   2.5D-13     9.0D+11
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 the value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C
C          Relative error due to truncation of the series for DRJ
C          is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    4.0D-18
C                           3.0D-3    3.0D-15
C                           1.0D-2    4.0D-12
C                           3.0D-2    3.0D-9
C                           1.0D-1    4.0D-6
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRJ Special Comments
C
C
C     Check by addition theorem: DRJ(X,X+Z,X+W,X+P)
C     + DRJ(Y,Y+Z,Y+W,Y+P) + (A-B) * DRJ(A,B,B,A) + 3.0D0 / SQRT(A)
C     = DRJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y
C     = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y),
C     and B - A = P * (P-Z) * (P-W).  The sum of the third and
C     fourth terms on the left side is 3.0D0 * DRC(A,B).
C
C
C          On Input:
C
C     X, Y, Z, and P are the variables in the integral DRJ(X,Y,Z,P).
C
C
C          On Output:
C
C
C          X, Y, Z, P are unaltered.
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C    -------------------------------------------------------------------
C
C
C   Special double precision functions via DRJ and DRF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 3rd kind
C                  -----------------------------------------
C
C
C                          PHI         2         -1
C             P(PHI,K,N) = INT (1+N SIN (THETA) )   *
C                           0
C
C
C                                  2    2         -1/2
C                             *(1-K  SIN (THETA) )     D THETA
C
C
C                                           2          2   2
C                        = SIN (PHI) DRF(COS (PHI), 1-K SIN (PHI),1)
C
C                                   3             2         2   2
C                         -(N/3) SIN (PHI) DRJ(COS (PHI),1-K SIN (PHI),
C
C                                  2
C                         1,1+N SIN (PHI))
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind
C                  -----------------------------------------
C
C
C                                            2 2    2
C                  EL3(X,KC,P) = X DRF(1,1+KC X ,1+X ) +
C
C                                            3           2 2    2     2
C                               +(1/3)(1-P) X  DRJ(1,1+KC X ,1+X ,1+PX )
C
C
C                                           2
C                  CEL(KC,P,A,B) = A RF(0,KC ,1) +
C
C
C                                                      2
C                                 +(1/3)(B-PA) DRJ(0,KC ,1,P)
C
C
C                  Heuman's LAMBDA function
C                  -----------------------------------------
C
C
C                                2                      2      2    1/2
C                  L(A,B,P) =(COS (A)SIN(B)COS(B)/(1-COS (A)SIN (B))   )
C
C                                            2         2       2
C                            *(SIN(P) DRF(COS (P),1-SIN (A) SIN (P),1)
C
C                                 2       3            2       2
C                            +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B))))
C
C                                    2         2       2
C                            *DRJ(COS (P),1-SIN (A) SIN (P),1,1-
C
C                                2       2          2       2
C                            -SIN (A) SIN (P)/(1-COS (A) SIN (B))))
C
C
C
C                  (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) =
C
C                   2                         2       2    -1/2
C              = COS (A)  SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2                  2       2
C                 *DRF(0,COS (A),1) + (1/3) SIN (A) COS (A)
C
C                                      2       2    -3/2
C                 *SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2         2       2          2       2
C                 *DRJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B)))
C
C
C                  Jacobi ZETA function
C                  -----------------------------------------
C
C                        2                     2   2    1/2
C             Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B))
C
C
C                                  2      2   2                 2
C                        *DRJ(0,1-K ,1,1-K SIN (B)) / DRF (0,1-K ,1)
C
C
C  ---------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, DRC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC)).
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRJ
      INTEGER IER
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7
      DOUBLE PRECISION ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3
      DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION LAMDA, MU, P, PN, PNDEV
      DOUBLE PRECISION POWER4, DRC, SIGMA, S1, S2, S3, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRJ
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0)
         LOLIM  = (5.0D0 * D1MACH(1))**(1.0D0/3.0D0)
         UPLIM  = 0.30D0*( D1MACH(2) / 5.0D0)**(1.0D0/3.0D0)
C
         C1 = 3.0D0/14.0D0
         C2 = 1.0D0/3.0D0
         C3 = 3.0D0/22.0D0
         C4 = 3.0D0/26.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRJ = 0.0D0
      IF (MIN(X,Y,Z).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'DRJ',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z,P).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRJ',
     *      'MAX(X,Y,Z,P).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 //
     *      ' AND UPLIM = ' // XERN7, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'RJ',
     *      'MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = '  // XERN5 // ' P = ' // XERN6 //
     *      ' AND LOLIM = ', 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.0D0
      POWER4 = 1.0D0
C
   30 MU = (XN+YN+ZN+PN+PN)*0.20D0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      PNDEV = (MU-PN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT
      ALFA = ALFA*ALFA
      BETA = PN*(PN+LAMDA)*(PN+LAMDA)
      SIGMA = SIGMA + POWER4*DRC(ALFA,BETA,IER)
      POWER4 = POWER4*0.250D0
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      PN = (PN+LAMDA)*0.250D0
      GO TO 30
C
   40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV
      EB = XNDEV*YNDEV*ZNDEV
      EC = PNDEV*PNDEV
      E2 = EA - 3.0D0*EC
      E3 = EB + 2.0D0*PNDEV*(EA-EC)
      S1 = 1.0D0 + E2*(-C1+0.750D0*C3*E2-1.50D0*C4*E3)
      S2 = EB*(0.50D0*C2+PNDEV*(-C3-C3+PNDEV*C4))
      S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC
      DRJ = 3.0D0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU))
      RETURN
      END


      SUBROUTINE DHTGEN (MODE,LPIVOT,L1,M,U,LDU,COLU,UPARAM,
     *                   C,LDC,NVC,COLC)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DHTGEN Krogh Added external statement.
C>> 1994-11-11 DHTGEN Krogh Declared all vars.
C>> 1994-10-20 DHTGEN Krogh Changes to use M77CON
C>> 1987-08-19 DHTGEN Lawson Initial code.
c--D replaces "?": ?HTGEN, ?AXPY, ?DOT, ?NRM2
c
C        Construction and/or application of a single Householder
C     transformation..     Q = I + U*(U**T)/b
c     where I is the MxM identity matrix, b is a scalar, and U is an
c     M-dimensional Householder vector.
c        All vectors are M-vectors but only the components in positions
c     LPIVOT, and L1 through M, will be referenced.
c        This version, identified by GEN at the end of its name,
c     has the GENerality to handle the options of the U-vector being
c     stored either as a column or row of a matrix, and the vectors in
c     C() may be either column or row vectors.
c     ------------------------------------------------------------------
C                         Subroutine arguments
c
C     MODE  [in]  = 1 OR 2   When MODE = 1 this subr determines the
c           parameters for a Householder transformation and applies
c           the transformation to NVC vectors.  When MODE = 2 this
c           subr applies a previously determined Householder
c           transformation.
C     LPIVOT  [in]  The index of the pivot element.
C     L1,M  [in]  If L1 .le. M  elements LPIVOT and L1 through M will
c           be referenced.  If L1 .gt. M the subroutine returns
c           immediately.  This may be regarded
c           as performing an identity transformation.
C     U()  [inout]  Contains the "pivot" vector.  Typically U() will be
c           a two-dimensional array in the calling program and the pivot
c           vector may be either a column or row in this array.
c           When MODE = 1 this is the vector from which Householder
c           parameters are to be determined.
c           When MODE = 2 this is the result from previous computation
c           with MODE = 1.
c     LDU  [in]  Leading dimensioning parameter for U() in the calling
c           program where U() is a two-dimensional array.  Gives
c           storage spacing between elements in a row of U() when U() is
c           regarded as a two-dimensional array.
C     COLU  [in]  True means the pivot vector is a column of the 2-dim
c           array U().  Thus the successive elements of the pivot vector
c           are at unit storage spacing.
c           False means the pivot vector is a row of the 2-dim array U()
c           Thus the storage spacing between successive elements is LDU.
c     UPARAM  [inout]  Holds a value that supplements the contents
c           of U() to complete the definition of a
c           Householder transformation.  Computed when MODE = 1 and
c           reused when MODE = 2.
c           UPARAM is the pivot component of the Householder U-vector.
C     C()  [inout]   On entry contains a set of NVC M-vectors to which a
c          Householder transformation is to be applied.
c          On exit contains the set of transformed vectors.
c          Typically in the calling program C() will be a 2-dim array
c          with leading dimensioning parameter LDC.
C          These vectors are the columns of an M x NVC matrix in C(,) if
c          COLC = true, and are rows of an NVC x M matrix in C(,) if
c          COLC = false.
C     LDC  [in]  Leading dimension of C(,).  Require LDC .ge. M if
c           COLC = true.  Require LDC .ge. NVC if COLC = false.
C     NVC  [in]  Number of vectors in C(,) to be transformed.
c           If NVC .le. 0 no reference will be made to the array C(,).
c     COLC  [in]  True means the transformations are to be applied to
c           columns of the array C(,).  False means the transformations
c           are to be applied to rows of the array C(,).
c     ------------------------------------------------------------------
c     Subprograms referenced: DAXPY, DDOT, DNRM2
c     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb, 1985, C. L. Lawson & S. Y. Chan, JPL.  Adapted code from the
c     Lawson & Hanson book to Fortran 77 for use in the JPL MATH77
c     library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     July, 1987. CLL.  Changed user interface so method of specifying
c     column/row storage options is more language-independent.
C     ------------------------------------------------------------------
      external DDOT, DNRM2
      double precision U(*), UPARAM, C(*), DDOT, DNRM2
      double precision B, FAC, HOLD, VNORM, ONE, ZERO, SUM, BINV
      integer MODE, LPIVOT, L1, M, LDU, LDC, NVC
      integer IUPIV, IUL1, IUINC, IUL0
      integer ICE, ICV, I2, I3, INCR, NTERMS, J
      logical COLU, COLC
      parameter (ONE = 1.0D0, ZERO = 0.0D0)
C     ------------------------------------------------------------------
      if (0.ge.LPIVOT .or. LPIVOT.ge.L1 .or. L1.gt.M) return
      if(COLU) then
         IUPIV = LPIVOT
         IUL1 = L1
         IUINC = 1
      else
         IUPIV = 1 + LDU * (LPIVOT-1)
         IUL1 = 1 + LDU * (L1-1)
         IUINC =  LDU
      endif
c
      if( MODE .eq. 1) then
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
         IUL0 = IUL1 - IUINC
         if(IUL0 .eq. IUPIV) then
            VNORM = DNRM2(M-L1+2, U(IUL0), IUINC)
         else
            HOLD = U(IUL0)
            U(IUL0) = U(IUPIV)
            VNORM = DNRM2(M-L1+2, U(IUL0), IUINC)
            U(IUL0) = HOLD
         endif
c
         if (U(IUPIV) .gt. ZERO) VNORM = -VNORM
         UPARAM = U(IUPIV)-VNORM
         U(IUPIV) = VNORM
      endif
C            ****** Apply the transformation  I + U*(U**T)/B  to C. ****
C
      if (NVC.LE.0) return
      B = UPARAM * U(IUPIV)
c                                 Here B .le. 0.  If B  =  0., return.
      if (B .eq. ZERO) return
      BINV = ONE / B
c                                  I2 = 1 - ICV + ICE*(LPIVOT-1)
c                                  INCR = ICE * (L1-LPIVOT)
      if(COLC) then
         ICE = 1
         ICV = LDC
         I2 = LPIVOT - LDC
         INCR = L1 - LPIVOT
      else
         ICE = LDC
         ICV = 1
         I2 = ICE*(LPIVOT-1)
         INCR = ICE*(L1-LPIVOT)
      endif
c
      NTERMS = M-L1+1
      do 120 J = 1,NVC
         I2 = I2 + ICV
         I3 = I2 + INCR
         SUM = UPARAM * C(I2) + DDOT(NTERMS, U(IUL1),IUINC, C(I3),ICE)
         if (SUM .ne. ZERO) then
            FAC = SUM*BINV
            C(I2) = C(I2) + FAC*UPARAM
            call DAXPY(NTERMS, FAC, U(IUL1),IUINC, C(I3),ICE)
         endif
  120 continue
      return
      end


PROGRAM binary_integer
IMPLICIT NONE
  INTEGER  i, number, terms(32) ! storage of a0, a1, etc, up to 32 bits

  WRITE(*,*) 'Give a number to transform to binary notation'
  READ(*,*) number
! Initialise the terms a0, a1 etc
  terms = 0
! Fortran takes only integer loop variables
  DO i=0, 31
     terms(i) = MOD(number,2)
     number = number/2
  ENDDO
! write out results
  WRITE(*,*) 'Binary representation '
  DO i=0, 31
    WRITE(*,*)' Term nr and value', i, terms(i)
  ENDDO

END PROGRAM binary_integer


MODULE GS

   CONTAINS

   SUBROUTINE GaussSeidel_UV2( A, u, b, t, rb, fator)

       USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(INOUT) :: u
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: b
       INTEGER, INTENT(IN) :: t, rb
       DOUBLE PRECISION, INTENT(IN) :: fator

       INTEGER :: p, pp, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm, correcao ! Soma dos componentes do stencil
       INTEGER :: linha, inicio, new_rb

       new_rb = (1 + rb)/2
       inicio = ABS(MOD(t,2) - new_rb )

              DO pp = 1 + inicio, A % Nx * A % Ny, 2

                   ! Calculando a linha de p
                   linha = (pp-1)/(A % Nx) + 1

                   ! Fazendo a correcao do caso Nx par (black points sao pares ao inves de impares)
                   p = pp + MOD(linha + 1, 2)*MOD(A % Nx + 1, 2)*(1 - 2*inicio)

                   ! Obtendo o stencil do volume
                   stencil = A % v(p)

                   ! Para cada coeficiente do stencil da matriz
                   ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
                   ! e definido como
                   ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
                   ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
                   sm = 0.0d0
                   DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

                       ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
                       ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
                       ! Logo
                       ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

                       ax = A % s(stencil) % c(se)
                       ux = u(p + A % s(stencil) % p(se), t+1)

                       sm = sm +  ax * ux

                   END DO

                  ! Obtendo o ap
                  ax = A % s(stencil) % c(1)
                  sm  = sm + u(p, t) * fator

                  ! Somando b(p) e divindo por ap para completar o Gauss-Seidel
                  u(p, t+1) = (sm + b(p, t))/ax

              END DO

   END SUBROUTINE GaussSeidel_UV2

   SUBROUTINE GaussSeidel_UV( A, u, b, t, rb)

       USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(INOUT) :: u
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: b
       INTEGER, INTENT(IN) :: t, rb

       INTEGER :: p, pp, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm, correcao ! Soma dos componentes do stencil
       INTEGER :: linha, inicio, new_rb

       new_rb = (1 + rb)/2
       inicio = ABS(MOD(t,2) - new_rb )

              DO pp = 1 + inicio, A % Nx * A % Ny, 2

                   ! Calculando a linha de p
                   linha = (pp-1)/(A % Nx) + 1

                   ! Fazendo a correcao do caso Nx par (black points sao pares ao inves de impares)
                   p = pp + MOD(linha + 1, 2)*MOD(A % Nx + 1, 2)*(1 - 2*inicio)

                   ! Obtendo o stencil do volume
                   stencil = A % v(p)

                   ! Para cada coeficiente do stencil da matriz
                   ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
                   ! e definido como
                   ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
                   ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
                   sm = 0.0d0
                   DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

                       ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
                       ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
                       ! Logo
                       ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

                       ax = A % s(stencil) % c(se)
                       ux = u(p + A % s(stencil) % p(se), t+1)

                       sm = sm +  ax * ux

                   END DO

                  ! Obtendo o ap
                  ax = A % s(stencil) % c(1)
                  sm  = sm + u(p, t)

                  ! Somando b(p) e divindo por ap para completar o Gauss-Seidel
                  u(p, t+1) = (sm + b(p, t))/ax

              END DO

   END SUBROUTINE GaussSeidel_UV

   SUBROUTINE GaussSeidel( A, u, b, iteracoes )

       USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: u
       DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: b
       INTEGER, INTENT(IN) :: iteracoes

       INTEGER :: p, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm ! Soma dos componentes do stencil

       DO ite = 1, iteracoes

           DO p = 1, A % Nx * A % Ny

               ! Obtendo o stencil do volume
               stencil = A % v(p)

               ! Para cada coeficiente do stencil da matriz
               ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
               ! e definido como
               ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
               ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
               sm = 0.0d0
               DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

                   ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
                   ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
                   ! Logo
                   ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

                   ax = A % s(stencil) % c(se)
                   ux = u(p + A % s(stencil) % p(se))

                   sm = sm +  ax * ux

                   !if (A % s(stencil) % p(se) .eq. -1) then
                   !write(*,*) p, ax, A % s(stencil) % p(se)
                   !end if

               END DO

               ! Obtendo o ap
               ax = A % s(stencil) % c(1)

               ! Somando b(p) e divindo por ap para completar o Gauss-Seidel
               u(p) = (sm + b(p))/ax

           END DO
           !call exit()

       END DO

   END SUBROUTINE GaussSeidel

END MODULE GS


      subroutine DSTAT1(XTAB, NX, STATS, IHIST, NCELLS, X1, X2)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1997-04-25 DSTAT1 Krogh Simplified code (WVS suggestion)
C>> 1994-11-11 DSTAT1 Krogh Declared all vars.
C>> 1994-10-20 DSTAT1 Krogh Changes to use M77CON
C>> 1989-10-20 DSTAT1 CLL
C>> 1987-05-01 DSTAT1 Lawson  Initial code.
c--D replaces "?": ?STAT1, ?STAT2
c
c        This subr computes basic statistics for X, storing them is
c     STATS() as follows:
c
c             STATS(1) = Total count
c             STATS(2) = Min
c             STATS(3) = Max
c             STATS(4) = Mean
c             STATS(5) = Standard deviation
c
c     This subr also accumulates counts in IHIST() to develop a
c     histogram of values of X.
c
c        The data to be treated is given in XTAB(1:NX).  If the
c     value of STATS(1) on entry is positive , say = COUNT, it is
c     assumed that COUNT data values have been processed previously
c     and results from that processing are in IHIST() and STATS().
c     These results will be updated to reflect the additional set of
c     NX values.
c
c        Alternatively, if STATS(1) is zero, the initial contents of
c     STATS(2:5) and IHIST() will be ignored and results will be
c     computed just for the present data set XTAB(1:NX).
c
c        The user must specify the range and resolution of the histogram
c     by setting X1, X2, and NCELLS.  The end cells, IHIST(1) and
c     IHIST(NCELLS) will be used to count occurences of X less than X1
c     or greater than X2 respectively.
c     The cells IHIST(2) through IHIST(NCELLS-1) will
c     be used to count occurences of X in NCELLS-2 equal-length
c     subintervals of [X1, X2].
c
c        Define h = (X2 - X1)/(NCELLS-2).  X-intervals will be
c     associated with elements of IHIST() as follows.
c
c          X interval                   Counting cell
c
c          (-Infinity, X1)              IHIST(1)
c          [X1+(i-2)*h, X1+(i-1)*h)     IHIST(i), i = 2,...,NCELLS-2
c          [X2-h, X2]                   IHIST(NCELLS-1)
c          (X2, Infinity)               IHIST(NCELLS)
c
c        After use of this subroutine, the user can call
c     DSTAT2, to produce a printer-plot of the histogram and print the
c     statistics.
c
c        Remark:  It is more efficient to call this subroutine one
c     time giving it N points rather than calling it N times giving it
c     one point each time, but the results will be the same to within
c     arithmetic limitations either way.
c     ------------------------------------------------------------------
c                    Subroutine arguments
c
c     XTAB()  [in]  Array of NX values whose statistics are to be
c           computed.
c     NX     [in]  Number of values given in XTAB().
c           Require NX .ge. 1.
c     STATS()  [inout]  Array of length 5 into which statistics are or
c           will be stored.  Initial value of STATS(1) must be positive
c           if IHIST() and STATS() contain prior results that are to be
c           updated.  Otherwise the initial value of STATS(1) must be
c           zero.
c     IHIST()  [inout]  Integer array of length at least NCELLS into
c           which counts will be accumulated.
c     NCELLS   [in]  Total number of classification regions.
c           Require NCELLS .ge. 3.
c     X1,X2  [in]  Lower and upper boundaries, respectively defining
c           the range of y values to be classified into NCELLS-2 equal
c           intervals.  Require X1 < X2.
c     ------------------------------------------------------------------
c        The value of FAC is not critical.  It should be greater than
c     one.  The program does less computation each time the test
c     (abs(DELTA) .lt. TEST) is satisfied.  It will be true more
c     frequently if FAC is larger.  There is probably not much advantage
c     in setting FAC larger than 4, so 64 is probably more than ample.
c     ------------------------------------------------------------------
c     C. L. Lawson and S. Y. Chiu, JPL, Apr 1987.
C     1989-10-20 CLL Moved integer declaration earlier to avoid warning
c     msg from Cray compiler.
c     ------------------------------------------------------------------
      integer NCELLS, NX
      integer IHIST(NCELLS)
      integer I, INDEX, J
      double precision COUNT, DELTA, FAC, PREV
      double precision SCALE, RSCALE, SCLNEW, STATS(5), SUMSCL
      double precision TEMP, TEST, X, X1, X2, XMAX, XMEAN, XMIN
      double precision XTAB(NX)
      parameter(FAC = 64.0D0)
c     ------------------------------------------------------------------
      if(NX .lt. 1) return
      COUNT = STATS(1)
      if(COUNT .eq. 0.D0) then
         do 10 I=1,NCELLS
            IHIST(I) = 0
   10    continue
c
c                    Begin: Special for first point
c
         PREV = 0.D0
         X = XTAB(1)
         XMIN = X
         XMAX = X
         XMEAN = 0.D0
         TEST = -1.0D0
         SUMSCL = 0.D0
c                    End: Special for first point
c
      else
c                    Here when COUNT is > zero on entry.
         XMIN = STATS(2)
         XMAX = STATS(3)
         XMEAN = STATS(4)
c
         if(STATS(5) .eq. 0.D0) then
            TEST = -1.0D0
            SUMSCL = 0.D0
         else
c
c              STATS(5) contains the old value of Sigma.  Since it is
c              nonzero (positive) here, COUNT must be at least 2.
c
            SCALE =  STATS(5)
            RSCALE = 1.0D0/SCALE
            TEST = FAC * SCALE
            SUMSCL = COUNT - 1.0D0
         endif
      endif
c
      do 30 J = 1, NX
         PREV = COUNT
         COUNT = COUNT + 1.0D0
         X = XTAB(J)
         XMIN = min(X, XMIN)
         XMAX = max(X, XMAX)
c        .                             Begin: Tally in histogram.
         if(X .lt. X1) then
            IHIST(1) = IHIST(1) + 1
         elseif(X .gt. X2) then
            IHIST(NCELLS) = IHIST(NCELLS) + 1
         else
c                          Following stmt converts integer to float.
            TEMP = NCELLS-2
c                          Following stmt converts float to integer.
            INDEX = TEMP*(X-X1)/(X2-X1)
            IHIST(INDEX + 2) = IHIST(INDEX + 2) + 1
         endif
c        .                             End: Tally in histogram.
c
         DELTA = X - XMEAN
c
c              Expect abs(DELTA) .le. TEST most of the time.
c
         if(abs(DELTA) .gt. TEST) then
            if( DELTA .eq. 0.D0 ) go to 20
c
c                     Here  abs(DELTA) .gt. TEST  and  DELTA .ne. 0.D0
c                     Must compute new SCALE, RSCALE and TEST
c                     and update SUMSCL if it is nonzero.
c
            SCLNEW = abs(DELTA)
            RSCALE = 1.0D0 / SCLNEW
            TEST = FAC * SCLNEW
            if(SUMSCL .ne. 0.D0) SUMSCL = SUMSCL * (SCALE * RSCALE)**2
            SCALE = SCLNEW
         endif
         XMEAN = XMEAN + DELTA / COUNT
         SUMSCL = SUMSCL + (PREV/COUNT) * (DELTA*RSCALE)**2
   20    continue
   30 continue
c
      STATS(1) = COUNT
      STATS(2) = XMIN
      STATS(3) = XMAX
      STATS(4) = XMEAN
      if(PREV .eq. 0.D0) then
         STATS(5) = 0.D0
      else
         STATS(5) = SCALE * sqrt( SUMSCL / PREV )
      endif
      return
      end


double precision Function nansum(a,n)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: a
   integer*8 :: i
   nansum=0.
   do i = 1,n
      if ( isnan(a(i)) ) cycle
      nansum=nansum+a(i)
   enddo
end Function nansum

double precision Function nanmean(a,n)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: a
   integer*8 :: i,counter
   nanmean=0.; counter=0
   do i = 1,n
      if ( isnan(a(i)) ) cycle
      nanmean=nanmean+a(i)
      counter=counter+1
   enddo
   if (counter >= 1) nanmean=nanmean/counter
end Function nanmean

double precision Function nanstd(a,n)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: a
   integer*8 :: i,counter
   double precision :: nmean,nanmean
   nmean=nanmean(a,n)
   nanstd=0.; counter=0
   do i=1,n
      if ( isnan(a(i)) ) cycle
      nanstd=nanstd+(a(i)-nmean)**2
      counter=counter+1
   enddo
   if (counter >= 1) nanstd=sqrt(nanstd/counter)
end Function nanstd

subroutine dropna(ai,n,ao,counter)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: ai
   double precision, intent(out), dimension(n) :: ao
   integer*8, intent(out)  :: counter
   integer*8 :: i
   ao=0.; counter=0
   do i=1,n
      if ( isnan(ai(i)) ) cycle
      counter = counter+1
      ao(counter) = ai(i)
   enddo
end subroutine dropna

double precision Function nan_mean(a,n)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: a
   double precision :: at(n)
   integer*8 :: cntr
   call dropna(a,n,at,cntr)
   nan_mean=sum(at(1:cntr))/cntr
end Function nan_mean

double precision Function nan_median(a,n)
   implicit none
   integer*8, intent(in) :: n
   double precision, intent(in), dimension(n) :: a
   double precision :: at(n)
   double precision, allocatable, dimension(:) :: tmp
   integer*8 :: cntr
   call dropna(a,n,at,cntr)
   allocate(tmp(cntr)); tmp=at(1:cntr)
   call qsort(tmp,cntr)
   nan_median=tmp(int(cntr/2+1))
   deallocate(tmp)
end Function nan_median


!Autor: Claudio Iván Esparza Castañeda
!Título: Müller
!Descripción: Se encarga de calcular las raíces de un polinomio a partir del método de Müller
!Fecha: 22/03/2020
Program bair
  implicit none
  REAL, allocatable, dimension(:)::A, B, BP, BQ
  REAL::e, h, f, p, q, dp, dq, dn, r, rt, z, x1, x2
  INTEGER::i, n, j
  COMPLEX::y1, y2
  COMPLEX, allocatable, dimension(:)::C
1  WRITE(*, *) "Grado del polinomio:"
  READ(*, *) n
  allocate(A(0:n), B(0:n), BP(0:n), BQ(0:n))
  WRITE(*, *) "Coeficientes del polinomio a0+a1x+a2x²+...anx^n"
  do i=0, n
     READ(*, *) A(i)
  end do
  p=0
  q=0
  WRITE(*, *) "Error"
  READ(*, *) e
  do
     do i=n, 1, -1
        B(i)=A(i)-p*B(i+1)-q*B(i+2)
     end do
     B(0)=A(0)-Q*B(2)
     do i=n, 1, -1
        BP(i)=-B(i+1)-p*BP(i+1)-Q*BP(i+2)
        BQ(i)=-BQ(i+1)-B(i+2)-Q*BQ(i+2)
     end do
     BP(0)=-Q*BP(2)
     BQ(0)=-Q*BQ(2)-B(2)
     dn=BP(0)*BQ(1)-BP(1)*BQ(0)
     dp=(B(0)*BQ(1)-B(1)*BQ(0))/dn
     p=p-dp
     dq=(B(1)*BP(0)-B(0)*BP(1))/dn
     q=q-dq
     j=j+1
     if (abs(dq)*abs(dp) .le. e) then
        EXIT
     end if
  end do
  WRITE(*, *) p, q
  r=p*p-4*q
  if (r .ge. 0) then
     rt=sqrt(r)
     x1=(-p+rt)/2
     x2=(-p-rt)/2
     WRITE(*, *) "Las raíces son:"
     WRITE(*, *) x1, x2
  end if
  if (r .lt. 0) then
     rt=sqrt(-r)
     y1=COMPLEX(-p/2, rt/2)
     y2=COMPLEX(-p/2, -rt/2)
     WRITE(*, *) "Las raíces son:"
     WRITE(*, *) y1, y2
  end if
  WRITE(*, *) "Orden Coeficientes"
  do i=2, n
     WRITE(*, *) i-2, B(i)
  end do
  deallocate(A, B, BP, BQ)
  goto 1
end Program bair