! sum all the elements of the array
real function sum_array (array, n1, n2, n3)
  implicit none
  integer :: n1,n2,n3,i1,i2,i3
  real array(n1,n2,n3)

  do i3=1, n3
     do i2=1, n2
        do i1=1, n1
           sum_array = sum_array + array(i1,i2,i3)
        end do
     end do
  end do
end function sum_array

program main
  implicit none
  integer :: n1,n2,n3,L,is1,ie1,is2,ie2,is3,ie3
  parameter(L=4, n1=100, n2=100, n3=100)
  real, dimension(:,:,:), allocatable :: u,v
  real, dimension(-L:L) :: c
  real result, sum_array

  is1=1;ie1=n1
  is2=1;ie2=n2
  is3=1;ie3=n3

  c = 3.

  allocate(v(n1,n2,n3))
  allocate(u(n1,n2,n3))

  ! Simple case
  u = 1.; v = 1.;
  call stencil8(u,v,c,n1,n2,n3,is1,ie1,is2,ie2,is3,ie3)
  result = sum_array (u, n1, n2, n3)
  PRINT *, ("the sum is"), result
  deallocate(v)
  deallocate(u)

end program main

subroutine stencil8(u,v,c,n1,n2,n3,is1,ie1,is2,ie2,is3,ie3)
  ! Stencil length : 2*L

  implicit none
  integer :: i1,i2,i3,is1,ie1,is2,ie2,is3,ie3,n1,n2,n3,L
  parameter(L=4)
  real, dimension(n1,n2,n3) :: u, v
  real, dimension(-L:L) :: c
  real c_4,c_3,c_1, c_2, c0, c1, c2,c3,c4

  c_4 = c(-4); c_3 = c(-3); c_2 = c(-2); c_1 = c(-1);
  c0 = c(0);
  c4 = c(4); c3 = c(3); c2 = c(2); c1 = c(1);

  do i3=is3+L,ie3-L
     do i2=is2+L,ie2-L
        do i1=is1+L,ie1-L
           u(i1,i2,i3) = &
                + c_4 * (v(i1-4,i2,i3) + v(i1,i2-4,i3) + v(i1,i2,i3-4))&
                + c_3 * (v(i1-3,i2,i3) + v(i1,i2-3,i3) + v(i1,i2,i3-3))&
                + c_2 * (v(i1-2,i2,i3) + v(i1,i2-2,i3) + v(i1,i2,i3-2))&
                + c_1 * (v(i1-1,i2,i3) + v(i1,i2-1,i3) + v(i1,i2,i3-1))&
                + c0  *  v(i1,  i2,i3) * 3&
                + c1  * (v(i1+1,i2,i3) + v(i1,i2+1,i3) + v(i1,i2,i3+1))&
                + c2  * (v(i1+2,i2,i3) + v(i1,i2+2,i3) + v(i1,i2,i3+2))&
                + c3  * (v(i1+3,i2,i3) + v(i1,i2+3,i3) + v(i1,i2,i3+3))&
                + c4  * (v(i1+4,i2,i3) + v(i1,i2+4,i3) + v(i1,i2,i3+4))
        end do
     end do
  end do

end subroutine stencil8


! Las variables de tipo complex son aquellas que almacenan numeros complejos.
! Un numero complejo está compuesto por una parte real y otra imaginaria.
! Dos unidades numericas consecutivas almacenan estas dos partes.

!Por ejemplo, el número representado por (1.0, -1.0) es igual a 1.0 - 1.0i
!La función generica cmplx() crea un número complejo. Produce un resultado que
!cuyas partes imaginarias y reales son de precisión simple.

! Las versiones  más modernas de Fortran (90/95) nos permiten tener mayor control sobre la precisión de
! datos de tipo real e integer mediante el especificador kind.

!En la programación científica, uno usualmente necesita saber el rango y precisión de los datos
!del hardware en el que se está trabajando.

!La función intrinseca kind() nos permite consultar los detalles de la representación de datos del hardware
!en el que se está trabajando.

program tipos_compl
real :: a
real :: b
complex :: z
complex, parameter :: z2 = (2.0, 3.1)

complex(kind=4) :: z_4bytes
complex(kind=8) :: z_8bytes
complex(kind=16) :: z_16bytes

z = cmplx(a, b)
print *, z

print *, z2

print *, "¿Cuántos bytes puede almacenar una variable de tipo complex por defecto?: ", kind(z)

print *, "¿Cuántos bytes almacena z_4bytes?: ", kind(z_4bytes)

print *, "¿Cuántos bytes almacena z_8bytes?: ", kind(z_8bytes)

print *, "¿Cuántos bytes almacena z_16bytes?: ", kind(z_16bytes)

end program tipos_compl

Constantes, variables y tipos de datos/tipos_compl.f90


      MODULE MATRIXUTIL
          USE CONFIG

          IMPLICIT NONE
          PRIVATE
          PUBLIC :: MATRIX_PRINT, MATRIX_IDENT, MATRIX_TRANSLATE,
     +              MATRIX_SCALE, MATRIX_ROTATE, MATRIX_MULT
      CONTAINS
          SUBROUTINE MATRIX_PRINT(MATRIX)
              REAL(DP), INTENT(IN) :: MATRIX(:, :)
              INTEGER :: ROW, COL
              DO ROW=1, SIZE(MATRIX, 2)
                  WRITE (0,'(*(F10.3))')
     +              (MATRIX(COL, ROW), COL=1, SIZE(MATRIX, 1))
              ENDDO
          END SUBROUTINE MATRIX_PRINT

          PURE SUBROUTINE MATRIX_IDENT(M)
              REAL(DP), INTENT(INOUT) :: M(:, :)
              INTEGER :: I

              M(:, :) = 0
              FORALL(I = 1:MIN(SIZE(M, 1), SIZE(M, 2))) M(I, I) = 1
          END SUBROUTINE MATRIX_IDENT

          PURE SUBROUTINE MATRIX_TRANSLATE(M, S)
              REAL(DP), INTENT(INOUT) :: M(:, :)
              REAL(DP), INTENT(IN)    :: S(3)
              INTEGER :: I

              CALL MATRIX_IDENT(M)
              FORALL(I = 1:3) M(4, I) = S(I)
          END SUBROUTINE MATRIX_TRANSLATE

          PURE SUBROUTINE MATRIX_SCALE(M, S)
              REAL(DP), INTENT(INOUT) :: M(:, :)
              REAL(DP), INTENT(IN)    :: S(3)
              INTEGER :: I

              CALL MATRIX_IDENT(M)
              FORALL (I = 1:MIN(SIZE(M, 1), SIZE(M, 2), 3))
                  M(I, I) = M(I, I) * S(I)
              END FORALL
          END SUBROUTINE MATRIX_SCALE

          PURE SUBROUTINE MATRIX_ROTATE(M, S, D)
              REAL(DP), INTENT(INOUT) :: M(:, :)
              REAL(DP), INTENT(IN)    :: S
              INTEGER,  INTENT(IN)    :: D  ! 1: X, 2: Y, 3: Z
              INTEGER                 :: I
              REAL(DP)                :: X(4)
              INTEGER, PARAMETER :: RM(2, 4, 3) =
     +          RESHAPE([2,2, 2,3, 3,2, 3,3,
     +                   1,1, 3,1, 1,3, 3,3,
     +                   1,1, 1,2, 2,1, 2,2], [2, 4, 3])

              X = [COS(S), -SIN(S), SIN(S), COS(S)]
              CALL MATRIX_IDENT(M)
              FORALL (I = 1:4) M(RM(1, I, D), RM(2, I, D)) = X(I)
          END SUBROUTINE MATRIX_ROTATE

          PURE FUNCTION MATRIX_MULT(A, B) RESULT(C)
              !   A   n x m   SIZE(A, 2), SIZE(A, 1)
              !   B   m x p   SIZE(B, 2), SIZE(A, 2)
              !   C   n x p   SIZE(B, 1), SIZE(A, 2)

              REAL(DP), INTENT(IN), DIMENSION(:, :) :: A, B
              REAL(DP) :: C(SIZE(B,1), SIZE(A,2))
              INTEGER  :: I, J, K

              C(:, :) = 0
              DO I = 1, SIZE(A, 2)
                  DO J = 1, SIZE(B, 2)
C                     DO K = 1, SIZE(B, 1)
                      C(:, I) = C(:, I) + A(J, I) * B(:, J)
C                     END DO
                  END DO
              END DO
          END FUNCTION MATRIX_MULT   ! possibly faster than MATMUL()
      END MODULE MATRIXUTIL


module procedures
implicit none
contains

subroutine writes2d (A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   integer :: n, m, i, j

   n = size(A, 1)
   m = size(A, 2)

   do i = 1,n
      write(*,'(20F8.3)') (A(i,j), j = 1, m)
   end do
   write(*,*)
end subroutine writes2d

subroutine writes1d (A)
   real(kind=8), allocatable, dimension(:), intent(in) :: A
   integer :: n, i

   n = size(A)

!   write(*,*) (A(i), i = 1, n)
   write(*,'(20F8.3)') (A(i), i = 1, n)
   write(*,*)
end subroutine writes1d

function inv(A) result(Ainv)
  real(kind=8), dimension(:,:), intent(in) :: A
  real(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

  real(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: n, info

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A,1)

  ! DGETRF computes a LU factorization of a general M-by-N matrix
  call DGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     stop 'Matrix is numerically singular!'
  end if

  ! DGETRI computes the inverse of a matrix using the LU factorization
  ! computed by DGETRF.
  call DGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if

end function inv

real(kind=8) function matnorm_inf(A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   real(kind=8), allocatable, dimension(:) :: rowsums
   integer :: n, i, j

   n = size(A,1)
   allocate(rowsums(n))

   do i = 1, n
      rowsums(i) = 0.0
      do j = 1, n
         rowsums(i) = rowsums(i) + dabs(A(i,j))
      end do
   end do

   matnorm_inf = maxval(rowsums)
   deallocate (rowsums)
end function matnorm_inf

real(kind=8) function matnorm_one(A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   real(kind=8), allocatable, dimension(:) :: columnsums
   integer :: n, i, j

   n = size(A,1)
   allocate(columnsums(n))

   do i = 1, n
      columnsums(i) = 0.0
      do j = 1, n
         columnsums(i) = columnsums(i) + dabs(A(j,i))
      end do
   end do

   matnorm_one = maxval(columnsums)
   deallocate (columnsums)
end function matnorm_one

subroutine TrueRelativeError_infinity_norm (A, residual, X_new, TRE)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   real(kind=8), allocatable, dimension(:), intent(in) :: X_new, residual

   real(kind=8), allocatable, dimension(:,:) :: work_matrix, work_residual
   real(kind=8), intent(out) :: TRE

   allocate (work_matrix (size(A,1),size(A,2)), work_residual(size(residual),1))

   work_matrix = matmul(inv(A),work_residual)
   TRE = matnorm_inf(work_matrix)/maxval(X_new)

end subroutine TrueRelativeError_infinity_norm

subroutine TrueRelativeError_one_norm (A, residual, X_new, TRE)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   real(kind=8), allocatable, dimension(:), intent(in) :: X_new, residual

   real(kind=8), allocatable, dimension(:,:) :: work_matrix, work_residual
   real(kind=8), intent(out) :: TRE

   allocate (work_matrix (size(A,1),size(A,2)), work_residual(size(residual),1))

   work_matrix = matmul(inv(A),work_residual)
   TRE = matnorm_one(work_matrix)/sum(X_new)

end subroutine TrueRelativeError_one_norm

subroutine Gauss_Siedel (A, B, X_old, n, tolerance, X_new)
   real(kind=8), allocatable, dimension(:,:), intent(inout) :: A
   real(kind=8), allocatable, dimension(:), intent(in) :: B
   real(kind=8), allocatable, dimension(:), intent(inout) :: X_old
   integer, intent(in) :: n
   real(kind=8), intent(in) :: tolerance
   real(kind=8), allocatable, dimension(:), intent(out) :: X_new
   real(kind=8), allocatable, dimension(:) :: residual, residual_abs
   integer :: i, j, iters
   real(kind=8) TRE_inf, TRE_one

   allocate ( X_new(n), residual(n), residual_abs(n) )

   do i = 1, n
      residual_abs(i) = i !initialize
   end do

   open (unit=9, file='plot.dat', status='new', action='write')

   iters = 0
   do while (maxval(residual_abs) .ge. tolerance)
      ! Find [x]:
      do i = 1, n
         X_new(i) = B(i)
         do j = 1, i-1
            X_new(i) = X_new(i) - A(i,j)*X_new(j)
         end do
         do j = i+1, n
            X_new(i) = X_new(i) - A(i,j)*X_old(j)
         end do
         X_new(i) = X_new(i)/A(i,i)
      end do
      iters = iters + 1
      ! Determine the residual:
      do i = 1, n
         residual(i) = B(i)
         do j = 1, n
            residual(i) = residual(i) - A(i,j)*X_new(j)
         end do
      end do
      do i = 1, n
         residual_abs(i) = dabs(residual(i))
      end do
      !Determine the true relative error:
      call TrueRelativeError_infinity_norm (A, residual, X_new, TRE_inf)
      call TrueRelativeError_one_norm (A, residual, X_new, TRE_one)
      ! Write the output:
      write(*,*)
      write(*,*) "---------------------------------------------"
      write(*,*) "iteration:", iters
      write(*,*) "---------------------------------------------"
      call writes1d(X_new)
      write(*,*)
      write(*,*) "residual:"
      call writes1d(residual)
      write(*,*) "TrueRelativeEror (infinity norm), rueRelativeEror (one norm)"
      write(*,*) TRE_inf, TRE_one
      write(*,*)
      write(9,*) iters, maxval(residual_abs)
      do i = 1, n
         X_old(i) = X_new(i)
      end do
   end do

   close(9)
end subroutine Gauss_Siedel

end module procedures


PROGRAM tminim

! Use minim to maximize the objective function:

! 1/{1 + (x-y)^2} + sin(pi.y.z/2) + exp[-{(x+z)/y - 2}^2]

! with respect to x, y and z.
! We will actually minimize its negative.
! The maximum occurs at x = y = z = +/-sqrt(4n+1) for any integer n.

USE Nelder_Mead
IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)
REAL (dp)          :: object, p(3), simp, step(3), stopcr, var(3)
INTEGER            :: ier, iprint, iquad, maxf, nloop, nop
LOGICAL            :: first

INTERFACE
  SUBROUTINE objfun(p, func)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(14, 60)
    REAL (dp), INTENT(IN)  :: p(:)
    REAL (dp), INTENT(OUT) :: func
  END SUBROUTINE objfun
END INTERFACE

! Set up starting values & step sizes.
! Parameters p(1), p(2), p(3) are x, y & z.

p(1) = 0._dp
p(2) = 1._dp
p(3) = 2._dp
step = 0.4_dp
nop = 3

! Set max. no. of function evaluations = 250, print every 10.

maxf = 250
iprint = 10

! Set value for stopping criterion.   Stopping occurs when the
! standard deviation of the values of the objective function at
! the points of the current simplex < stopcr.

stopcr = 1.d-04
nloop = 6

! Fit a quadratic surface to be sure a minimum has been found.

iquad = 1

! As function value is being evaluated in REAL (dp), it
! should be accurate to about 15 decimals.   If we set simp = 1.d-6,
! we should get about 9 dec. digits accuracy in fitting the surface.

simp = 1.d-6

! Now call MINIM to do the work.

first = .true.
DO
  CALL minim(p, step, nop, object, maxf, iprint, stopcr, nloop,   &
             iquad, simp, var, objfun, ier)

! If ier > 0, try a few more function evaluations.

  IF (ier == 0) EXIT
  IF (.NOT. first) STOP
  first = .false.
  maxf = 100
END DO

! Successful termination.

WRITE(*, 900) object, p
900 FORMAT(' Success !'/' Objective function = ', f12.6/ ' at: ', 3f12.6)
WRITE(*, 910) var
910 FORMAT(' Elements of var = ', 3f12.6)

STOP

END PROGRAM tminim

SUBROUTINE objfun(p, func)

! This is the subroutine which the user must write.
! Remember that we are minimizing the negative of the function we
! really want to maximize.

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(14, 60)
REAL (dp), INTENT(IN)  :: p(:)
REAL (dp), INTENT(OUT) :: func

!     Local variables

REAL (dp), PARAMETER :: half = 0.5_dp, one = 1._dp, pi = 3.14159265357989_dp, &
                        two = 2._dp
REAL (dp)            :: x, y, z

x = p(1)
y = p(2)
z = p(3)
func = -one/(one + (x-y)**2) - SIN(half*pi*y*z) - EXP(-((x+z)/y - two)**2)
RETURN
END SUBROUTINE objfun


program isingmodel

! JS: NOTE:  There is a book on reserve in the science library,
! JS:  David Chandler, "Introduction to Modern Statistical Mechanics"
! JS:  that describes both the Ising model and the Monte Carlo procedure
! JS:  in some depth.  It might be a useful resource if you get stuck.

! array, defining variables

implicit none
real :: kT, E, E2, M, C, paccept,ptrial, Estart,Eflip, Etot

integer :: col, row, east,west,north,south
integer :: nMC
integer, parameter :: numL = 24 ! the number of row or column
integer, parameter :: J = -1    ! define a ferromagnetic system
integer, dimension(:,:), allocatable :: spin

allocate(spin(numL,numL))

! random number generator
call random_seed()

! initialized our spin array
do col=1,numL
   do row=1,numL
      call random_number(paccept)
      if (paccept .lt. 0.5) then
         spin(col,row) = +1
      else
         spin(col,row) = -1
      end if
   end do
end do
write(*,*), 'print the initial configurations :', spin
! program structure:

! defining the loops (and what do we mean by loops)

! loop over temperature (kT in units of the coupling, J)

do kT=4.0, 0.1, -0.05      !JS: Start at kT=4, and go to kT=0.1 in steps of -0.05

! JS: First, run a set of MC steps to equilibrate our system.
! JS: In other words, so that the configuration of the spins is
! JS: in an equilibrium configuration consistent with Boltzman's laws
! JS: for the particular temperature

! loop MC trials
   do nMC=1,10000

! spatial loop in the 2D plane (incorporate pbc <periodic boundary condition> )

      do col=1,numL
         do row=1,numL

            east = col+1
            west = col-1
            north = row-1
            south = row+1

            if (col.eq.1) west = numL
            if (col.eq.numL) east = 1
            if (row.eq.1) north = numL
            if (row.eq.numL) south = 1

! try flip a spin at position (col,row)
! calculate energy (function)

            Estart = J*(spin(col,row)*spin(east,row) &
                 + spin(col,row)*spin(west,row) &
                 + spin(col,row)*spin(col,north) &
                 + spin(col,row)*spin(col,south) )

            Eflip =  J*((-spin(col,row))*spin(east,row) &
                 + (-spin(col,row))*spin(west,row) &
                 + (-spin(col,row))*spin(col,north) &
                 + (-spin(col,row))*spin(col,south) )

! acceptance/rejectance for MC algorithm (define as subroutine?)

            if (Eflip .lt. Estart) then
               spin(col,row) = -spin(col,row)
            else
               call random_number(paccept)
               ptrial = EXP(-(Eflip-Estart)/kT)

               if (paccept .lt. ptrial) then
                  spin(col,row) = -spin(col,row)
               end if
            end if

         end do
      end do

   end do  ! loop over nMC

!Caculate the total energy of the final configuration

! JS: Now that the above has finished, and we are in equilibrium,
! JS: run another MC cycle again, this time to collect statistics
! JS:  In other words, another do-loop over nMC, row, col, etc.
! JS:  flipping spins as appropriate, etc.

! JS: BUT now, every time (mod(nMC, 50) .eq. 0), collect E, E^2, M to calculate
! JS: averages.  This E will have to be the total energy of the entire system
! JS: calculated over all the spins.  You might want to create functions to
! JS: give you the value of E, M, E^2, or you could just do it inline.

! JS: When the datacollection is over (you have completed this second run of
! JS: nMC steps), it will be time to output the averages.

!OUTPUT:  Graphs; (Averages) Heat Capacity (<E^2>-<E>^2, ;derivative of <E(T)>,
! Temperature, Energy <E> (to get Heat Capacity), Magnetization <M>
! JS: (You will want to report these as an intensive property,
! JS:  i.e., <E>/N, C/N, <M>/N, where N is the total number of spins (16*16)

end do     !JS: loop over kT values (slowly cooling the system by lowering kT)

call count_Etot(numL,spin,Etot)
write(*,*), 'print the equilibrium configurations :', spin
write(*,*),"Temperature =", kT
write(*,*),"the total energy at this Temperature =", Etot
deallocate(spin)

contains

subroutine count_Etot(numL,spin,Etot)
implicit none
integer,intent(in)  :: numL
integer,dimension(numL,numL),intent(in)  :: spin
real,intent(out) :: Etot
Etot = sum(spin)
end subroutine count_Etot

end program isingmodel


PROGRAM LAPLACE
    INTEGER, PARAMETER :: XSIZE=101,YSIZE=101
    REAL(8), DIMENSION(1:XSIZE,1:YSIZE) :: PHIOLD,PHINEW,ERROR
    REAL :: MAXDELTA
    REAL(8) :: ERRORSUM,NSQ=XSIZE*YSIZE

    REAL(8), PARAMETER :: CONVERGENCE = EPSILON(ERRORSUM)
    INTEGER :: ITERATIONS = 0

    INTEGER :: I,J

    DO I=1,XSIZE
        DO J=1,YSIZE
            PHINEW(I,J) = (I*I-J*J)/(NSQ)
        END DO
    END DO

    PHINEW(2:XSIZE-1,2:YSIZE-1)=0

    open(10,file='jacobi_101.csv')

    JACOBI_ITERATION: DO
        ITERATIONS = ITERATIONS+1
        PHIOLD=PHINEW

        PHINEW(2:XSIZE-1,2:YSIZE-1)=0.25*(&
            &PHIOLD(1:XSIZE-2,2:YSIZE-1)+&
            &PHIOLD(3:XSIZE,2:YSIZE-1)+&
            &PHIOLD(2:XSIZE-1,1:YSIZE-2)+&
            &PHIOLD(2:XSIZE-1,3:YSIZE))
        ERROR = PHIOLD-PHINEW
        ERRORSUM = SQRT(SUM(ERROR*ERROR)/NSQ)
        write(10,*) ERRORSUM, ITERATIONS
        IF (ERRORSUM < 2*CONVERGENCE) EXIT JACOBI_ITERATION

     END DO JACOBI_ITERATION

    close(10)
END PROGRAM LAPLACE


subroutine shape1(s,nnode,shape,deriv)

!-----------------------------------------------------------------------
!
! This routine evaluates shape functions and their first derivates
! for 1-d continuos with 2 3 4 & 5 nodes
!
!-----------------------------------------------------------------------

  use      typre
  implicit none
  integer(ip), intent(in)  :: nnode
  real(rp),    intent(in)  :: s
  real(rp),    intent(out) :: deriv(nnode), shape(nnode)
  real                     :: s1, s2, s3, s4, a, c

  if(nnode==2) then
     shape(1)= 0.5_rp*(1.0_rp-s)              !  1    2
     shape(2)= 0.5_rp*(1.0_rp+s)
     deriv(1)=-0.5_rp
     deriv(2)= 0.5_rp
  else if(nnode==3) then
     shape(1)= 0.5_rp*s*(s-1.0_rp)            !  1    3    2
     shape(2)= 0.5_rp*s*(s+1.0_rp)
     shape(3)=-(s+1.0_rp)*(s-1.0_rp)
     deriv(1)= s-0.5_rp
     deriv(2)= s+0.5_rp
     deriv(3)=-2.0_rp*s
  else if(nnode==4) then
     a = 9.0_rp/16.0_rp
     s1= s + 1.0_rp
     s2= s - 1.0_rp
     s3= s + 1.0_rp/3.0_rp
     s4= s - 1.0_rp/3.0_rp
     c = 3.0_rp*a
     shape(1)= -a*s2*s3*s4                    !  1    3    4    2
     shape(2)=  a*s1*s3*s4
     shape(3)=  c*s1*s2*s4
     shape(4)= -c*s1*s2*s3
     deriv(1)= - a*(s2*s3+s2*s4+s3*s4)
     deriv(2)=   a*(s1*s3+s1*s4+s3*s4)
     deriv(3)=   c*(s1*s2+s1*s4+s2*s4)
     deriv(4)= - c*(s1*s2+s1*s3+s2*s3)
! * * * * * * * * * * * * * * * * * *
! *Valores calculados para nnode=5  *
! * * * * * * * * * * * * * * * * * *
  else if(nnode==5) then
     s1 = s + 1.0_rp
     s2 = s - 1.0_rp
     s3 = s + 1.0_rp/2.0_rp
     s4 = s - 1.0_rp/2.0_rp
     shape(1) = 2.0_rp/3.0_rp*s*s3*s4*s2     !  1    3    4    5    2
     shape(2) =-8.0_rp/3.0_rp*s*s1*s4*s2
     shape(3) = 4.0_rp*s1*s3*s4*s2
     shape(4) =-8.0_rp/3.0_rp*s*s1*s3*s2
     shape(5) = 2.0_rp/3.0_rp*s*s1*s3*s4
     deriv(1) = 2.0_rp/3.0_rp*(s*s3*s4+s*s3*s2+s*s4*s2+s3*s4*s2)
     deriv(2) =-8.0_rp/3.0_rp*(s*s1*s4+s*s1*s2+s*s4*s2+s1*s4*s2)
     deriv(3) =        4.0_rp*(s1*s3*s4+s1*s3*s2+s1*s4*s2+s3*s4*s2)
     deriv(4) =-8.0_rp/3.0_rp*(s*s1*s3+s*s1*s2+s*s3*s2+s1*s3*s2)
     deriv(5) = 2.0_rp/3.0_rp*(s*s1*s3+s*s1*s4+s*s3*s4+s1*s3*s4)

  end if
!  a= 0.0_rp
!  c= 0.0_rp
!  a = a + shape(1)+ shape(2)+ shape(3)+ shape(4)
!  c = c + deriv(1)+ deriv(2)+ deriv(3)+ deriv(4)

end subroutine shape1


! chk_norm2_hypot.f90 --
!     Check if the compiler supports the new NORM2 and HYPOT functions
!
!     Note: there is a whole list of such special functions defined for the Fortran 2008 standard, not
!     all of them are tested here
!
!     For an extensive discussion of the calculation of the Euclidean norm:
!     https://www.researchgate.net/publication/298896236
!
program chk_norm2_hypot
    implicit none

    real, dimension(4) :: vector = (/ 1.0, 2.0, 3.0, 4.0 /)
    real               :: x = 3.0, y = 4.0

    write( *, '(a)' )              'HYPOT function - the (3,4,5) triangle'
    write( *, '(a,2f7.4,a,f7.4)' ) 'The hypothenusa of a rectangular triangle with sides', x, y, ' is ', hypot(x,y)

    write( *, '(a)' )              '2-norm of a vector:'
    write( *, '(a,4f10.4)' )       'Vector:                      ', vector
    write( *, '(a,f10.4)' )        'Euclidean norm of the vector:', norm2(vector)

    !
    ! Special attention to very large values - ideally there should be no overflow
    !
    vector(1:2) = (/ (3.0/10.0) * huge(x), (4.0/10.0) * huge(x) /)

    write( *, '(a)' )              '2-norm of a vector with very large components:'
    write( *, '(a,2e14.4)' )       'Vector:        ', vector(1:2)
    write( *, '(a,e14.4)' )        'Euclidean norm:', norm2(vector(1:2))
    write( *, '(a,e14.4)' )        'Expected:      ', (5.0/10.0) * huge(x)

    !
    ! Special attention to very small values - ideally there should be no underflow
    !
    vector(1:2) = (/ 30.0 * tiny(x), 40.0 * tiny(x) /)

    write( *, '(a)' )              '2-norm of a vector with very large components:'
    write( *, '(a,2e14.4)' )       'Vector:        ', vector(1:2)
    write( *, '(a,e14.4)' )        'Euclidean norm:', norm2(vector(1:2))
    write( *, '(a,e14.4)' )        'Expected:      ', 50.0 * tiny(x)

end program chk_norm2_hypot


      program aritmetica
        implicit none

        real :: pi
        real :: radio_cilindro
        real :: altura_cilindro
        real :: area_cilindro
        real :: volumen_cilindro

        pi=3.1415926535
        !  3.14159265358979323846264338

        print *, 'Introduzca el radio de la base del cilindro:'
        read(*,*) radio_cilindro

        print *, 'Introduzca la altura del cilindro:'
        read(*,*) altura_cilindro

        area_cilindro = pi*radio_cilindro**2.0
        volumen_cilindro = area_cilindro*altura_cilindro

        print *, 'Radio del cilindro: ', radio_cilindro
        print *, 'Altura del cilindro: ',altura_cilindro
        print *, 'Area del cilindro: ',area_cilindro
        print *, 'Volumen del cilindro: ',volumen_cilindro
      end program aritmetica


DOUBLE PRECISION FUNCTION  D_H(N_SITES,N_PARTICLES,stats)

  !Calculates the number of states of N_particles Bosons/Ferminos in N_sites lattice sites
  ! Wikipedia:
  ! D_B  = (N_particles + N_sites - 1)!)/(N_particles! * (L-1)!)))
  ! D_F  = N_sites!/(N_particles! (N_sites-N_particles)!)))

    !N_SITES      (IN): INTEGER, number of lattice sites
    !N_PARTICLES  (IN): INTEGER, umber of partcles
    !stats        (IN)! 'F' or 'B' for Fermions or Bosons, respectively

  IMPLICIT NONE
  INTEGER, INTENT(IN):: N_SITES,N_PARTICLES
  CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: stats

  INTEGER          :: N_,K_,i
  DOUBLE PRECISION :: Num,Den,N_STATES

  IF(PRESENT(stats)) THEN
     SELECT CASE (stats)
     CASE("B")

         IF(N_PARTICLES.GT.1) THEN
            N_ = N_SITES+N_PARTICLES-1;
            K_ = N_PARTICLES;
            write(*,*) N_,k_
            Num = 1.0;
            do while (n_.gt.0)
                Num = Num*n_;
                n_ = n_-1;
            end do
            Den = 1.0;
            do while (k_.gt.0)
                Den = Den*k_;
                k_ = k_-1;
            end do
         ELSE
             num = n_sites
             den = 1
         END IF

     CASE("F")
        N_STATES = N_SITES
        N_ = N_STATES
        Num = 1.0;
        do while (n_.gt.0)
           Num = Num*n_
           n_ = n_-1;
        end do
        k_ = N_STATES - N_PARTICLES
        Den = 1.0
        do while (k_.gt.0)
           Den = Den*k_;
           k_ = k_-1;
        end do
        k_ = N_PARTICLES
        do while (k_.gt.0)
           Den = Den*k_;
           k_ = k_-1;
        end do

     CASE DEFAULT
        D_H = N_SITES
     END SELECT

     D_H = Num/Den;

  ELSE

     D_H = N_SITES

  END IF

END FUNCTION D_H

MODULE CREATIONDESTRUCTION

  implicit none
  private
  public :: A_DAGGER,A_,TUNNELING_,TUNNELING_F_

  interface A_DAGGER
    procedure A_DAGGER_INT,A_DAGGER_REAL
  end interface A_DAGGER

  interface A_
    procedure A_INT,A_REAL
  end interface A_

contains
    !Bosonic tunelling
    FUNCTION TUNNELING_(k,STATE) result(NEW_STATE)

        INTEGER, INTENT(IN) :: k
        INTEGER, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        NEW_STATE      = STATE
        IF(STATE(K).GT.0) THEN
            NEW_STATE(k)   = NEW_STATE(k) - 1
            NEW_STATE(k+1) = NEW_STATE(k+1) + 1
        ELSE
            NEW_STATE = 0
        END IF

    END FUNCTION TUNNELING_

    !FERMIONIC  tunelling
    FUNCTION TUNNELING_F_(k,STATE) result(NEW_STATE)

        INTEGER, INTENT(IN) :: k
        INTEGER, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        NEW_STATE      = STATE
        IF(K.LT.SIZE(STATE,1))THEN
            IF(STATE(K).EQ.1 .AND. STATE(K+1).EQ.0) THEN
                NEW_STATE(k)   = NEW_STATE(k) - 1
                NEW_STATE(k+1) = NEW_STATE(k+1) + 1
            ELSE
                NEW_STATE = 0
            END IF
        ELSE
!            write(*,*) 'mw,k',k,state(k),state(k-1)
            IF(STATE(K).EQ.1 .AND. STATE(K-1).EQ.0) THEN
                NEW_STATE(k)   = NEW_STATE(k) - 1
                NEW_STATE(k-1) = NEW_STATE(k-1) + 1
            ELSE
                NEW_STATE = 0
            END IF
        END IF

    END FUNCTION TUNNELING_F_

    !BOSONIC CREATION AND DESTRUCTION OPERATORE
    FUNCTION A_DAGGER_INT(k,STATE) result(NEW_STATE)

        INTEGER, INTENT(IN) :: k
        INTEGER, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        !WRITE(*,*) k,NEW_STATE
        NEW_STATE    = STATE
        NEW_STATE(k) = NEW_STATE(k) + 1
        NEW_STATE    = SQRT(1.0*NEW_STATE(K))*NEW_STATE
               !WRITE(*,*) k,NEW_STATE
    END FUNCTION A_DAGGER_INT

    FUNCTION A_DAGGER_REAL(k,STATE) result(NEW_STATE)

        INTEGER, INTENT(IN) :: k
        DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        NEW_STATE    = STATE
        !WRITE(*,*) k,NEW_STATE
        NEW_STATE(k) = NEW_STATE(k) + 1
        NEW_STATE    = SQRT(1.0*NEW_STATE(K))*NEW_STATE
        !WRITE(*,*) k,NEW_STATE
    END FUNCTION A_DAGGER_REAL

    FUNCTION A_INT(k,STATE) result(NEW_STATE)
    !A_DAGGER |n> = sqrt(n+1) |n+1>
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: K
        INTEGER, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        NEW_STATE    = STATE
!        WRITE(*,*) k,NEW_STATE
        IF(STATE(k).GT.0) THEN
            NEW_STATE(k) = NEW_STATE(k) - 1
            NEW_STATE    = SQRT(1.0*NEW_STATE(K))*NEW_STATE
        ELSE
            NEW_STATE =0
        END IF
 !       WRITE(*,*) k,NEW_STATE
    END FUNCTION A_INT

    FUNCTION A_REAL(k,STATE) result(NEW_STATE)
    !A_DAGGER |n> = sqrt(n+1) |n+1>
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: K
        DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: STATE

        DOUBLE PRECISION, DIMENSION(SIZE(STATE,1)) :: NEW_STATE

        NEW_STATE    = STATE
        IF(STATE(k).GT.0) THEN
            NEW_STATE(k) = NEW_STATE(k) - 1
            NEW_STATE    = SQRT(1.0*NEW_STATE(K))*NEW_STATE
        ELSE
            NEW_STATE =0
        END IF
    END FUNCTION A_REAL

end module   CREATIONDESTRUCTION

SUBROUTINE Manybody_basis(D_BARE,N_SITES,N_BODIES,STATS,states_occ,INFO)

!   CREATES A MATRIX WITH AS MANY ROWS AS STATES AND AS MANY COLUMNS AS LATTICE SITES
!   EACH ROW OF THIS MATRIX IS A BASIS STATE IN THE OCCUPATION NUMBER
!
!    D_BARE   (IN) INTEGER  : NUMBER OF STATES
!    N_SITES  (IN) INTEGER  : NUMBER OF LATTICE SITES
!    N_BODIES (IN) INTEGER  : NUMBER OF PARTICLES
!    STATS    (IN) CHAR     : 'F' or '' B
!    states_occ (OUT) (D_BARE,N_SITES))      : STATES LABELLED AS OCCUPATION OF THE LATTICE
!    INFO       (INOUT)     : ERROR FLAG

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: D_BARE,N_SITES,N_BODIES
  CHARACTER(LEN=*),INTENT(IN):: stats
  INTEGER, DIMENSION(D_BARE,N_SITES), intent(out) :: states_occ
  INTEGER, INTENT(INOUT) :: INFO

  LOGICAL MORE
  INTEGER i,j,INTEGER_SPACE

  INTEGER, ALLOCATABLE,DIMENSION(:) :: STATE_

  i = 0
  STATES_OCC = 0
  MORE = .FALSE.

  INFO = 0
  SELECT CASE (stats)
  CASE("B")
     ALLOCATE(STATE_(N_SITES))
     STATE_ = 0
     STATE_(1) = N_BODIES
     DO i=1,D_BARE
        CALL COMP_NEXT(N_BODIES,N_SITES,STATE_,MORE) ! DEFINED IN subset.f90
        STATES_OCC(i,:) = STATE_
        !write(*,*) state_
     END DO

  CASE("F")

     IF(N_BODIES .LE. 2*N_SITES) THEN
        ALLOCATE(STATE_(N_SITES))
        STATE_=0
        j  =1
        INTEGER_SPACE = 2**N_SITES -1
        DO i=1,INTEGER_SPACE

            CALL BVEC_NEXT_GRLEX(N_SITES,STATE_) ! DEFINED IN bvec.f90
            IF(SUM(STATE_) .EQ. N_BODIES) THEN
                STATES_OCC(j,:) = STATE_
                !write(*,*) j
                j=j+1
            ELSE

            END IF
        END DO
     ELSE
        WRITE(*,*) "ERROR"
        WRITE(*,*) "THE NUMBER OF PARTICLES IS LARGER THAN THE NUMBER OF AVAILABLE STATES"
        INFO  = -1
     END IF

  END  SELECT

END SUBROUTINE Manybody_basis

SUBROUTINE TENSORMULT(N,A,B,C,INFO)
    ! TENSOR MULTIMPLICATION OF MATRICES A AND B TO PRODUCE C
    !N, INTEGER(3), IN: DIMENSION OF MATRIX A,B,C  N(1,2,3), RESPECTIVELY
    !A  COMPLEX*18, DIMENSION (N(1),N(2)), IN
    !B  COMPLEX*18, DIMENSION (N(1),N(2)), IN
    !C  COMPLEX*18, DIMENSION (N(3),N(3)), OUT
    !INFO: ERROR FLAG
    IMPLICIT NONE
    INTEGER, DIMENSION(3), INTENT(IN) :: N
    INTEGER, INTENT(INOUT) :: INFO
    COMPLEX*16, DIMENSION(N(1),N(1)), INTENT(IN) :: A
    COMPLEX*16, DIMENSION(N(2),N(2)), INTENT(IN) :: B
    COMPLEX*16, DIMENSION(N(3),N(3)), INTENT(OUT) :: C

    INTEGER i,j,r

    !WRITE(*,*) A
    !WRITE(*,*) B
    !write(*,*) N
    DO i=1,N(2)
        DO j=1,N(2)
            !if(abs(B(i,j)).gt.0) then
            !    do r=1,size(a,1)
            !     write(*,*) abs(A(r,:))
            !    end do
            !    write(*,*)
            !    write(*,*)
            !    write(*,*) (i-1)*N(1)+1,i*N(1),(j-1)*N(1)+1,j*N(1)
            !end if
            C((i-1)*N(1)+1:i*N(1),(j-1)*N(1)+1:j*N(1)) = A*B(i,j)
        END DO
    END DO

END SUBROUTINE TENSORMULT


C PROGRAM FOR LAGRANGE INTERPOLATION
C GAURAV RUDRA MALIK; ROLL NO : 23
	DIMENSION X(100),F(100)
	WRITE(*,*)'ENTER THE NUMBER OF TERMS; MAX: 100'
	READ(*,*) I
	WRITE(*,*)'ENTER THE VALUE OF X AND THE CORRESPONDING VALUE OF F(X)'
	DO 1 J=1,I
	READ(*,*),X(J),F(J)
1	CONTINUE
	WRITE(*,*)'THE ENTERED VALUES ARE'
	DO 2 J=1,I
	WRITE(*,3)X(J),F(J)
2	CONTINUE
3	FORMAT(F12.6'	'F12.6)
	A=X(1)
	B=X(1)
	DO 4 J=1,I
	IF(X(I).GT.A)THEN
	A=X(I)
	ENDIF
	IF(X(I).LT.B)THEN
	B=X(I)
	ENDIF
4	CONTINUE
	WRITE(*,*)'ENTER THE NUMBER AT WHICH THE VALUE OF FUNCTION IS REQUIRED'
5	READ(*,*),E
	IF((E.GT.A).OR.(E.LT.B))THEN
	WRITE(*,*)'INVALID INPUT FOR INTERPOLATION, ENTER AGAIN'
	GOTO 5
	ENDIF
	C=1.0
	D=1.0
	S=0.0
	DO 7 J=1,I
	D=1.0
	DO 6 K=1,I
	IF(J.NE.K) THEN
	C=(E-X(K))/(X(J)-X(K))
	D=D*C
	ENDIF
6	CONTINUE
	D=D*F(J)
	S=S+D
7	CONTINUE
	WRITE(*,*)'THE VALUE INTERPOLATED AT X =',E,' IS FOUND TO BE',S
	STOP
	END

RESULT

 ENTER THE NUMBER OF TERMS; MAX: 100
10
 ENTER THE VALUE OF X AND THE CORRESPONDING VALUE OF F(X)
1
3
2
6
3
11
4
18
5
27
6
38
7
51
8
66
9
83
10
102
 THE ENTERED VALUES ARE
    1.000000	    3.000000
    2.000000	    6.000000
    3.000000	   11.000000
    4.000000	   18.000000
    5.000000	   27.000000
    6.000000	   38.000000
    7.000000	   51.000000
    8.000000	   66.000000
    9.000000	   83.000000
   10.000000	  102.000000
 ENTER THE NUMBER AT WHICH THE VALUE OF FUNCTION IS REQUIRED
4.5
 THE VALUE INTERPOLATED AT X =  4.5 IS FOUND TO BE  22.25


module gauss_seidel
    implicit none
    public solve, gauss_seidel_iter

contains
function solve(a, x_initial, b, n, atol, rtol, relaxation) result(x_new)
    integer, intent(in) :: n
    real(8), intent(in) :: atol, rtol
    real(8), intent(in) :: x_initial(n)
    real(8), intent(in) :: b(n)
    real(8), intent(in) :: a(n, n)
    real(8), intent(in), optional :: relaxation
    !f2py real(8) :: relaxation = 1

    integer :: i
    real(8) ::  x_new(n), x_old(n), w = 1.d0

    if (present(relaxation)) w = relaxation

    x_new = x_initial

    do
        do i = 1, n
            x_old = x_new
            x_new(i) = gauss_seidel_iter(a, x_new, x_old, b, n, i)
            x_new(i) = x_old(i) + w*(x_new(i)-x_old(i))
        end do
        print*, x_new
        if(maxval(abs(x_new-x_old)) < atol + rtol * maxval(abs(x_new))) exit
    end do
    return
end function solve

pure real(8) function gauss_seidel_iter(a, x_new, x_old, b, n, i)
    integer, intent(in) :: n
    integer, intent(in) :: i
    real(8), intent(in) :: x_new(n)
    real(8), intent(in) :: x_old(n)
    real(8), intent(in) :: b(n)
    real(8), intent(in) :: a(n, n)

    gauss_seidel_iter = 1.d0/a(i,i) * (b(i) - &
                    sum(a(i,:i-1)*x_new(:i-1)) &
                    - sum(a(i,i+1:)*x_old(i+1:)))
    return
end function gauss_seidel_iter
end module gauss_seidel


module reg_mod
implicit none
contains
subroutine linear_regression(x,y,slope,intcep,ierr)
! regress y(:) on x(:), where size(x) == size(y)
real   , intent(in)            :: x(:),y(:)
real   , intent(out)           :: slope,intcep
integer, intent(out), optional :: ierr
integer                        :: ierr_,n
real                           :: xmean,ymean
if (present(ierr)) ierr = 0
n = size(x)
ierr_ = findloc([n>1, size(y)==n],.false.,dim=1)
if (ierr_ /= 0) then
   if (present(ierr)) then
      ! if error flag passed, set it and return
      ierr = ierr_
      return
   else
      ! otherwise stop
      print*,"in linear_regression, ierr_ =",ierr_
      error stop
   end if
end if
xmean  = sum(x)/n
ymean  = sum(y)/n
slope  = sum((x-xmean)*(y-ymean))/sum((x-xmean)**2)
! should check that denominator above is nonzero
intcep = ymean - slope*xmean
end subroutine linear_regression
end module reg_mod
!
program test_reg
use reg_mod, only: linear_regression
implicit none
integer, parameter :: n = 10**3
real :: x(n),y(n),noise(n),slope,intcep
integer :: ierr
call random_seed()
call random_number(x)
call random_number(noise)
y = 5*x + 3 + (noise - 0.5)
call linear_regression(x,y,slope,intcep)
print "('slope, intercept =',2(1x,f0.4))",slope,intcep
! pass error flag ierr
call linear_regression(x(2:),y,slope,intcep,ierr)
if (ierr /= 0) print*,"after linear_regression, ierr =",ierr
! no error flag passed -- stop in procedure upon error
call linear_regression(x(2:),y,slope,intcep)
end program test_reg
! sample output:
! slope, intercept = 4.9824 3.0011
!  after linear_regression, ierr =           2
!  in linear_regression, ierr_ =           2
! ERROR STOP


module difference_of_squares
  contains
  integer function square_of_sum(n)
    implicit none
    integer :: i,n

    square_of_sum = 0

    do i = 1,n
      square_of_sum = square_of_sum + i
    end do

    square_of_sum = square_of_sum * square_of_sum
  end function square_of_sum

  integer function sum_of_squares(n)
    implicit none
    integer :: i, n

    sum_of_squares = 0

    do i = 1,n
      sum_of_squares = sum_of_squares + i**2
    end do

  end function sum_of_squares

  integer function difference(n)
    implicit none
    integer :: n

    difference = square_of_sum(n) - sum_of_squares(n)
  end function difference

end module difference_of_squares


program ilist05s512
! CAP372 - exercise 5 - 2019-09-15
! - Each subtask i hold one row of matrix A and one column of matrix B .
! - The result is stored in one element of C .
! - After that, every subtask i, 0≤i<n, transmits its column of matrix B
!   to the subtask with the number (i + 1) mod n .
! - When the number of processors ("p") is less than the number of
!   basic subtasks ("n"), each processor would execute several
!   inner products of matrix A rows and matrix B columns.
! - Each aggregated basic subtask ( = the calculation of one row of C)
!   determines several rows of the result matrix C.
  implicit none
  integer, parameter :: ms = 512      ! matrix size
  integer, parameter :: p = 8         ! emulate the number of processes
  integer :: mi, mj, mk               ! matrix indexes
  double precision :: t1, t2          ! time elapsed
  double precision :: temp1           ! temporary
  integer :: stripe_i, stripe_qtd, stripe_count, stripe_countA   ! stripe
  integer :: interation, subtask      ! looping

  ! C =  A * B, matrix initialization
  double precision, dimension(ms, ms) :: C = 0,       &
    A = reshape([(mi, mi=1, ms*ms)], shape(A)),       &
    B = reshape([(mi, mi=ms*ms+1, ms*ms*2)], shape(A))

  call cpu_time(t1)                   ! elapsed time calculation
  stripe_qtd = ms / p                 ! subtasks per processor
  do interation = 0, ms / stripe_qtd - 1    ! algorithm interation
    do subtask = 0, ms / stripe_qtd - 1     ! each subtask hold one matrix row
      do stripe_countA = 0, stripe_qtd - 1      ! A count for p < n
        do stripe_count = 0,  stripe_qtd - 1    ! count for p < n
          ! stripe column calculation
          stripe_i = stripe_qtd*mod(subtask+p-interation,p)+stripe_count
          ! matrix A line calculation
          mi = subtask * stripe_qtd + 1 + stripe_countA
          temp1 = 0                   ! multiplication: A line x B column
          do mj = 1, ms               ! count A column
            mk = stripe_i + 1         ! B column index
            temp1 = temp1 + A(mi, mj) * B(mj, mk)  ! C = A x B
          end do
          C(mi, mk) = temp1           ! store C element
        end do
      end do
    end do
  end do
  call cpu_time(t2)                   ! elapsed time calculation
  write(*, "(A, I5, A, I3, A, F8.4)") 'Serial version: matrix size:', ms,  &
        ',  Emulated Processes:', p, ',  Elapsed time [s]:', t2 - t1
end program ilist05s512


!---------------------------------------------------------------
program harmonic1
!---------------------------------------------------------------
  !
  !       Solution of the quantum harmonic oscillator.
  !       Forward and backward integration with Numerov method.
  !       Solution matching at a classical turning point.
  !       Eigenvalue search using the shooting method.
  !       Adimensional units: x = (mK/hbar^2)^(1/4) X
  !                           e = E/(hbar omega)
  !
  implicit none
  ! In next line, "dp is the kind having at least 14 significan digits,
  ! range between 10^-200 and 10^200: in practice, double precision
  integer, parameter :: dp = selected_real_kind(14,200)
  !
  integer :: mesh, i, icl
  integer :: nodes, hnodes, ncross, kkk, n_iter
  real(dp) :: xmax, dx, ddx12, norm, arg, djump, fac
  real(dp) :: eup, elw, e
  real(dp), allocatable :: x(:), y(:), p(:), vpot(:), f(:)
  character (len=80) :: fileout
  !
  ! read input data
  !
  write(*,"('Max value for x (typical value: 10) > ')", advance='no')
  read (*,*) xmax
  write(*,"('Number of grid points (typically a few hundreds) > ')", advance='no')
  read (*,*) mesh
  !
  ! allocate arrays, initialize grid
  !
  allocate ( x(0:mesh), y(0:mesh), p(0:mesh), vpot(0:mesh), f(0:mesh) )
  dx =  xmax/mesh
  ddx12=dx*dx/12.0_dp
  !
  ! set up the potential (must be even w.r.t. x=0)
  !
  do i = 0, mesh
     x(i) = float(i) * dx
     vpot(i) = 0.5_dp * x(i)*x(i)
  end do
  !
  write(*,"('output file name > ')", advance='no')
  read (*,'(a)') fileout
  ! output to fort.7 file by default if fileout not provided
  if ( fileout /= ' ' ) &
      open (7,file=fileout,status='unknown',form='formatted')

  ! this is the entry point for a new eigenvalue search
  search_loop: do
     !
     ! read number of nodes (stop if < 0)
     !
     write(*,"('nodes (type -1 to stop) > ')", advance='no')
     read (*,*) nodes
     if (nodes < 0) then
        close(7)
        deallocate ( f, vpot, p, y, x )
        stop
     end if
     !
     ! set initial lower and upper bounds to the eigenvalue
     !
     eup=maxval (vpot(:))
     elw=minval (vpot(:))
     !
     ! Set trial energy
     !
     write(*,"('Trial energy (0=search with bisection) > ')", advance='no')
     read (*,*) e
     if ( e == 0.0_dp ) then
        ! search eigenvalues with bisection (max 1000 iterations)
        e = 0.5_dp * (elw + eup)
        n_iter = 1000
     else
        ! test a single energy value (no bisection)
        n_iter = 1
     endif

     iterate: do kkk = 1, n_iter
        !
        ! set up the f-function used by the Numerov algorithm
        ! and determine the position of its last crossing, i.e. change of sign
        ! f < 0 means classically allowed   region
        ! f > 0 means classically forbidden region
        !
        f(0)=ddx12*(2.0_dp*(vpot(0)-e))
        icl=-1
        do i=1,mesh
           f(i)=ddx12*2.0_dp*(vpot(i)-e)
           ! beware: if f(i) is exactly zero the change of sign is not observed
           ! the following line is a trick to prevent missing a change of sign
           ! in this unlikely but not impossible case:
           if ( f(i) == 0.0_dp) f(i)=1.d-20
           ! store the index 'icl' where the last change of sign has been found
           if ( f(i) /= sign(f(i),f(i-1)) ) icl=i
        end do

        if (icl >= mesh-2) then
           deallocate ( f, vpot, p, y, x )
           print *, 'Error: last change of sign too far'
           stop 1
        else if (icl < 1) then
           deallocate ( f, vpot, p, y, x )
           print *, 'Error: no classical turning point'
           stop 1
        end if
        !
        ! f(x) as required by the Numerov algorithm (note f90 array syntax)
        !
        f = 1.0_dp - f
        y = 0.0_dp
        !
        ! determination of the wave-function in the first two points
        !
        hnodes = nodes/2
        !
        ! beware the integer division: 1/2 = 0 !
        ! if nodes is even, there are 2*hnodes nodes
        ! if nodes is odd,  there are 2*hnodes+1 nodes (one is in x=0)
        ! hnodes is thus the number of nodes in the x>0 semi-axis (x=0 excepted)
        !
        if (2*hnodes == nodes) then
           ! even number of nodes: wavefunction is even
           y(0) = 1.0_dp
           ! assume f(-1) = f(1)
           y(1) = 0.5_dp*(12.0_dp-10.0_dp*f(0))*y(0)/f(1)
        else
           ! odd number of nodes: wavefunction is odd
           y(0) = 0.0_dp
           y(1) = dx
        end if
        !
        ! outward integration and count number of crossings
        !
        ncross=0
        do i =1,icl-1
           y(i+1)=((12.0_dp-10.0_dp*f(i))*y(i)-f(i-1)*y(i-1))/f(i+1)
           if ( y(i) /= sign(y(i),y(i+1)) ) ncross=ncross+1
        end do
        fac = y(icl)
        !
        if (2*hnodes == nodes) then
           ! even number of nodes: no node in x=0
           ncross = 2*ncross
        else
           ! odd number of nodes: node in x=0
           ncross = 2*ncross+1
        end if
        !
        ! check number of crossings
        !
        if ( n_iter > 1 ) then
           if (ncross /= nodes) then
              ! Incorrect number of crossings: adjust energy
              if ( kkk == 1) &
                   print '("Bisection         Energy       Nodes  Discontinuity")'
              print '(i5,f25.15,i5)', kkk, e, ncross
              if (ncross > nodes) then
                 ! Too many crossings: current energy is too high,
                 ! lower the upper bound
                 eup = e
              else
                 ! Too few crossings: current energy is too low,
                 ! raise the lower bound
                 elw = e
              end if
              ! New trial value:
              e = 0.5_dp * (eup+elw)
              ! go to beginning of do loop, don't perform inward integration
              cycle
           end if
        else
           print *, e, ncross, nodes
        end if
        !
        ! Correct number of crossings: proceed to inward integration
        !
        ! Determination of the wave-function in the last two points
        ! assuming y(mesh+1) = 0
        !
        y(mesh) = dx
        y(mesh-1) = (12.0_dp-10.0_dp*f(mesh))*y(mesh)/f(mesh-1)
        norm = 1.0d100
        do i = mesh-1,icl+1,-1
           y(i-1)=((12.0_dp-10.0_dp*f(i))*y(i)-f(i+1)*y(i+1))/f(i-1)
           ! the following lines prevent overflows if starting from too far
           if ( abs(y(i-1)) > norm ) then
              y(i-1:mesh) = y(i-1:mesh) / norm
           endif
        end do
        !
        ! rescale function to match at the classical turning point (icl)
        !
        fac = fac/y(icl)
        y(icl:) = y(icl:)*fac
        !
        ! normalize on the [-xmax,xmax] segment
        ! the x=0 point must be counted once
        !
        norm = (2.0_dp*dot_product (y, y) - y(0)*y(0)) * dx
        y = y / sqrt(norm)
        !
        if ( n_iter > 1 ) then
           !  calculate the discontinuity in the first derivative
           !  y'(i;RIGHT) - y'(i;LEFT)
           djump = ( y(icl+1) + y(icl-1) - (14.0_dp-12.0_dp*f(icl))*y(icl) ) / dx
           print '(i5,f25.15,i5,f14.8)', kkk, e, nodes, djump
           if (djump*y(icl) > 0.0_dp) then
              ! Energy is too high --> choose lower energy range
              eup = e
           else
              ! Energy is too low  --> choose upper energy range
              elw = e
           endif
           e = 0.5_dp * (eup+elw)
           ! ---- convergence test
           if ( eup-elw < 1.d-10) exit iterate
        endif
        !
     end do iterate
     !
     ! ---- convergence has been achieved (or it wasn't required) -----
     !
     ! Calculation of the classical probability density for energy e:
     !
     norm = 0.0_dp
     p(icl:) = 0.0_dp
     do i=0,icl
        arg = (e - x(i)**2/2.0_dp)
        if ( arg > 0.0_dp) then
           p(i) = 1.0_dp/sqrt(arg)
        else
           p(i) = 0.0_dp
        end if
        norm = norm + 2.0_dp*dx*p(i)
     enddo
     ! The point at x=0 must be counted once:
     norm = norm - dx*p(0)
     ! Normalize p(x) so that  Int p(x)dx = 1
     p(:icl-1) = p(:icl-1)/norm
     ! lines starting with # ignored by gnuplot
     write (7,'("#   x         y(x)            y(x)^2      classical p(x)    V")')
     ! x<0 region:
     do i=mesh,1,-1
        ! if exponent is > 99, the format X.Y-100 is misinterpreted by gnuplot
        if ( abs(y(i)) < 1.0D-50 ) y(i) = 0.0_dp
        write (7,'(f8.3,3e16.8,f12.6)') &
             -x(i), (-1)**nodes*y(i), y(i)*y(i), p(i), vpot(i)
     enddo
     ! x>0 region:
     do i=0,mesh
        write (7,'(f8.3,3e16.8,f12.6)') &
             x(i), y(i), y(i)*y(i), p(i), vpot(i)
     enddo
     ! two blank lines separating blocks of data, useful for gnuplot plotting
     write (7,'(/)')

  end do search_loop

end program harmonic1


program average

![-3-]@copyright wikipedia, modified @alpaca-tc. http://en.wikipedia.org/wiki/Fortran
![-4-] Read in some numbers and take the average
![-5-] As written, if there are no data points, an average of zero is returned
![-6-] While this may not be desired behavior, it keeps this example simple

implicit none

real, dimension(:), allocatable :: points
integer                         :: number_of_points
real                            :: average_points=0., positive_average=0., negative_average=0.

write (*,*) "Input number of points to average:"
read  (*,*) number_of_points

allocate (points(number_of_points))

write (*,*) "Enter the points to average:"
read  (*,*) points

![-22-] Take the average by summing points and dividing by number_of_points
if (number_of_points > 0) average_points = sum(points) / number_of_points

![-25-] Now form average over positive and negative points only
if (count(points > 0.) > 0) then
  positive_average = sum(points, points > 0.) / count(points > 0.)
end if

if (count(points < 0.) > 0) then
  negative_average = sum(points, points < 0.) / count(points < 0.)
end if

deallocate (points) ![-34-] Print result to terminal

![-36-] Print result to terminal
write (*,'(a,g12.4)') 'Average = ', average_points
write (*,'(a,g12.4)') 'Average of positive points = ', positive_average
write (*,'(a,g12.4)') 'Average of negative points = ', negative_average

end program average


module constants
implicit none

   real, parameter,private :: pi = 3.1415926536
   real, parameter, private :: e = 2.7182818285

contains
   subroutine show_consts()
      print*, "Pi = ", pi
      print*, "e = ", e
   end subroutine show_consts

   function ePowerx(x)result(ePx)
   implicit none
      real::x
      real::ePx
      ePx = e ** x
   end function ePowerx

   function areaCircle(r)result(a)
   implicit none
      real::r
      real::a
      a = pi * r**2
   end function areaCircle

end module constants

program module_example
use constants
implicit none

   call show_consts()

   Print*, "e raised to the power of 2.0 = ", ePowerx(2.0)
   print*, "Area of a circle with radius 7.0 = ", areaCircle(7.0)

end program module_example


PROGRAM MonteCarlo2
  ! This program demonstrates the parallelization of a program that uses the
  ! Monte Carlo method by simulating a random walk in two dimensions of 100,000
  ! particles in 10 steps. The program outputs the distribution of the
  ! distances that the particles have travled.

  USE IFPORT

  IMPLICIT NONE
  INCLUDE 'mpif.h'

  ! Configuration variables
  INTEGER, PARAMETER      :: n = 100000
  REAL, PARAMETER         :: pi = 3.1415926
  INTEGER, DIMENSION(0:9) :: localDist, globalDist

  ! MPI variables
  INTEGER               :: nprocs
  INTEGER               :: myrank
  INTEGER               :: ierr

  ! Count and temporary variables
  INTEGER :: i, ista, iend, step, temp
  REAL    :: x, y, angle

  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr)

  CALL para_range(1, n, nprocs, myrank, ista, iend)

  DO i = 0, 9
    localDist(i) = 0
  ENDDO

  CALL srand(100 + myrank)
  DO i = ista, iend
    x = 0.0
    y = 0.0
    DO step = 1, 10
      angle = 2.0 * pi * rand()
      x = x + cos(angle)
      y = y + sin(angle)
    ENDDO
    temp = sqrt(x**2 + y**2)
    localDist(temp) = localDist(temp) + 1
  ENDDO
  CALL MPI_REDUCE(localDist, globalDist, 10, MPI_INTEGER, MPI_SUM, 0, &
                  MPI_COMM_WORLD, ierr)

  IF (myrank == 0) write (*,*) 'distribution =', globalDist

  CALL MPI_FINALIZE(ierr)
END PROGRAM MonteCarlo2

SUBROUTINE para_range(n1, n2, nprocs, irank, ista, iend)
  IMPLICIT NONE

  INTEGER, INTENT(IN)  :: n1
  INTEGER, INTENT(IN)  :: n2
  INTEGER, INTENT(IN)  :: nprocs
  INTEGER, INTENT(IN)  :: irank
  INTEGER, INTENT(OUT) :: ista
  INTEGER, INTENT(OUT) :: iend

  INTEGER :: iwork1
  INTEGER :: iwork2

  iwork1 = (n2 - n1 + 1) / nprocs
  iwork2 = MOD(n2 - n1 + 1, nprocs)
  ista = irank * iwork1 + n1 + MIN(irank, iwork2)
  iend = ista + iwork1 - 1
  IF (iwork2 > irank) iend = iend + 1
END


!TITLE          Projectile Motion                      ProjectileMotion.f90
!    Fortran for Science and Engineering
!COMMENT
!   Objective: Compute the position (x and y co-ordinates) and the velocity
!              (magnitude and direction) of a projectile, given t,
!              the time since launch, u, the launch velocity, a, the
!              initial angle of launch (in degrees), and g,
!              the acceleration due to gravity.
!       Input: -
!      Output: -
!      Author: Chris B. Kirov
!        Date: 31.03.20

program ProjectileMotion
    implicit none

    ! Constants !
    real, parameter :: PI = 3.1415927               ! pi
    real, parameter :: g = 9.81                     ! acceleration due to gravity

    ! Initial conditions !
    real a                                          ! launch angle in degrees
    real u                                          ! launch velocity
    real t                                          ! time of flight

    ! Wanted values !
    real theta                                      ! direction at time t in degrees
    real x                                          ! horizontal displacement
    real y                                          ! vertical displacement
    real vx                                         ! horizontal velocity
    real vy                                         ! vertical velocity
    real v                                          ! resultant velocity

    ! Read input !
    print *, "Type launch angle [degrees]:"
    read *, a

    print *, "Type launch velocity [m/s]:"
    read *, u

    print *, "Type time of flight [s]:"
    read *, t

    ! Calculate wanted values !
    a = a * PI / 180.                               ! convert to radians

    x = u * cos(a) * t
    y = u * sin(a) * t  - g * t * t / 2.0

    vx = u * cos(a)
    vy = u * sin(a) - g * t

    v = sqrt(vx * vx + vy * vy)
    theta = tan(vy / vx) * 180 / PI                 ! directly converted in degrees

    ! Print results !
    print *, "Horizontal displacement, x: ", x, "Vertical displacement, y: ", y
    print *, "Horizontal velocity, Vx: ", vx, "Vertical velocity, Vy: ", vy
    print *, "Resultant velocity magnitude, V: ", v, "Resultant Velocity Direction, Theta: ", theta
end program ProjectileMotion

Visual Studio 2010/Projects/Chapter22 Exercise 6/7. Fortran/0ProgramInFortran.f90


module nrtools
  use nrtype
contains
  recursive function rcsv_bicoef(n, k) result(bicoef)
    !===========================================================================!
    ! Recursive function for the calculation of binomial coefficients. !
    ! April 19th 2016. !
    ! Daniel Celis Garza !
    !---------------------------------------------------------------------------!
    ! This function recursively calculates the binomial coefficient for a given !
    ! n and k. !
    ! n choose k = n!/( k! * (n - k)! ) = n choose (n - k) !
    !
    ! n!/( k! * (n - k)! ) = n(n-1)(n-2)...(n-k+1)/k                            !
    ! = (n/k) * (n-1)!/( (k-1)! * (n-k)! )                              !
    !---------------------------------------------------------------------------!
    ! Inputs:
    ! n = integer n
    ! k = integer k
    !---------------------------------------------------------------------------!
    ! Outputs:
    ! bicoef = integer type i16 !
    !===========================================================================!
    implicit none
    integer, intent(in) :: n, k
    real(dp)            :: bicoef

    ! Identify Key Scenarios.
    iks: if (k > n) then
      write(*,*) " Error: nrtools: rcsv_bicoef: iks: n must be greater than k. k = ", k, ", n = ", n
      return
    else if (k == 0._dp) then iks
      bicoef = 1._dp
    else if (k > n/2) then iks
      ! Recurse function so as to reduce the number of operations to at most n/2 at the numerator and denominator.
      bicoef = rcsv_bicoef(n, n-k)
    else iks
      ! Calculate binomial coefficient.
      bicoef = float(n)/float(k) * rcsv_bicoef(n-1, k-1)
    end if iks

  end function rcsv_bicoef

  function ln_gamma(x)
    ! Approximates the natural logarithm of the gamma function for x \in \reals and x > 0
    implicit none
    real(dp), intent(in) :: x
    real(dp) :: ln_gamma
    real(dp) :: tmp
    real(dp), parameter, dimension(7) :: coef = [1.000000000190015_dp,76.18009172947146_dp,-86.50532032941677_dp,&
    0._dp,0._dp,0._dp,0._dp]
    real(dp), parameter :: sqrtau = sqrt(tau)

    ! Check that x > 0.
    xg0: if (x <= 0._dp) then
      write(*,*) " Error: nrtools: ln_gamma: xg0: x must be greater than 0. x = ", x
      return
    end if xg0

    tmp = x + 5.5_dp
    tmp = (x + 0.5_dp) * log(tmp) - tmp
    ln_gamma = tmp + log(sqrtau * (coef(1) + sum( coef(2:7) / arthm_prog( x + 1._dp, 1._dp, size(coef(2:7)) ) ) ) / x )

  end function ln_gamma

  function arthm_prog(first, step, n)
    ! Calculates the arithmetic progression with step = step.
    implicit none
    real(dp), intent(in) :: first, step
    integer, intent(in)  :: n
    real(dp) :: arthm_prog(n)
    integer  :: i ! Counter

    arthm_prog(1) = first

    do i = 2, n
        arthm_prog(i) = arthm_prog(i-1) + step
    end do

  end function arthm_prog

  recursive function rcsv_gamma(z) result(gamma)

    ! Approximates the gamma function via Lanczos' approximation, with gamma = 8, N = 9
    ! https://en.wikipedia.org/wiki/Lanczos_approximation
    implicit none
    complex(dpc), intent(in) :: z
    complex(dpc) :: gamma
    complex(dpc) :: tmp, t
    real(dp) :: x
    integer  :: i
    real(dp), parameter, dimension(9) :: coef = [0.99999999999980993_dp, 676.5203681218851_dp, -1259.1392167224028_dp, &
    771.32342877765313_dp, -176.61502916214059_dp, 12.507343278686905_dp,&
    -0.13857109526572012_dp, 9.9843695780195716d-6, 1.5056327351493116d-7]
    real(dp), parameter :: sqrtau = sqrt(tau)

    tmp = z

    ! Calculate Gamma Function
    cgf: if( real(tmp) <= 0.5_dp ) then

      gamma = pi / ( sin(pi*tmp) * rcsv_gamma(1._dp-tmp) )

    else cgf

      tmp = tmp - 1._dp
      x   = coef(1)

      ! Calculate the Arithmetic Progression and Divide.
      apd: do i = 2, size(coef)
        x = x + coef(i) / (tmp + i - 1)
      end do apd

      t = tmp + size(coef) - 1.5_dp

      gamma = sqrtau * t ** (tmp + 0.5_dp) * exp(-t) * x

    end if cgf
  end function rcsv_gamma

  recursive function rcsv_ln_gamma(z) result(ln_gamma)
    ! Calculates the value of the natural logarithm of the gamma function for gamma = 8 and N = 9
    implicit none
    complex(dpc), intent(in) :: z
    complex(dpc) :: ln_gamma
    complex(dpc) :: tmp, t
    real(dp) :: x
    integer  :: i
    real(dp), parameter, dimension(9) :: coef = [0.99999999999980993_dp, 676.5203681218851_dp, -1259.1392167224028_dp, &
    771.32342877765313_dp, -176.61502916214059_dp, 12.507343278686905_dp,&
    -0.13857109526572012_dp, 9.9843695780195716d-6, 1.5056327351493116d-7]
    real(dp), parameter :: lnsqrtau = log(sqrt(tau)), lnpi = log(pi)

    tmp = z

    ! Calculate Ln(Gamma), it takes the main branch cut.
    clg: if (real(tmp) <= 0.5_dp) then

      ln_gamma = lnpi - log(sin(pi*tmp)) - rcsv_ln_gamma(1._dp-tmp)

    else clg

       tmp = tmp - 1._dp
       x   = coef(1)

       ! Calculate tge Arithmetic Progression and Divide.
       apd: do i = 2, size(coef)
         x = x + coef(i) / (tmp + i - 1)
       end do apd

       t = tmp + size(coef) - 1.5_dp

       ln_gamma = lnsqrtau + log(t)*(tmp + 0.5_dp) -t + log(x)

    end if clg

  end function rcsv_ln_gamma
end module nrtools


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! MODULE CONSTANTS_MODULE
!
! This module defines constants that are used by other modules
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module constants_module

   real, parameter :: PI = 3.141592653589793
   real, parameter :: OMEGA_E = 7.292e-5 ! Angular rotation rate of the earth

   real, parameter :: DEG_PER_RAD = 180./PI
   real, parameter :: RAD_PER_DEG = PI/180.

   ! Mean Earth Radius in m.  The value below is consistent
   ! with NCEP's routines and grids.
   real, parameter :: A_WGS84  = 6378137.
   real, parameter :: B_WGS84  = 6356752.314
   real, parameter :: RE_WGS84 = A_WGS84
   real, parameter :: E_WGS84  = 0.081819192

   real, parameter :: A_NAD83  = 6378137.
   real, parameter :: RE_NAD83 = A_NAD83
   real, parameter :: E_NAD83  = 0.0818187034

   real, parameter :: EARTH_RADIUS_M = 6370000.   ! same as MM5 system
   real, parameter :: EARTH_CIRC_M = 2.*PI*EARTH_RADIUS_M

   real, parameter :: G = 9.81                    ! m/s

end module constants_module


! ToDo: mergeSort is not right
module sorting
    use iso_fortran_env, only: i4 => int32, i8 => int64
    implicit none
contains
    subroutine bubbleSort(array)
        implicit none
        integer, dimension(:):: array
        integer :: i, j, tem
        i = size(array)
        do while (i > 1)
            do j = 1, i - 1
                if (array(j) > array(j + 1)) then
                    tem = array(j)
                    array(j) = array(j + 1)
                    array(j + 1) = tem
                end if
            end do
            i = i - 1
        end do
    end subroutine bubbleSort

    subroutine selectSort(array)
        implicit none
        integer, dimension(:) :: array
        integer :: i, j, tem

        do i = 1, size(array) - 1
            do j = i + 1, size(array)
                if (array(i) > array(j)) then
                    tem = array(i)
                    array(i) = array(j)
                    array(j) = tem
                end if
            end do
        end do
    end subroutine selectSort

    pure recursive function mergeSort(array) result(res)
        implicit none
        integer, dimension(:), intent(in) :: array
        integer, dimension(size(array)) :: res
        integer, dimension(size(array)/2) :: left
        integer, dimension(size(array) - size(array)/2) :: right
        integer :: mid, l, r, i

        if (size(array) > 1) then
            mid = size(array) / 2
            left = array(:mid)
            right = array(mid+1:)
            mergeSort(left)
            mergeSort(right)
        end if

        l = 1
        r = 1
        i = 1
        do while(l <= size(left) .and. r <= size(right))
            if (left(l) < right(r)) then
                res(i) = left(l)
                l = l + 1
            else
                res(i) = right(r)
                r = r + 1
            end if
            i = i + 1
        end do

        do while(l <= size(left))
            res(i) = left(l)
            l = l + 1
            i = i + 1
        end do
        do while(r <= size(right))
            res(i) = right(r)
            r = r + 1
            i = i + 1
        end do
    end function mergeSort

    pure recursive function quickSort(x) result(res)
        integer, dimension(:), intent(in) :: x !! Input array
        integer, dimension(size(x)) :: res
        integer, dimension(size(x)- 1) :: tem
        integer :: pivot

        if(size(x) > 1)then
            pivot = x(size(x) / 2 + 1)
            tem = [x(1 : size(x)/2), x(size(x) / 2 + 2:)]
            res = [quickSort(pack(tem, tem < pivot)), pivot, &
                   quickSort(pack(tem, tem >= pivot))]
          else
            res = x
          endif
    end function quickSort
end module sorting

program test
    use sorting, only : bubbleSort, selectSort, mergeSort, quickSort
    implicit none
    integer, dimension(5) :: array = [2, 9, 3, 0, -1]
    integer, dimension(8) :: array_8, res
    call bubbleSort(array)
    print *, array

    array = [2, 9, 3, 0, -1]
    call selectSort(array)
    print *, array

    array_8 = [2, 11, 4, 1, 9, 3, 0, -1]
    res = mergeSort(array_8)
    print *, res

    array_8 = [2, 11, 4, 1, 9, 3, 0, -1]
    print *, "OA: ", array_8
    res = quickSort(array_8)
    print *, res
end program test