      subroutine comqr(nm,n,low,igh,hr,hi,wr,wi,ierr)
c
      integer i,j,l,n,en,ll,nm,igh,itn,its,low,lp1,enm1,ierr
      double precision hr(nm,n),hi(nm,n),wr(n),wi(n)
      double precision si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,tst1,tst2,
     x       pythag
c
c     this subroutine is a translation of a unitary analogue of the
c     algol procedure  comlr, num. math. 12, 369-376(1968) by martin
c     and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 396-403(1971).
c     the unitary analogue substitutes the qr algorithm of francis
c     (comp. jour. 4, 332-345(1962)) for the lr algorithm.
c
c     this subroutine finds the eigenvalues of a complex
c     upper hessenberg matrix by the qr method.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  cbal.  if  cbal  has not been used,
c          set low=1, igh=n.
c
c        hr and hi contain the real and imaginary parts,
c          respectively, of the complex upper hessenberg matrix.
c          their lower triangles below the subdiagonal contain
c          information about the unitary transformations used in
c          the reduction by  corth, if performed.
c
c     on output
c
c        the upper hessenberg portions of hr and hi have been
c          destroyed.  therefore, they must be saved before
c          calling  comqr  if subsequent calculation of
c          eigenvectors is to be performed.
c
c        wr and wi contain the real and imaginary parts,
c          respectively, of the eigenvalues.  if an error
c          exit is made, the eigenvalues should be correct
c          for indices ierr+1,...,n.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the limit of 30*n iterations is exhausted
c                     while the j-th eigenvalue is being sought.
c
c     calls cdiv for complex division.
c     calls csroot for complex square root.
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (low .eq. igh) go to 180
c     .......... create real subdiagonal elements ..........
      l = low + 1
c
      do 170 i = l, igh
         ll = min0(i+1,igh)
         if (hi(i,i-1) .eq. 0.0d0) go to 170
         norm = pythag(hr(i,i-1),hi(i,i-1))
         yr = hr(i,i-1) / norm
         yi = hi(i,i-1) / norm
         hr(i,i-1) = norm
         hi(i,i-1) = 0.0d0
c
         do 155 j = i, igh
            si = yr * hi(i,j) - yi * hr(i,j)
            hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
            hi(i,j) = si
  155    continue
c
         do 160 j = low, ll
            si = yr * hi(j,i) + yi * hr(j,i)
            hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
            hi(j,i) = si
  160    continue
c
  170 continue
c     .......... store roots isolated by cbal ..........
  180 do 200 i = 1, n
         if (i .ge. low .and. i .le. igh) go to 200
         wr(i) = hr(i,i)
         wi(i) = hi(i,i)
  200 continue
c
      en = igh
      tr = 0.0d0
      ti = 0.0d0
      itn = 30*n
c     .......... search for next eigenvalue ..........
  220 if (en .lt. low) go to 1001
      its = 0
      enm1 = en - 1
c     .......... look for single small sub-diagonal element
c                for l=en step -1 until low d0 -- ..........
  240 do 260 ll = low, en
         l = en + low - ll
         if (l .eq. low) go to 300
         tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
     x            + dabs(hr(l,l)) + dabs(hi(l,l))
         tst2 = tst1 + dabs(hr(l,l-1))
         if (tst2 .eq. tst1) go to 300
  260 continue
c     .......... form shift ..........
  300 if (l .eq. en) go to 660
      if (itn .eq. 0) go to 1000
      if (its .eq. 10 .or. its .eq. 20) go to 320
      sr = hr(en,en)
      si = hi(en,en)
      xr = hr(enm1,en) * hr(en,enm1)
      xi = hi(enm1,en) * hr(en,enm1)
      if (xr .eq. 0.0d0 .and. xi .eq. 0.0d0) go to 340
      yr = (hr(enm1,enm1) - sr) / 2.0d0
      yi = (hi(enm1,enm1) - si) / 2.0d0
      call csroot(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
      if (yr * zzr + yi * zzi .ge. 0.0d0) go to 310
      zzr = -zzr
      zzi = -zzi
  310 call cdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
      sr = sr - xr
      si = si - xi
      go to 340
c     .......... form exceptional shift ..........
  320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
      si = 0.0d0
c
  340 do 360 i = low, en
         hr(i,i) = hr(i,i) - sr
         hi(i,i) = hi(i,i) - si
  360 continue
c
      tr = tr + sr
      ti = ti + si
      its = its + 1
      itn = itn - 1
c     .......... reduce to triangle (rows) ..........
      lp1 = l + 1
c
      do 500 i = lp1, en
         sr = hr(i,i-1)
         hr(i,i-1) = 0.0d0
         norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
         xr = hr(i-1,i-1) / norm
         wr(i-1) = xr
         xi = hi(i-1,i-1) / norm
         wi(i-1) = xi
         hr(i-1,i-1) = norm
         hi(i-1,i-1) = 0.0d0
         hi(i,i-1) = sr / norm
c
         do 490 j = i, en
            yr = hr(i-1,j)
            yi = hi(i-1,j)
            zzr = hr(i,j)
            zzi = hi(i,j)
            hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
            hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
            hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
            hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
  490    continue
c
  500 continue
c
      si = hi(en,en)
      if (si .eq. 0.0d0) go to 540
      norm = pythag(hr(en,en),si)
      sr = hr(en,en) / norm
      si = si / norm
      hr(en,en) = norm
      hi(en,en) = 0.0d0
c     .......... inverse operation (columns) ..........
  540 do 600 j = lp1, en
         xr = wr(j-1)
         xi = wi(j-1)
c
         do 580 i = l, j
            yr = hr(i,j-1)
            yi = 0.0d0
            zzr = hr(i,j)
            zzi = hi(i,j)
            if (i .eq. j) go to 560
            yi = hi(i,j-1)
            hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
  560       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
            hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
            hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  580    continue
c
  600 continue
c
      if (si .eq. 0.0d0) go to 240
c
      do 630 i = l, en
         yr = hr(i,en)
         yi = hi(i,en)
         hr(i,en) = sr * yr - si * yi
         hi(i,en) = sr * yi + si * yr
  630 continue
c
      go to 240
c     .......... a root found ..........
  660 wr(en) = hr(en,en) + tr
      wi(en) = hi(en,en) + ti
      en = enm1
      go to 220
c     .......... set error -- all eigenvalues have not
c                converged after 30*n iterations ..........
 1000 ierr = en
 1001 return
      end


*DECK DFAC
      DOUBLE PRECISION FUNCTION DFAC (N)
C***BEGIN PROLOGUE  DFAC
C***PURPOSE  Compute the factorial function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1
C***TYPE      DOUBLE PRECISION (FAC-S, DFAC-D)
C***KEYWORDS  FACTORIAL, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DFAC(N) calculates the double precision factorial for integer
C argument N.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D9LGMC, DGAMLM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  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***END PROLOGUE  DFAC
      DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN,  D9LGMC
      SAVE FACN, SQ2PIL, NMAX
      DATA FACN  (  1) / +.1000000000 0000000000 0000000000 000 D+1    /
      DATA FACN  (  2) / +.1000000000 0000000000 0000000000 000 D+1    /
      DATA FACN  (  3) / +.2000000000 0000000000 0000000000 000 D+1    /
      DATA FACN  (  4) / +.6000000000 0000000000 0000000000 000 D+1    /
      DATA FACN  (  5) / +.2400000000 0000000000 0000000000 000 D+2    /
      DATA FACN  (  6) / +.1200000000 0000000000 0000000000 000 D+3    /
      DATA FACN  (  7) / +.7200000000 0000000000 0000000000 000 D+3    /
      DATA FACN  (  8) / +.5040000000 0000000000 0000000000 000 D+4    /
      DATA FACN  (  9) / +.4032000000 0000000000 0000000000 000 D+5    /
      DATA FACN  ( 10) / +.3628800000 0000000000 0000000000 000 D+6    /
      DATA FACN  ( 11) / +.3628800000 0000000000 0000000000 000 D+7    /
      DATA FACN  ( 12) / +.3991680000 0000000000 0000000000 000 D+8    /
      DATA FACN  ( 13) / +.4790016000 0000000000 0000000000 000 D+9    /
      DATA FACN  ( 14) / +.6227020800 0000000000 0000000000 000 D+10   /
      DATA FACN  ( 15) / +.8717829120 0000000000 0000000000 000 D+11   /
      DATA FACN  ( 16) / +.1307674368 0000000000 0000000000 000 D+13   /
      DATA FACN  ( 17) / +.2092278988 8000000000 0000000000 000 D+14   /
      DATA FACN  ( 18) / +.3556874280 9600000000 0000000000 000 D+15   /
      DATA FACN  ( 19) / +.6402373705 7280000000 0000000000 000 D+16   /
      DATA FACN  ( 20) / +.1216451004 0883200000 0000000000 000 D+18   /
      DATA FACN  ( 21) / +.2432902008 1766400000 0000000000 000 D+19   /
      DATA FACN  ( 22) / +.5109094217 1709440000 0000000000 000 D+20   /
      DATA FACN  ( 23) / +.1124000727 7776076800 0000000000 000 D+22   /
      DATA FACN  ( 24) / +.2585201673 8884976640 0000000000 000 D+23   /
      DATA FACN  ( 25) / +.6204484017 3323943936 0000000000 000 D+24   /
      DATA FACN  ( 26) / +.1551121004 3330985984 0000000000 000 D+26   /
      DATA FACN  ( 27) / +.4032914611 2660563558 4000000000 000 D+27   /
      DATA FACN  ( 28) / +.1088886945 0418352160 7680000000 000 D+29   /
      DATA FACN  ( 29) / +.3048883446 1171386050 1504000000 000 D+30   /
      DATA FACN  ( 30) / +.8841761993 7397019545 4361600000 000 D+31   /
      DATA FACN  ( 31) / +.2652528598 1219105863 6308480000 000 D+33   /
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA NMAX / 0 /
C***FIRST EXECUTABLE STATEMENT  DFAC
      IF (NMAX.NE.0) GO TO 10
      CALL DGAMLM (XMIN, XMAX)
      NMAX = XMAX - 1.D0
C
 10   IF (N .LT. 0) CALL XERMSG ('SLATEC', 'DFAC',
     +   'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2)
C
      IF (N.LE.30) DFAC = FACN(N+1)
      IF (N.LE.30) RETURN
C
      IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'DFAC',
     +   'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2)
C
      X = N + 1
      DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) )
C
      RETURN
      END


Subroutine momntm(px, py, pz, e)
  Implicit Double Precision (A-H, O-Z)
  External ran1
  Parameter (pi=3.14159265358979D0)
  Common /rndm3/iseedp
  Save
  iseed = iseedp
  cost = 2D0*ran1(iseed) - 1D0
  sint = dsqrt(1D0-cost**2)
  phi = 2D0*pi*ran1(iseed)
  px = e*sint*cos(phi)
  py = e*sint*sin(phi)
  pz = e*cost
  Return
End Subroutine momntm


************************************************************************
*
*     Function MVUEPHI                      Called by: MLELOAD2, MLEVAR
*
*     calculate the function PHI given in Likes (1980)
*
*     local vars
*     ----------
*     ARG1     DLOGAM(K+1)
*     ARG2     DLOGAM(NU2)
*     ARG3     DLOGAM(NU2+K)
*     IK       I-1
*     RK       DBLE(I-1)
*     TOL      convergence criteria (convergence when term < tol)
*     WORK     amount of MVUEPHI contributed by a single term
*
**********************************************************************
      DOUBLE PRECISION FUNCTION MVUEPHI(AW4,NU2)
*
*     subroutine arguments
*
      DOUBLE PRECISION AW4,NU2
*
*     local variables
*
      INTEGER*4 I,IK
      DOUBLE PRECISION ARG1,ARG2,ARG3,RK,TOL,WORK
*
*     function declaration
*
      DOUBLE PRECISION DLOGAM
*
*     define criteria for convergence
*
      PARAMETER (TOL=1.D-9)
*
*     for AW4 equal to zero, PHI equals 1
*
      IF (AW4 .EQ. 0.D0) THEN
         MVUEPHI = 1.D0
         RETURN
      ENDIF
*
*     For AW4 not equal to zero, calculate PHI by iteration.  PHI may
*     be computed using factorial and gamma functions, e.g.:
*
*     WORK = (1.D0/FAC(RK))*(GAMMA(NU2)/GAMMA(NU2+RK))*GAMMA(AW4)**IK
*
*     instead of GAMMA(X) use EXP(LN_GAMMA(X)) to avoid machine
*     overflow.  This allows log GAMMA terms to be added/subtracted
*     rather than multiplying/dividing.  Use EXP(LOGAM(K+1)) for
*     FACTORIAL(K).
*
      MVUEPHI = 0.D0
      DO 10 I=1,200
         IK = I-1
         RK = DBLE(I-1)
         ARG1 = DLOGAM((RK+1.D0))
         ARG2 = DLOGAM(NU2)
         ARG3 = DLOGAM(NU2+RK)
         IF (AW4**IK.GT.2.D0**1000) CALL ERROR7(5)
         WORK = DEXP(-ARG1+ARG2-ARG3)*(AW4**IK)
         MVUEPHI = MVUEPHI+WORK
         IF (I.GT.2.AND.DABS(WORK).LT.TOL) RETURN
 10   CONTINUE
*
*     the function has not converged in 200 iterations; terminate
*     execution
*
      CALL ERROR7(6)

      END


! Program for de bidimensional simulation of a cavity system
! Undergraduate: Felipe J. O. Ribeiro
! Professor: Aristeu da Silveira Neto

!Main module for global variables
Module global
    implicit none

    !Definition of Cell Data type:
    type Cell
        double precision:: T, Ti                      !Temperature variables
        double precision:: P, Pi, Pl                  !Double precision
        double precision:: v, u, vl, ul               !velocities variables
        double precision:: dx, dy                     !Size variables
        double precision:: x, y                       !Absolute cobordinates location
        double precision:: alpha, nu, rho, mi         !Local physical variables
        double precision:: div, divi                  !Divergent of velocity in this cell
        LOGICAL:: Wall                                !Is Wall?
        integer:: type_Wall                           !What type of wall?
                                !1----> (velocity: dirichlet = (u-0, v-0), Temperature: Neumann = 0, Preassure: Neumann = 0)
                                !2----> (velocity: dirichlet = (u-ui, v-vi), Temperature: Neumann = 0, Preassure: Neumann = 0)
    end type cell

    ! Phisical parameters
    integer:: Nx, Ny                                                     !Space discretization
    double precision:: Lx, Ly, dx, dy                                    !Geometry of the space domain
    double precision:: alpha, nu, mi, rho, gx, gy                        !physical variables
    double precision:: vi, ui, pi, Ti, Reynolds, V_top, ta, tb, dil, RA  !Initial condition variables
    double precision:: time, dt, cfl, increment                          !Convergence variables
    type(Cell), dimension(:,:), allocatable:: C                          !Temperature and extra matrix
    CHARACTER:: CR = CHAR(13)

    !Computational parameters
    integer:: i, ii, iii                                         !Integer counters
    integer:: step, pressure_step, velo_step                     !Number of iterations in simulation
    double precision, dimension(:,:), allocatable:: tr           !Transition variable
    character*200:: dirname, filename, misc                      !Names for file creation and directory structure
    Logical:: save_image, folder                                 !Simulation options
    integer:: what_velocity_simulation, image_frequence, step_image
    contains

    subroutine StripSpaces(string)
        character(len=*):: string
        integer:: stringLen
        integer:: last, actual

        stringLen = len (string)
        last = 1
        actual = 1

        do while (actual < stringLen)
            if (string(last:last) == ' ') then
                actual = actual+1
                string(last:last) = string(actual:actual)
                string(actual:actual) = ' '
            else
                last = last+1
            if (actual < last) &
                actual = last
            endif
        end do

    end subroutine

end module global

!Main program, responsible for distributin mpi jobs
program cavidade
    use global              !Library for global variables
    implicit none

    call Simulation()

end program cavidade

!Routine for the simulation
subroutine Simulation()
    use global
    implicit none

    !Parameters of the simulation:
    Nx = 30                                                        !Space cells in x direction
    Ny = Nx                                                        !Space cells in y direction
    Lx = 1.d0                                                      !Size of space domain in x  (m)
    Ly = Lx                                                        !Size of space domain in y  (m)
    dx =  Lx / (Nx)                                                !Cells length in x (m)
    dy =  Ly / (Ny)                                                !Cells length in y (m)
    !Physical determination of fluid flow:
    alpha =  1.43d-4                                               !Thermal condutivity (water with 25 degree Celcius) (m**2/s)
    mi = 8.891d-4                                                  !viscosity (water with 25 degree Celcius) (n*s/m**2) (https://www.engineeringtoolbox.com/water-dynamic-kinematic-viscosity-d_596.html)
    rho = 8.2d0  ! 997.7d0                                           !Specific mass (water with 25 degree Celcius) (N/m**3)
    nu = mi/rho                                                    !Knematic viscosity
    V_top = 0.0d0  ! 2d0                                              !Velocity of top plate
    Reynolds = V_top*Lx/(nu)                                       !Reynolds number
    gx = 0.0d0                                                     !Gravity in x direction (m/s**2)
    gy = 10.0d0                                                    !Gravity in y direction (m/s**2) (http://lilith.fisica.ufmg.br/~dsoares/g/g.htm)
    vi = 0.0d0                                                     !Initial condition parameter for vertical velocity
    ui = 0.0d0                                                     !Initial condition parameter for horizontal velocity
    pi = 0.0d0                                                     !Initial condition parameter for preassure
    ti = 25.0d0                                                    !Initial condition parameter for temperature
    ta = 5.0d0                                                     !Temperature on the left wall
    tb = 50.0d0                                                    !Temperature on the right wall
    Ra =  1.89d5                                                   !Número de Rayleigh.
    dil = alpha*nu*Ra / (gy * (Tb-Ta) * Lx**3 )              !Thermal dilatation linear coefficient
    !Simulation convergence parameters:
    cfl = 0.025d0                                                  !Relation betwen time and space steps
    dt = (cfl*dx**2 )/ nu                                        !Time step length (s)
    time = 2500                                                    !Total time of simulation (s)
    increment = 1.d-10                                             !Increment for implicity Gaus-Seidel solutions
    !Simulation Pannel control:
    save_image = .FALSE.                                           !Save file is wanted?
    folder = .FALSE.                                               !The results folder is already there?
    image_frequence = 10                                           !In how many iterations the image must be saved?
    what_velocity_simulation = 2                                   !Type of velocity numerical solution (1 = explicit/2 = implicit)

    !Data from the present simulation
    Print*, "Simulation " , filename
    Print*, "Ra = " , Ra
    Print*, "dt= " , dt
    Print*, "dx= " , dx
    Print*, "CFl = " , cfl

    !Allocation of simulations buffers:
    allocate(C(Nx+2  , Ny+2))                                  !   1 extra cell   |wall|      N cells      |wall| 1 extra cell
    allocate(tr(Nx+2  , Ny+2))

    !Simulation Routines:

     call Simu_routines()                                          !The protocolls are called for simulation development

    !Simulation Statistics:
    print*, " "
    print*, "------------------------------------------------------"
    print*, "-                                                    -"
    print*, "-                  Fim da simulação                  -"
    print*, "-                                                    -"
    print*, "------------------------------------------------------"

    !Dellocation of simulations buffers:
    deallocate(C)
    deallocate(tr)

end subroutine simulation

!Simulation center of routines:
subroutine Simu_routines()
    use global
    implicit none

    call initialconditions()                                       !Create the initial condition for the simulation

    call time_steps()                                              !Initiate time iterations

    if(save_image)then
        call save_this_image()                                     !Save image in non volitile memory.
    end if

end subroutine Simu_routines

!Set initial values for all the domain and simulation values
subroutine initialconditions()
    use global
    implicit none

    !Geometric topologicall determination (is wall ?)
    do i = 1, Nx+2
        do ii = 1, Ny+2

            if ( (i == 1 .or. ii == 1 .or. i == Nx+2 ) .and. ii /= Ny+2)then
                C(i, ii)%Wall = .True.
                C(i, ii)%type_Wall = 1
            else if(ii == Ny+2)then
                C(i, ii)%Wall = .True.
                C(i, ii)%type_Wall = 2
            else
                C(i, ii)%Wall = .False.
            end if

        end do
    end do

    !Initial phisicall considerations:
    do i = 1, Nx+2
        do ii = 1, Ny+2

            if ( C(i, ii)%Wall .eqv. .False. )then
                !Determinations for all the physicall domain

                C(i, ii)%u = ui
                C(i, ii)%v = vi
                C(i, ii)%alpha = alpha
                C(i, ii)%nu = nu
                C(i, ii)%mi = mi
                C(i, ii)%rho = rho

            end if

            C(i, ii)%T = ti
            C(i, ii)%P = pi
            C(i, ii)%dx = dx
            C(i, ii)%dy = dy

        end do
    end do
end subroutine initialconditions

subroutine time_steps()
    use global
    implicit none

    !initiate simulation loop
    step = 1
    do while(step*dt < time-dt)
        call boundary_conditions()                                 !Set boundary conditions
        call velocity_solver()                                     !Solve the velocity field
        call preassure_definition()                                !Simulate preassure of the next step
        call velocity_corrector()                                  !Correct the velocity with the preassure simulated
        call boundary_conditions()                                 !Set boundary conditions
        call divergent_calculator()                                !Calcule the divergent of the velocity domain
        call preassure_atualization()                              !Calculate the preassure of new step
        call temperature_atualization()                            !Calculate new temperature
        call boundary_conditions()                                 !Set boundary conditions
        if(mod(step, image_frequence) == 0.0)then
            call save_this_image()                                     !Save domain for paraview
        end if
        !At final of a step
        WRITE(*,101) char(13), MAXVAL(C%div), "   " , pressure_step, velo_step
        101 FORMAT(1a1, ES7.1, A, I5, I5, $)
        step = step+1
    end do
end subroutine time_steps

subroutine boundary_conditions()
    use global
    implicit none
    !Boundary conditions
        do i = 1, Ny+2
            !Preassure on all the walss
            C(Nx+2, i)%P  =  C(Nx+1, i)%P     !>
            C(1     , i)%P     =  C(2, i)%P       !<
            C(Nx+2, i)%Pl  =  C(Nx+1, i)%Pl     !>
            C(1     , i)%Pl     =  C(2, i)%Pl       !<

            C(1     , i)%v = - C(2     , i)%v
            C(Nx+2   , i)%v = - C(Nx+1   , i)%v
            C(1     , i)%vl = - C(2     , i)%vl
            C(Nx+2   , i)%vl = - C(Nx+1   , i)%vl

            C(1     , i)%u = 0
            C(2     , i)%u = 0
            C(Nx+2   , i)%u = 0
            C(1     , i)%ul = 0
            C(2     , i)%ul = 0
            C(Nx+2   , i)%ul = 0

            C(1     , i)%T = ta
            C(Nx+2, i)%T = tb
        end do

        do i = 1, Nx+2
            C(i, Ny+2)%P =  C(i, Ny  + 1)%P
            C(i, 1    )%P =  C(i, 2     )%P
            C(i, Ny+2)%Pl =  C(i, Ny  + 1)%Pl
            C(i, 1    )%Pl =  C(i, 2     )%Pl

            C(i, 1    )%v = 0
            C(i, 2    )%v = 0
            C(i, Ny+2)%v = 0
            C(i, 1    )%vl = 0
            C(i, 2    )%vl = 0
            C(i, Ny+2)%vl = 0

            C(i, 1    )%u = -C(i, 2     )%u
            C(i, Ny+2)%u = 2*V_top  - C(i, Ny+1)%u
            C(i, 1    )%ul = -C(i, 2     )%ul
            C(i, Ny+2)%ul = 2*V_top-C(i, Ny+1)%ul

            C(i, 1     )%T = C(i, 2     )%T
            C(i, Ny+2)%T = C(i, Ny+1)%T
        end do
end subroutine boundary_conditions

subroutine velocity_solver()
    use global
    implicit none

    if(what_velocity_simulation == 2)then
    ! IMPLICITY SOLVER
    !print*, "implicit velocity"

        !Initial value
        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%ul = 0
                C(i, ii)%vl = 0

            end do
        end do

        velo_step = 0

        !Implicit velocity line creation
        C(3, 3)%div = 10
        C(3, 3)%divi = 10
        do while( MAXVAL(C%div) > increment .or. MAXVAL(C%divi) > increment)

            do i = 2, Nx+1
                do ii = 2, Ny+1

                    C(i, ii)%div = C(i, ii)%ul      !div é utilizado para se ver o incremento da velocidade
                    C(i, ii)%divi = C(i, ii)%vl     !divi é utilizado para se ver o incremento da velocidade

                end do
            end do

            do i = 3, Nx+1
                do ii = 2, Ny+1

                    C(i, ii)%ul = (C(i, ii)%u * (C(i, ii)%dx**2)*(C(i, ii)%dy**2))/((C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dy**2) + (C(i, ii)%dx**2) ) ) &
                        - ( (   &
                            ((C(i, ii)%v+C(i-1, ii)%v  + C(i, ii+1)%v  + C(i-1, ii+1)%v )/4)&
                            * (C(i, ii)%dx**2) *(C(i, ii)%dy) * dt)/( 2 * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 4*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) ) * &
                        (C(i, ii+1)%u-C(i, ii-1)%u ) &
                        - ( (C(i, ii)%u * (C(i, ii)%dx) *(C(i, ii)%dy**2) * dt)/( 2 * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 4*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )  *&
                        (C(i+1, ii)%u-C(i-1, ii)%u ) &
                        - ( ( (C(i, ii)%dx) *(C(i, ii)%dy**2) * dt)/( rho * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*rho*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i, ii)%P-C(i-1, ii)%P) &
                        +( ( (C(i, ii)%dx**2) *(C(i, ii)%dy**2) * dt * (C(i, ii)%rho-rho) * gx)/( rho * &
                            (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*rho*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )&
                        + ( ( nu *(C(i, ii)%dy**2) * dt)/( (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i+1, ii)%ul+C(i-1, ii)%ul)&
                        + ( ( nu *(C(i, ii)%dx**2) * dt)/( (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i, ii+1)%ul+C(i, ii-1)%ul)
                end do
            end do

            do i = 2, Nx+1
                do ii = 3, Ny+1
                    C(i, ii)%vl = (C(i, ii)%v * (C(i, ii)%dx**2) *(C(i, ii)%dy**2))/((C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dy**2) + (C(i, ii)%dx**2) ) ) &
                        - ( (C(i, ii)%v * (C(i, ii)%dx**2) *(C(i, ii)%dy) * dt)/( 2 * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 4*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) ) * &
                        (C(i, ii+1)%v-C(i, ii-1)%v ) &
                        - ( ( &
                            (C(i, ii)%u+C(i, ii-1)%u+C(i+1, ii)%u+C(i+1, ii-1)%u)/4 &
                                * (C(i, ii)%dx) *(C(i, ii)%dy**2) * dt)/( 2 * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 4*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )  *&
                        (C(i+1, ii)%v-C(i-1, ii)%v ) &
                        - ( ( (C(i, ii)%dx**2) *(C(i, ii)%dy) * dt)/( rho * (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*rho*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i, ii)%P-C(i, ii-1)%P) &
                        +( ( (C(i, ii)%dx**2) *(C(i, ii)%dy**2) * dt * (  dil * (C(i, ii)%T-ti) )* gy)/( rho * &
                            (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*rho*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )&
                        + ( ( nu *(C(i, ii)%dy**2) * dt)/( (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i+1, ii)%vl+C(i-1, ii)%vl)&
                        + ( ( nu *(C(i, ii)%dy**2) * dt)/( (C(i, ii)%dx**2) * &
                        (C(i, ii)%dy**2) + 2*nu*dt *( (C(i, ii)%dx**2) + (C(i, ii)%dy**2) ) ) )*&
                        (C(i, ii+1)%vl+C(i, ii-1)%vl)

                end do
            end do

            call boundary_conditions()

            velo_step = velo_step+1

            do i = 2, Nx+1
                do ii = 2, Ny+1

                    C(i, ii)%div = abs ( C(i, ii)%div-C(i, ii)%ul )
                    C(i, ii)%divi = abs ( C(i, ii)%divi-C(i, ii)%vl )

                end do
            end do

        end do

    else if(what_velocity_simulation == 1)then
    !EXPLICIT SOLVER
    !print*, "explicit velocity"

        do i = 3, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%ul = C(i, ii)%u &
                    - C(i, ii)%u * ((dt)/(C(i, ii)%dx)) *(C(i+1, ii)%u-C(i, ii)%u) &
                    - ( C(i, ii)%v+C(i-1, ii)%v  + C(i, ii+1)%v  + C(i-1, ii+1)%v )/4 &
                    * ((dt)/(C(i, ii)%dy)) *(C(i, ii+1)%u-C(i, ii)%u)&
                    - ((dt)/(rho*C(i, ii)%dx )) * (C(i, ii)%P-C(i-1, ii)%P)&
                    + dt*gx * (C(i, ii)%rho-rho)/(rho) &
                    + (nu*dt / (C(i, ii)%dx**2) ) * (C(i+1, ii)%u-2 * C(i, ii)%u+C(i-1, ii)%u) &
                    + (nu*dt / (C(i, ii)%dy**2) ) * (C(i, ii+1)%u-2 * C(i, ii)%u+C(i, ii-1)%u)
            end do
        end do

        do i = 2, Nx+1
            do ii = 3, Ny+1
                C(i, ii)%vl = C(i, ii)%v &
                    - (C(i, ii)%u+C(i, ii-1)%u+C(i+1, ii)%u+C(i+1, ii-1)%u)/4 &
                    * ((dt)/(C(i, ii)%dx)) *(C(i+1, ii)%v-C(i, ii)%v) &
                    - C(i, ii)%v * ((dt)/(C(i, ii)%dy)) *(C(i, ii+1)%v-C(i, ii)%v) &
                    - ((dt)/(rho*C(i, ii)%dy)) * (C(i, ii)%P-C(i, ii-1)%P)&
                    + dt*gy * (C(i, ii)%rho-rho)/(rho) &
                    + (nu*dt / (C(i, ii)%dx**2) ) * (C(i+1, ii)%v-2 * C(i, ii)%v+C(i-1, ii)%v) &
                    + (nu*dt / (C(i, ii)%dy**2) ) * (C(i, ii+1)%v-2 * C(i, ii)%v+C(i, ii-1)%v)

            end do
        end do

        call boundary_conditions()

    end if

end subroutine velocity_solver

subroutine preassure_definition()
    use global
    implicit none

    !Pressure initial gaus saidel value (zero)
    do i = 1, Nx+2
        do ii = 1, Ny+2

                C(i, ii)%Pl = 0

        end do
    end do
    pressure_step = 0

    !Implicit preassure line creation
    C(3, 3)%divi = 10
    do while( MAXVAL(C%divi) > increment)

        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%divi = C(i, ii)%Pl

            end do
        end do
       C(Nx/2, Ny/2)%Pl = 0

        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%Pl = -1 * ( (rho*C(i, ii)%dx*C(i, ii)%dy**2)/(2 * (C(i, ii)%dx**2 + C(i, ii)%dy**2) * dt )) &
                * ( C(i+1, ii)%ul-C(i, ii)%ul) &
                -1 * ( (rho*C(i, ii)%dx**2 * C(i, ii)%dy)/(2 * (C(i, ii)%dx**2 + C(i, ii)%dy**2) * dt )) &
                * ( C(i, ii+1)%vl-C(i, ii)%vl) &
                + ( (C(i, ii)%dy**2)/ (2 * (C(i, ii)%dx**2 + C(i, ii)%dy**2)))*( C(i+1, ii)%Pl+C(i-1, ii)%Pl) &
                + ( (C(i, ii)%dx**2)/ (2 * (C(i, ii)%dx**2 + C(i, ii)%dy**2)))*( C(i, ii+1)%Pl+C(i, ii-1)%Pl)

            end do
        end do

        call boundary_conditions()

        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%divi = abs ( C(i, ii)%divi-C(i, ii)%Pl )

            end do
        end do

        pressure_step = pressure_step+1
    end do

end subroutine preassure_definition

subroutine velocity_corrector()
    use global
    implicit none

    do i = 3, Nx+1
        do ii = 2, Ny+1

                C(i, ii)%u = C(i, ii)%ul - (dt/(C(i, ii)%dx*rho)) * (C(i, ii)%Pl-C(i-1, ii)%Pl)

        end do
    end do

    do i = 2, Nx+1
        do ii = 3, Ny+1

                C(i, ii)%v =  C(i, ii)%vl - (dt/(C(i, ii)%dy*rho)) * (C(i, ii)%Pl-C(i, ii-1)%Pl)

        end do
    end do

end subroutine velocity_corrector

subroutine divergent_calculator()
    use global
    implicit none

    do i = 2, Nx+1
        do ii = 2, Ny+1

            C(i, ii)%div = (C(i+1, ii)%u-C(i, ii)%u)/ C(i, ii)%dx + (C(i, ii+1)%v-C(i, ii)%v)/ C(i, ii)%dy

        end do
    end do

end subroutine divergent_calculator

subroutine preassure_atualization()
    use global
    implicit none

    !Pressure atualization
    do i = 2, Nx+1
        do ii = 2, Ny+1

            C(i, ii)%P = C(i, ii)%Pl +  C(i, ii)%P

        end do
    end do

end subroutine preassure_atualization

subroutine temperature_atualization()
    use global
    implicit none

    !Explicit simulation for this step.

        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%Ti = C(i, ii)%T * (1-4 * alpha*dt/(dx*dy)) &
                + C(i+1, ii)%T * (alpha*dt / (dx**2) - C(i+1, ii)%u*dt/(2*dx)) &
                + C(i, ii+1)%T * (alpha*dt /(dy**2) - C(i, ii+1)%v*dt / (2*dy))&
                + C(i-1, ii)%T * ((alpha*dt) / (dx*dx) + C(i, ii)%u*dt /(2*dx)) &
                + C(i, ii-1)%T *((alpha*dt) /(dy*dy) + C(i, ii)%v*dt/(2*dy))

            end do
        end do

        do i = 2, Nx+1
            do ii = 2, Ny+1

                C(i, ii)%T = C(i, ii)%Ti

            end do
        end do

        call boundary_conditions()

end subroutine temperature_atualization

subroutine save_this_image()
    use global
    implicit none

    call GETCWD(dirname)

    if(folder .eqv. .FALSE.)then
        !Creation of new folder for data saving
        write(misc, FMT = 187)  Nx, "_" , Ny, "_" , Ta, "_" , Tb, "_" , Ra
        187     format( "cavity_" , I3, A, I3, A, F6.1, A, F6.1, A, e7.1)
        call StripSpaces (misc)
        call system("cd results && mkdir " // misc)
        misc = trim(dirname) // "/results/" //  trim(misc)
        step_image = 0
        folder = .TRUE.
    end if

    ! Step file creation
    write(filename, FMT = 186) trim(misc), "/step" , step_image, ".dat"
    186     format(  A, A, I10, A)
    call StripSpaces (filename)

    ! Open instance of write
    open(unit = 10, file = filename)

    !Data write
    write(10, *) "TITLE = " , '"Cavity_simu"'
    write(10, *) 'Variables="X","Y","P","U","V","T","div"'
    write(10, *) 'Zone I=', Nx, ', J=', Ny, ', F = POINT'

    do i = 2, Nx+1
        do ii = 2, Ny+1

            write(10, *) (dx*i - 1.5*dx), (dy*ii-1.5*dy), C(i, ii)%P, &
            (C(i+1, ii)%u+C(i, ii)%u)/2, (C(i, ii+1)%v+C(i, ii)%v)/2, &
            C(i, ii)%T, C(i, ii)%div

        end do
    end do

    ! Close instance of write
    close(10)

    step_image = step_image+1
    return

end subroutine save_this_image


MODULE L2_REAL64
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  IMPLICIT NONE

  ! Assign the names for the types in this module.
  INTEGER, PARAMETER :: PNT=REAL64 ! "PoiNT' data type.
  INTEGER, PARAMETER :: RAD=REAL64 ! "RADius" data type.
  INTEGER, PARAMETER :: IDX=INT64  ! "InDeX" data type.
  INTEGER, PARAMETER :: DST=REAL64 ! "DiSTance" data type.
  INTEGER, PARAMETER :: ITL=REAL64 ! "InTernal" data type.

  ! Define storage space for internal data to this metric.
  REAL(KIND=PNT), ALLOCATABLE, DIMENSION(:,:) :: BUILD_POINTS
  REAL(KIND=PNT), ALLOCATABLE, DIMENSION(:,:) :: SEARCH_POINTS
  REAL(KIND=ITL), ALLOCATABLE, DIMENSION(:) :: BUILD_DATA
  REAL(KIND=ITL), ALLOCATABLE, DIMENSION(:) :: SEARCH_DATA

CONTAINS

  SUBROUTINE COPY_METRIC_BUILD_DATA(DATA)
    ! Copy the build data into the provided memory space.
    REAL(KIND=ITL), INTENT(OUT), DIMENSION(:) :: DATA
    DATA(:) = BUILD_DATA(:)
  END SUBROUTINE COPY_METRIC_BUILD_DATA

  SUBROUTINE METRIC_SETUP_BUILD(POINTS)
    ! Compute the squared sum of each point, provided column vectors.
    REAL(KIND=PNT), INTENT(IN), DIMENSION(:,:) :: POINTS
    INTEGER :: I
    BUILD_POINTS = POINTS
    ! De-allocate existing build data if it is present.
    IF (ALLOCATED(BUILD_DATA))  DEALLOCATE (BUILD_DATA)
    ! Allocate build data.
    ALLOCATE (BUILD_DATA(1:SIZE(POINTS,2)))
    ! Compute the squared sums of points.
    DO I = 1, SIZE(POINTS,2)
       BUILD_DATA(I) = SUM(POINTS(:,I)**2)
    END DO
  END SUBROUTINE METRIC_SETUP_BUILD

  SUBROUTINE METRIC_BUILD(POINTS, I1, I2, DISTANCE)
    ! Compute the squared l2 distance between two indices.
    REAL(KIND=PNT),    INTENT(IN), DIMENSION(:,:) :: POINTS
    INTEGER(KIND=IDX), INTENT(IN)  :: I1, I2
    REAL(KIND=DST),    INTENT(OUT) :: DISTANCE
    DISTANCE = BUILD_DATA(I1) + BUILD_DATA(I2) - &
         2 * DOT_PRODUCT(POINTS(:,I1), POINTS(:,I2))
  END SUBROUTINE METRIC_BUILD

  SUBROUTINE METRIC_SETUP_SEARCH(SEARCH_POINTS)
    ! Compute the squared sum of each point
    REAL(KIND=PNT), INTENT(IN), DIMENSION(:,:) :: SEARCH_POINTS
  END SUBROUTINE METRIC_SETUP_SEARCH

  SUBROUTINE METRIC_SEARCH(POINTS, SEARCH_POINTS, I1, I2, DISTANCE)
    ! Compute the actual l2 distance between two indices.
    REAL(KIND=PNT),    INTENT(IN), DIMENSION(:,:) :: POINTS, SEARCH_POINTS
    INTEGER(KIND=IDX), INTENT(IN)  :: I1, I2
    REAL(KIND=DST),    INTENT(OUT) :: DISTANCE
  END SUBROUTINE METRIC_SEARCH

END MODULE L2_REAL64


!===============================================================================
program cijkl2Cij_prog
!===============================================================================
!  Reads 3x3x3x3 cijkl from stdin and writes 6x6 Cij to stdout

   use anisotropy_ajn

   implicit none

   real(8) :: cijkl(3,3,3,3), Cij(6,6)
   integer :: iostatus,i,j,k,l

   if (command_argument_count() /= 0) then
      write(0,'(a)') 'Usage: cijkl2Cij < [list of 3x3x3x3 elastic constants]'
      stop
   endif

   iostatus = 0
   do while (iostatus == 0)
      read(*,*,iostat=iostatus) ((((cijkl(i,j,k,l),l=1,3),k=1,3),j=1,3),i=1,3)
      if (iostatus < 0) exit
      if (iostatus > 0) then
         write(0,'(a)') 'cijkl2Cij: problem reading 3x3x3x3 tensor from stdin.'
         stop
      endif
      Cij = cijkl2Cij(cijkl)
      write(*,*) ((Cij(i,j),j=1,6),i=1,6)
   enddo

end program cijkl2Cij_prog