!-----------------------------------------------------------------------
!
! Copyright (c) 2016 Tom L. Underwood
!
! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, sublicense, and/or sell copies of the Software, and to
! permit persons to whom the Software is furnished to do so, subject to
! the following conditions:
!
! The above copyright notice and this permission notice shall be
! included in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
! NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
! BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
! ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!-----------------------------------------------------------------------
!
! By extracting lines beginning with the regular expression '\!\! ?'
! (ignoring leading whitespace), and then removing matches to the
! regular expression, html documentation corresponding to this
! source code will be created.
!
!!
!!
!!  <title> rng_mod Documentation </title>
!!
!!
!!
!!
 rng_mod Documentation

!!
!!
 Author

!!
 Tom Underwood

!!
!!
 Description

!!

!! rng_mod is a module which contains procedures for
!! generating random numbers by the Mersenne twister  MT19937 algorithm
!! by acting as a wrapper for 'mt95.f90'), as well as a number of
!! other useful random-number-related procedures.
!!

!!
module rng_mod

  !!
 Dependencies

  !!

  !!

  !!
  kinds_mod

  !!
  mt95

  !!

  !!

  use kinds_mod
  use mt95

  implicit none

contains

  !!
 Procedures

  !!
  subroutine init_random_seed()

  !!

  !!  init_random_seed  initialises the random number generator
  !! using the (optional) integer seed specified in the argument. If there is
  !! no argument then a random seed is used - which is taken from the system
  !! clock.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     seed
  !!     integer, intent(in), optional
  !!    A specific seed for the random number generator.
  !!

  !!

  subroutine init_random_seed(seed)
    integer, intent(in), optional :: seed
    integer :: clock
    if(present(seed)) then
        call genrand_init(seed)
    else
       call system_clock(count=clock)
       call genrand_init(clock)
    end if
  end subroutine init_random_seed

  !!
  function get_random_number()

  !!

  !!  get_random_number  generates a random number between
  !! 0 and 1. We emphasise that this number may be 0, but not 1.
  !!

  !!
Returns:  real(rk)

  function get_random_number()
    real(rk) :: get_random_number

    call genrand_real2(get_random_number)

  end function get_random_number

  !!
  function top_hat_rand(L)

  !!

  !!  top_hat_rand  generates a random number between
  !! -L and L, where L>0.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     L
  !!     real(rk), intent(in)
  !!
  !!   The highest magnitude of random number generated by the
  !!   function.
  !!
  !!

  !!

  !!
Returns:  real(rk)

  function top_hat_rand(L)
    real(rk), intent(in) :: L
    real(rk) :: top_hat_rand
    top_hat_rand=(2.0_rk*get_random_number()-1.0_rk)*L
  end function top_hat_rand

  !!
  function bag_array(nspec)

  !!

  !! This function returns a random array with the specified number of occurences of the numbers 1, 2, ...
  !! Its name reflects the fact that the array reflects drawing at random balls of various types from
  !! a 'bag' containing the specified number of each type of ball.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     nspec
  !!     integer(ik), dimension(:), allocatable, intent(in)
  !!
  !!   Array containing the number of occurences of each number to occur in the returned array:
  !!   nspec(1) is the number of times 1 should occur; nspec(2) is the number
  !!   of times 2 should occur; etc. E.g. nspec=
  !!   This array should have 1 as its first index.
  !!
  !!

  !!

  !!
Returns:  integer(ik), dimension(:), allocatable

  function bag_array(nspec)
    integer(ik), dimension(:), intent(in) :: nspec
    integer(ik), dimension(:), allocatable :: bag_array
    ! The total number of elements in the array to return
    integer(ik) :: nelem
    ! The total number of species to consider
    integer(ik) :: totspec
    ! The total number of elements left to assign.
    integer(ik) :: nleft
    ! An array containing the number of elements left to assign for each species
    integer(ik), dimension(size(nspec)) :: nleftspec
    ! Unimportant variables
    integer(ik) :: i,n
    real(rk) :: cutoff, rand

    nleftspec=nspec
    totspec=size(nspec)
    nelem=sum(nspec)
    allocate(bag_array(nelem))
    bag_array=0 ! For error trapping

    ! Assign the species
    nleft=nelem
    do n=1,nelem
       ! Get a random number
       rand=get_random_number()

       ! Decide which species it corresponds to. If rand<nleftspec(1)/nleft, then we choose
       ! species 1; if nleftspec(1)/nleft<=rand<(nleftspec(1)+nleftspec(2))/nleft then we choose
       ! species 2; etc.
       cutoff=0
       do i=1,totspec
          cutoff=cutoff+(1.0_rk*nleftspec(i))/nleft
          if(rand<cutoff) then
             bag_array(n)=i
             ! Update nleft and nleftspec
             nleft=nleft-1
             nleftspec(i)=nleftspec(i)-1
             exit
          end if
       end do

    end do
  end function bag_array

end module rng_mod
!!
!!
!!


!!-------------example.f90----------------------------------------------------!!
!
! Purpose: To show how to write thngs in fortran (90)
!
!!----------------------------------------------------------------------------!!

program hello_world
$$ Every fortran code begins and ends with a program statement.
$$ Be sure you name the program something that you will remember in the future!
    write(*,*) "hello world!"
$$ This command may be a little confusing. Let's break it down...
$$ "write" is a function that takes two arguments: \n the first is the file or screen you are printing out to. \n
$$The second is the format in which you would like to print. In this case, both are the '*' character, which means we are using defaults for both. The default file is the terminal screen and the default formatting is determined by fortran, itself.

end program

$$ This syntax will be used for looping later, please remember to end your program!


MODULE shape_class
!
!   This module implements an abstract shape class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/31/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Type definition
TYPE,PUBLIC :: shape

   ! Instance variables.
   ! <none >

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: area => calc_area_fn
   PROCEDURE,PUBLIC :: perimeter => calc_perimeter_fn
   PROCEDURE,PUBLIC :: to_string => to_string_fn

END TYPE shape

! Restrict access to the actual procedure names
PRIVATE :: calc_area_fn, calc_perimeter_fn, to_string_fn

CONTAINS

   REAL FUNCTION calc_area_fn(this)
   !
   ! Return the area of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(shape) :: this               ! Shape object

   ! Return dummy area
   calc_area_fn = 0.

   END FUNCTION calc_area_fn

   REAL FUNCTION calc_perimeter_fn(this)
   !
   ! Return the perimeter of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(shape) :: this               ! Shape object

   ! Return dummy perimeter
   calc_perimeter_fn = 0.

   END FUNCTION calc_perimeter_fn

   CHARACTER(len=50) FUNCTION to_string_fn(this)
   !
   ! Return the a character description of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(shape) :: this               ! Shape object

   ! Return dummy string
   to_string_fn = ''

   END FUNCTION to_string_fn

END MODULE shape_class


program readMatrix
    integer i, j;
    integer, parameter :: rows = 3;
    integer, parameter :: cols = 3;
    integer, dimension(rows, cols) :: a;

    do i = 1, rows
        do j = 1, cols
            print *, "Enter element a(", i, ", ", j, ") : ";
            read *, a(i, j);
        end do
    end do

    print *, "Marix Elements are as as : ";
    do i = 1, rows
        do j = 1, cols
            print *, a(i, j);
        end do
        print *, "";
    end do
end program readMatrix


program ex1

    integer(kind=4)   :: a
    integer(4)        :: b ! Short form

    real(kind=8)      :: c
    real(8)           :: d ! Short form

    character(len=20) :: textstring
    character         :: t
    character(20)     :: textstring2
    character(len=20, kind=1) :: textstring3     ! english string

    a = 4
    b = 5
    c = 1.0_8
    d = 2.0_8
    e = 0.0_8

    t = 'a'
    textstring = 'Hello'
    textstring2 = 'World!'
    textstring3 = 'English'

end program ex1


program do_test
    implicit none
    integer :: i

    do i = 0, 10, 2
        print *, i
    end do
    print '(A, I0)', 'value of do-loop index after block: ', i

end program do_test


      program asignable
        implicit none

        integer, allocatable :: vector(:)
        integer, allocatable :: matriz(:,:)

        allocate(vector(10))
        allocate(matriz(10,10))

        !Se asignan por defecto todos los
        !elementos con ceros

        print *,'Vector: ', vector
        print *,'Matriz: ', matriz
      end program asignable


! 3. Write a function that checks whether an element occurs in a list.

    program Exercises
        integer :: list(4)
        logical :: r

        list = (/1, 6, 32, 5/)
        r = listContains(list, 8)

        if (r) then
            print *, 'The list contains the number.'
        else
            print *, 'The list doesn''t contain the number.' ! Escape apostrophe literal with two apostrophes.
        end if

        contains

        function listContains(list, x) result(r)
            integer, dimension(1:), intent(in) :: list
            integer, intent(in) :: x
            logical :: r
            integer :: i

            do i=1,size(list)
                if (list(i) == x) then
                    r = .true.
                    return
                end if
            end do

            r = .false.

        end function listContains

    end program Exercises


module precision_mod

    implicit none
    private

    public :: wp

    integer, parameter :: sp = kind(1.0e0)  ! single precision
    integer, parameter :: dp = kind(1.0d0)  ! double precision

    integer, parameter :: wp = dp   ! working precison

end module


program overwrite_stdout
!! overwrites terminal stdout in place e.g. for update status
!! char(13) is carriage return
use, intrinsic:: iso_fortran_env, only: stdout=>output_unit
use sleep_std, only : sleep

implicit none (type, external)

integer :: i
integer, parameter :: N=5

do i = 1,N
  write(stdout,'(A1,F7.3,A1)',advance='no') achar(13),i/real(N)*100,'%'
  flush(stdout) !< Fortran 2003, necessary for ifort

  call sleep(500)
end do

end program


module mod_a
    implicit none

contains

    subroutine print_a(n)
        implicit none
        integer, intent(in) :: n
        print '(A, I0)', 'A: ', n
    end subroutine print_a

end module mod_a


!Calculadora utilizando subrutinas y funciones
!La calculadora debe soportar las siguientes op:
! +, -, *, /

!Estas operaciones deben estar implementadas con dos funciones
!y dos subrutinas


! Copyright (C) 2015-2017, Simone Marsili
! All rights reserved.
! License: BSD 3 clause

module kinds
  implicit none

  ! specific
  integer, parameter :: kint_single = 4
  integer, parameter :: kint_double = 8
  integer, parameter :: kflt_single = 4
  integer, parameter :: kflt_double = 8
  ! generic
  integer, parameter :: kint = 4
  integer, parameter :: kflt = 8

end module kinds


program main
    use std ! standard package of SiCroF library
    implicit none

    type(IO_) :: f ! file-IO instance
    integer(int32) :: i, num ! int i and int num

    ! for i=1; i<11;i++
    do i=1,10
        !    f.open(filepath, filename, extention)
        !    str(int) => string
        call f%open("./","hello"//trim(str(i)),".txt")

        ! This
        call f%write(str(i))
        ! and this
        write(f%fh,*) str(i)
        ! are same

        call f%close()

        call f%open("./","hello"//trim(str(i)),".txt")
        ! read a line
        read(f%fh,*) num
        ! print(num)
        print *, num

        call f%close()
    enddo

end program


! Same a s Problem 1 with a LIFO stack.  Here new elements are added in the
! sorted ascending order.
program singly_linked_list_sorted
    implicit none

    type :: a_sll_node
        integer :: val
        type(a_sll_node), pointer :: next => null()
    end type a_sll_node

    type(a_sll_node), pointer :: head, temp, current, previous

    integer :: iostatus, val

    ! Insertion
    print "(a)", "Enter the list values one by line:"
    head => null()
    do
        read(*, *, iostat=iostatus) val
        if (iostatus /= 0) exit

        ! Insert a new node in sorted order.  There are three cases:
        ! 1) empty list (head is null);
        ! 2) non-empty list with insertion before the 1st element (you must
        !    re-point head);
        ! 3) non-empty list with insertion after the 1st element.
        ! You need three extra pointers: `temp` for the target, `current` for
        ! the node to insert before, `previous` for the node to insert after.
        allocate(temp)
        temp%val = val
        previous => null()
        current  => head
        if (.not.associated(head)) then
            head => temp
        else
            do while (associated(current))
                if (current%val < val) then
                    ! Advance by one node.
                    previous => current
                    current  => current%next
                else
                    ! Node found
                    exit
                end if
            end do
            temp%next => current
            if (associated(previous)) then
                ! Insert after the 1st element.
                previous%next => temp
            else
                ! Insert before the 1st element.
                head => temp
            end if
        end if
    end do

    ! Walk through the list and print the stored values.
    temp => head
    do while (associated(temp))
        write(*, "(a, i0, a)", advance="no") "(", temp%val, ")->"
        temp => temp%next
    end do
    print "(a)", "null()"

    ! Deletion
    ! TODO: I don't like this solution, it's too difficult.
    print "(a)", "Values to delete, one by line"
    do
        read(*, *, iostat=iostatus) val
        if (iostatus /= 0) exit

        ! Delete a node with the given value.
        previous => null()
        current  => head
        if (.not.associated(head)) then
            continue ! nothing to delete from an empty list
        else
            if (current%val <= val) then
                do while (associated(current))
                    if (current%val < val) then
                        previous => current     ! advance by one node
                        current  => current%next
                    else
                        exit ! node found
                    end if
                end do
                if (associated(current)) then ! current is not the null() tail.
                    if (associated(previous)) then
                        previous%next => current%next ! delete after the 1st element.
                    else
                        head => current%next ! delete the 1st element.
                    end if
                    deallocate(current)
                end if
            end if
        end if
    end do

    ! Walk through the list and print the stored values.
    temp => head
    do while (associated(temp))
        write(*, "(a, i0, a)", advance="no") "(", temp%val, ")->"
        temp => temp%next
    end do
    print "(a)", "null()"

    ! Destroy the list (delete all elements) by popping its first node from the
    ! head.
    do while (associated(head))
        temp => head
        head => head%next
        deallocate(temp)
    end do
end program singly_linked_list_sorted


program test_get_var_grid

  use bmif_2_0, only: BMI_FAILURE
  use bmiheatf
  use fixtures, only: config_file, status

  implicit none

  character (len=*), parameter :: var_name = "plate_surface__temperature"
  integer, parameter :: expected_id = 0

  type (bmi_heat) :: m
  integer :: grid_id

  status = m%initialize(config_file)
  status = m%get_var_grid(var_name, grid_id)
  status = m%finalize()

  if (grid_id.ne.expected_id) then
     stop BMI_FAILURE
  end if
end program test_get_var_grid


! chk_locate_string --
!     Check if the compiler allows the FINDLOC function to be applied to character strings
!
!     Note:
!     Not entirely sure this is indeed allowed by the standard
!
program chk_locate_string
    implicit none

    character(len=5), dimension(5) :: array = (/ 'MIN  ', 'MAX  ', 'MEAN ', 'STDEV', 'COUNT' /)

    write( *, '(6a)' )   'Array of strings: ', array
    write( *, '(a,i5)' ) 'The position of "MAX" is ', findloc(array, 'MAX')
end program chk_locate_string


      program matini
      integer size
      parameter (size=100)
      real t(size,size)

      do 100 i = 1, size
         do 200 j = 1, size
            t(i,j) = 0.
 200     continue
 100  continue

      end


      program while02

      real x(100)

      i = 100
      do while(i.gt.1)
         x(i) = 0.
         i = i - 1
      enddo

      end


PROGRAM ex1
 INTEGER , PARAMETER :: n = 10
 REAL ( KIND= 8 ) :: a ( 1 : 10 )
 REAL ( KIND= 8 ) :: b ( 1 : 10 )
 INTEGER :: i
 INTEGER :: j

 DO j = 1 , 10 , 1
  DO i = 1 , 10 , 1
   PRINT * ,"loop iteration: " , i , j
  END DO
 END DO
END PROGRAM ex1


subroutine copy_array(input, output)

  implicit none

  real*8, dimension(:), intent(in) :: input
  real*8, dimension(size(input)), intent(out) :: output
  !, allocatable
  integer :: n

  !allocate(output(size(input)))

  do n = 1, size(input)
    output(n) = input(n)
  end do

  return

end subroutine


PROGRAM main
IMPLICIT NONE
REAL :: a, b
REAL, DIMENSION(5) :: c
INTEGER :: i
COMMON / common1 / a, b, c, i
...
CALL sub11
END PROGRAM main

SUBROUTINE sub11
REAL :: x
REAL,DIMENSION(5) :: y
INTEGER :: i, j
COMMON / common1 / x, y, i, j
...
END SUBROUTINE sub11


! MODULE can be reused
    MODULE stack
    IMPLICIT NONE
! data
    INTEGER, PARAMETER :: stack_size = 100
    INTEGER, SAVE :: store(stack_size), pos=0

! can specify the visibility separately
! note no forward declaraion of member subprograms is needed
    PRIVATE :: pos, store, stack_size
    PUBLIC :: pop, push
!Alternatively, use statements or attributes;
!    PUBLIC                 ! set default visibility
!    INTEGER, PRIVATE, SAVE :: store(stack_size), pos
!    INTEGER, PRIVATE, PARAMETER :: stack_size = 100

! manipulations
! push
   CONTAINS
    SUBROUTINE push(i)
     INTEGER, INTENT(IN) :: i
      IF (pos < stack_size) THEN
       pos = pos + 1; store(pos) = i
      ELSE
!       STOP 'Stack Full error'
       STOP
      END IF
    END SUBROUTINE push
! pop
    SUBROUTINE pop(i)
     INTEGER, INTENT(OUT) :: i
      IF (pos > 0) THEN
       i = store(pos); pos = pos - 1
      ELSE
       STOP 'Stack Empty error'
      END IF
     END SUBROUTINE pop
   END MODULE stack

! use of module
! the types, data structure, and subprograms are exposed
     PROGRAM StackUser
      USE stack
      IMPLICIT NONE
      INTEGER :: i, j

      CALL Push(1);
      CALL Push(2);
      CALL Pop(i);
      CALL Pop(j)
      PRINT *, i,j

     END PROGRAM StackUser


      PROGRAM W01
      INTEGER I, N

c      I = 100
      I = 1
      N = 10
      J = 3

      DO WHILE (I.LT.N)
         PRINT *, I
         I = I+1
         J = 2
      ENDDO

      PRINT *, I, J

      END


!Taking input from user
program Take_Input
    implicit none
    INTEGER :: number

    !We use read () to take value from user
    !Syntax:
    !read(*,*),<variable name>

    WRITE (*, *) "Enter any number?"
    READ (*, *) number
    print *, "The inputted number is ", number

end program Take_Input


program bucles
integer i, j

!Los bucles son una herramienta especialmente útil cuando es necesario repetir alguna sentencia o grupo de sentencias
!de manera ciclica. Fortran nos permite el uso de bucles do (similar al ciclo for de otros lenguajes) y el bucle
!do-while

!Supongase que se tiene el siguiente arreglo:
integer pi(5)
data pi /3,1,4,1,6/

!Si quisieramos imprimirlo, veremos que tendriamos que nombrar cada uno de sus elementos uno por uno e imprimirlos:
!print *, pi(1)
!print *, pi(2)
!	....

!Si quisieramos agilizar este proceso, podemos utilizar un bucle do:
do i=1, size(pi)
print *, "Pi: ",pi(i)
end do

!Si quisieramos un bucle que haga algo hasta que una condición sea verdadera, hacemos uso de el bucle do-while:
i = 1
do while (i .ne. size(pi)+1)
print *, "Pi_2: ", pi(i)
i = i + 1
end do

!Este bucle hace lo mismo que el anterior.

!También se puede utilizar algo llamado "Implied DO" para construir arreglos de dimensión 1
!Utilizando la siguiente sintaxis:

! 					<expr. 1>[, <expr. 2>, <expr. k>], <variable>  = <np>, <nf>[,<nc>]

!Donde aquellas expresiones encerradas en corchetes son opcionales. Además, <variable>
!debe ser de tipo Integer, que toma los valores enteros np, np+nc, np+nc+nc, ..., comprendidos
!entre np y nf; Si se omite nc, toma el valor de 1.

!Ejemplo:
print *, (0, (-1)**k, k=0, 2)!Esto da 0, 1, 0, -1, 0, 1

print *, (0, (0, -1)**k, k=0, 2)

!Estos ciclos se pueden anidar:

print *, (i*k, (j*j, i*j, j=1, 3), i=2, 4)

print *, (1+k, (1, j**k, j=1, 2), k = 1, 2)

!Por último, podemos controlar el flujo del bucle con las instrucciones:
! exit: Sale instantaneamente del bucle
! cycle: El programa continua at inicio de la siguiente iteración
! stop: El programa detiene su ejecución.

end program bucles


program main

  implicit none

  double precision :: x, y, z
  double precision :: compute

  x = 1.0
  y = 2.0

  z = compute(x, y)

  call print_result(z)

end program main


! { dg-do compile }
!  PR 50130 - this caused an ICE.  Test case supplied by Joost
!  VandeVondele.
integer, parameter :: a(10)=0
integer, parameter :: b(10)=a(1:10:0) ! { dg-error "Illegal stride of zero" }
END


! sandbox fortran90

program prog01
    use progmod
    implicit none

    double precision :: z = 1.0d0 ! <= 'd' car 'e' c'est un real (float)
    logical          :: flag = .true.  ! ATTENTION une variable initialisee ici est implictement "save" (static)
    real             :: b
    integer          :: i = 2, &   ! on peut mettre des commentaires ici
                        n = 5; print *, 'hello world i=', i ! <= pas depasser la 132e colonne ------------------------------------->

    b = 2; i = 3
    print *, 'hello &
          &world coupe', flag, z

    do i = 1, n
        print *, 'i=', i
    end do

    print '("hello")'           ! ne laisse pas un caractere blanc (1x) en 1ere colonne!
    print '(A)', "hello"        ! mieux - A = string
    print '(A,i5)', "hello i=", i
    print *, 'globvar=', globvar

end


!!    Each process prints out a "Hello, world!" message with a process ID
!!  Original Author:  John Burkardt
!!  Modified: Michael Hirsch, Ph.D.

use mpi  ! Windows Intel 2019 MPI doesn't have mpi_f08 yet (grrr)
use, intrinsic:: iso_fortran_env, only: dp=>real64, compiler_version
implicit none

integer :: i, Nproc, ierr
real(dp) :: wtime

!>  Initialize MPI.
call MPI_Init(ierr)
if (ierr /= 0) error stop 'mpi init error'

!>  Get the number of processes.
call MPI_Comm_size(MPI_COMM_WORLD, Nproc, ierr)

!>  Get the individual process ID.
call MPI_Comm_rank(MPI_COMM_WORLD, i, ierr)

!>  Print a message.
if (i == 0) then
  print *,compiler_version()
  wtime = MPI_Wtime()
  print *, 'number of processes: ', Nproc
end if

print *, 'Process ', i

if ( i == 0 ) then
  wtime = MPI_Wtime() - wtime
  print *, 'Elapsed wall clock time = ', wtime, ' seconds.'
end if

!>  Shut down MPI.
call MPI_Finalize(ierr)
if (ierr /= 0) error stop 'mpi finalize error'

end program


program print_logicals
    implicit none
    logical :: l = .false.
    integer :: width
    character(len=10) :: fmt

    do width = 1, 6
        write (fmt, "('(L', I0, ')')") width
        print fmt, l
    end do
end program print_logicals


! Using functions
! Bug: the function return type replaced by "OVERLOADED"

program main

    implicit none
    integer :: a,b,c,add1,add2
    a = 10
    b = 20

    c = add1(a,b)
    c = add2(a,b)

end program main

function add1(a, b)
    integer a, b, add1
    add1 = a + b
    return
end function add1

integer function add2(a, b)
    integer a, b
    add2 = a + b
    return
end function add2


! chk_recursive_io.f90 --
!     Check if the compiler allows recursive I/O
!
!     Note:
!     This program checks the Fortran 2008 feature of recursive I/O, not the variations
!     the Fortran 2003 allows (internal reads/writes)
!
program chk_recursive_io
    implicit none

    integer :: lun, ierr
    real    :: x, y

    lun = 10
    x   = 1.0
    y   = 1.0

    open( lun,   file = 'chk_recursive_io.out' )
    open( lun+1, file = 'chk_recursive_io.dummy' )

    write( lun, '(2f10.3)', iostat = ierr ) x, f(y)

    if ( ierr /= 0 ) then
        write( *, '(a)' ) 'Recursive I/O (Fortran 2008 feature) to different file units is allowed'
    else
        write( *, '(a)' ) 'Recursive I/O (Fortran 2008 feature) seems not to be allowed'
    endif
contains
real function f(y)
    real, intent(in) :: y

    write(lun+1, '(a,f10.3)' ) 'Argument: ', y

    f = 2.0 * y
end function f
end program chk_recursive_io


program main

 implicit none

 integer :: i
 character(len=5),dimension(5),parameter :: colors = ['Red  ','Green','Blue ','Black','White']

 !using a do loop:
 do i=1,size(colors)
   write(*,'(A)') colors(i)
 end do

 !this will also print each element:
 write(*,'(A)') colors

end program main


    module custom_precision

    implicit none

    integer, parameter      :: SP = kind(1.)
    integer, parameter      :: DP = kind(1.d0)

    end module custom_precision


PROGRAM test_read
INTEGER :: i = 1, j = 2, k = 3
WRITE (*,*) 'Enter i, j, and k: '
READ (*,*) i, j, k
WRITE (*,*) 'i, j, k = ', i, j, k
END PROGRAM test_read


program while_loop_1

    integer,parameter :: n=139, i=0

    real*8 a(n)

    !$xev loop_tag
    hoge: do while(i<n)
        a(i) = 0
        i = i+1
    end do

end program while_loop_1


      program commandLine_04
!
!     This program demonstrates the two key functions available in Fortran for
!     getting command line arguments.
!
!     H. P. Hratchian, 2020.
!
!
      implicit none
      integer::nArguments,i,intTemp,total
      character(len=256)::commandLineArg
!
!     Find out how many command line arguments there are and report that.
!
      nArguments = COMMAND_ARGUMENT_COUNT()
      write(*,*)' The number of command line arguements is ',nArguments
      total = 0
      do i = 1,nArguments
        call GET_COMMAND_ARGUMENT(i,commandLineArg)
        write(*,*)' argument number ',i,' is:',TRIM(commandLineArg)
        read(commandLineArg,*) intTemp
        total = total + intTemp
      endDo
      write(*,*)' The total sum of all the integers is ',total
!
      end program commandLine_04


program main

  use mpi
  use omp_lib
  implicit none

  integer :: ierr, rank, size, tid, thread_level
  character(len=*), parameter :: FMT1 = "(2(A, I4))"

  call MPI_INIT_THREAD(MPI_THREAD_FUNNELED, thread_level, ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
  call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)

  write(*, FMT1) "Hello, world! I am the main thread of MPI rank ", &
                 rank, " of size ", size

  !$OMP PARALLEL PRIVATE(tid)
  tid = OMP_GET_THREAD_NUM()
  write(*, FMT1) "Hello, world! I am OpenMP thread ", &
                 tid, " of MPI rank ", rank
  !$OMP END PARALLEL

  call MPI_FINALIZE(ierr)

end program main


! { dg-do run }
! { dg-shouldfail "Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" }
! { dg-options "-fbounds-check" }
program main
  integer, dimension(:,:), allocatable :: a, b
  integer, dimension(:), allocatable :: sh
  allocate (a(2,2))
  allocate (b(2,2))
  allocate (sh(3))
  a = 1
  b = cshift(a,sh)
end program main
! { dg-output "Fortran runtime error: Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" }


! chk_allocate_mold.f90
!     Check: does the compiler support the MOLD argument to the allocate statement?
!
program chk_allocate_mold
    implicit none

    integer, dimension(10,7)           :: src
    integer, dimension(:,:), allocatable :: target

    allocate( target, mold = src )

    write( *, '(a,i0)' )   'Size of the allocated array: ', size(target)
    write( *, '(a,10i5)' ) 'Shape:                       ', shape(target)

    if ( any( shape(src) /= shape(target) ) ) then
        write( *, '(/,a)' ) 'NOTE: this is not what was expected (expected shape: 10, 7)'
    else
        write( *, '(/,a)' ) 'Shape as expected (same as source array)'
    endif
end program chk_allocate_mold


PROGRAM linked_list
IMPLICIT NONE
TYPE :: node
  REAL :: value
  TYPE (node), POINTER :: prev
  TYPE (node), POINTER :: next
END TYPE node

TYPE (node), POINTER :: head => NULL()
CHARACTER(len=20) :: filename
INTEGER :: nvals = 0
TYPE (node), POINTER :: ptr => NULL()
TYPE (node), POINTER :: tail => NULL()
INTEGER :: istat
CHARACTER(len=80) :: msg
REAL :: temp

! Get the name of the file containing the input data.
WRITE(*, *) 'Enter the file name with the data to be read: '
READ(*, '(A20)') filename
! Open the input data file.
OPEN(UNIT=9, FILE=filename, STATUS='OLD', ACTION='READ', &
     IOSTAT=istat, IOMSG=msg)
! Was the OPEN successful?
fileopen: IF (istat == 0) THEN
  ! The file was opened successfully, so read the data from
  ! it, and store it in the linked list.

  input: DO
    READ(9, *, IOSTAT=istat) temp
    IF(istat /= 0) EXIT
    nvals = nvals + 1
    IF (.NOT. ASSOCIATED(head)) THEN
      ALLOCATE(head, STAT=istat)
      tail => head
      NULLIFY(tail%next)
      tail%value = temp
    ELSE
      ALLOCATE (tail%next, STAT=istat)
      ptr => tail
      tail => tail%next
      tail%prev => ptr
      NULLIFY(tail%next)
      tail%value = temp
    END IF
  END DO input
  ! Now, write out the data
  ptr => head
  WRITE(*, '(A)') ' Printing list.'
  forward: DO
    IF (.NOT. ASSOCIATED(ptr)) EXIT
    WRITE(*, '(F10.4)') ptr%value
    ptr => ptr%next
  END DO forward
  ptr => tail
  WRITE(*, '(A)') ' Printing list backwards.'
  backward: DO
    IF (.NOT. ASSOCIATED(ptr)) EXIT
    WRITE(*, '(F10.4)') ptr%value
    ptr => ptr%prev
  END DO backward
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, '(A,I6)') 'File open failed. Status: ', istat
  WRITE(*, *) msg
END IF fileopen
END PROGRAM linked_list


C File: derived-types-01.f
C Illustrates simple user-defined types in Fortran

      program main
      implicit none

      type mytype
      integer :: k
      real :: v
      end type mytype

      type (mytype) x, y;

      x%k = 12
      x%v = 3.456

      y%k = 21
      y%v = 4.567

 10   format (2(I5, X, F6.3))
      write (*, 10) x%k, y%v, y%k, x%v

      stop
      end program main


! chk_int_too_large.f90 --
!     Check: does the compiler accept integer values that exceed the limit?
!
program chk_int_too_large
    implicit none

    integer :: x

    x = 4000000000

    write( *, '(a)'    ) 'Variable was set to 4*10**9'
    write( *, '(a,i0)' ) 'Actual value for the variable:             ', x
    write( *, '(a,i0)' ) 'Maximum value for default integers (HUGE): ', huge(x)

    write( *, '(/,a)'  ) 'The compiler accepts such large values'
end program chk_int_too_large


! { dg-do compile }
! Tests the fix for 26074, in which the array reference below would
! be determined not to be constant within modules.
!
! Contributed by Jonathan Dursi  <ljdursi@cita.utoronto.ca>
!
module foo

   integer, parameter :: len = 5
   integer :: arr(max(len,1))

end


PROGRAM ptr_array
IMPLICIT NONE
TYPE :: ptr
   REAL, DIMENSION(:), POINTER :: p
END TYPE
TYPE (ptr), DIMENSION(3) :: p1
REAL, DIMENSION(4), TARGET :: a = (/ 1.,  2.,  3.,  4. /)
REAL, DIMENSION(4), TARGET :: b = (/ 5.,  6.,  7.,  8. /)
REAL, DIMENSION(4), TARGET :: c = (/ 9., 10., 11., 12. /)
p1(1)%p => a
p1(2)%p => b
p1(3)%p => c
WRITE (*,*) p1(3)%p
WRITE (*,*) p1(2)%p(3)
END PROGRAM ptr_array


! Demonstrate merge
program xmerge
implicit none
integer :: i
do i=-1,1
   print*,i
   ! "zero" must be padded to have same length as "positive"
   print*,merge("negative",merge("zero    ","positive",i==0),i<0)
end do
end program xmerge


!------------------------------
! subOutside is an external procedure
subroutine subOutside(y,M)
  implicit none

  real, intent(in)    :: y(M)
  integer, intent(in) :: M

  integer           :: j

  print*, 'size of y ', size(y)
  do  j=1,size(y)
    print*, 'y(',j,') = ', y(j)
  enddo

! it will not work here:  print*,x
! because x is not visible from subOutside (no interface)
end subroutine subOutside


Module LeeX

Implicit None
! Aquí se declaran las variables globales del Modulo
!No tenemos variables globales del Modulo para declarar

contains
	! La Declaración 'contains' se utiliza para declarar las funciones dentro de un módulo
	! y se coloca despues de declarar las variables globales del modulo.

   Function FuncLeeX()

     real :: FuncLeeX

     Print *,'Por favor ingrese un Numero Real'
     Read *, FuncLeeX
     Print *, 'El valor ingresado es :', FuncLeeX

   End Function FuncLeeX

End Module LeeX


!! R757 forall-assignment-stmt
!    is assignment-stmt
!    or pointer-assignment-stmt

integer :: A(10)

forall (i = 1:10)
  A(i) = 13
end forall

END


!*****************************************************************************************
!> author: Jacob Williams
!  license: BSD
!
!### Description
!  Numeric kind definitions for BSpline-Fortran.

    module bspline_kinds_module

    use,intrinsic :: iso_fortran_env

    implicit none

    private

#ifdef DOUBLE_PREC
    integer,parameter,public :: wp = real64  !! Real precision
#else
    integer,parameter,public :: wp = real32  !! Real precision
#endif

    integer,parameter,public :: ip = int32   !! Integer working precision

!*****************************************************************************************
    end module bspline_kinds_module
!*****************************************************************************************


! chk_function_unset.f90 --
!     Check if the compiler checks for functions that do not set a value
!
program chk_function_unset
    implicit none

    integer :: x, y

    x = 1
    y = myfunc( x )

    write( *, '(a,i0)' ) 'Function did not set its return value, but the result is: ', y
contains
integer function myfunc( x )
    integer, intent(in) :: x

    integer :: z

    if ( x > 0 ) then
        z = 1
    else
        z = 2
    endif
end function myfunc
end program chk_function_unset


program pointerExample
implicit none

   integer, pointer :: p1
   integer, target :: t1
   integer, target :: t2

   p1=>t1 ! associate pointer p1 to target t1
   p1 = 1

   Print *, p1
   Print *, t1

   p1 = p1 + 4
   Print *, p1
   Print *, t1

   t1 = 8
   Print *, p1
   Print *, t1

   nullify(p1) ! dissociate pointer p1 from target t1
   Print *, t1

   p1=>t2 ! associate pointer p1 to target t1
   Print *, associated(p1)
   Print*, associated(p1, t1)
   Print*, associated(p1, t2)

   !what is the value of p1 at present
   Print *, p1
   Print *, t2

   p1 = 10
   Print *, p1
   Print *, t2
   Print *, t1

end program pointerExample


! Copyright (c) 2005-2010, 2012-2013, Andrew Hang Chen and contributors,
! All rights reserved.
! Licensed under the 3-clause BSD license.

module calculator_test
  use fruit
  implicit none

contains                          !fortran 95 limits subroutine name to 31 char.
  subroutine test_calculator_should_produce_4_when_2_and_2_are_inputs
    use calculator, only: add
    integer:: result

    call add (2,2,result)
    call assert_equals (4, result)
  end subroutine test_calculator_should_produce_4_when_2_and_2_are_inputs
end module calculator_test


program nullify_02
implicit none

   real, pointer :: p1
   real, target :: t1
   integer, pointer :: p2
   integer, target :: t2

   p1=>t1
   p1 = 1
   p2=>t2
   p2 = 2.
   nullify(p1, p2)

end program nullify_02


program outputdata

   real, dimension(5) :: x, y(10)
   integer :: i

   do i = 1, 5
    x(i) = 1.0
   end do

   do i = 1, 10
    y(i) = 10.0
   end do

   print *, x
   print *, y

end program outputdata


      PROGRAM TEST
      INTEGER N
      PARAMETER (N=10)
      REAL ARRAY(N) !The index of ARRAY should from 1 to 10.
      ARRAY(11) = 1.0 !It uses an index out of the bound.
      END


PROGRAM LOOP_FUSION
  CALL clawloop
END

SUBROUTINE clawloop ( )

 INTEGER :: i
 INTEGER :: j
 INTEGER :: k

 DO i = 1 , 5 , 1
  DO j = 1 , 4 , 1
   DO k = 1 , 2 , 1
    PRINT * ,"First loop body:" , i , j
    PRINT * ,"Second loop body:" , i , j
   END DO
  END DO
 END DO
END SUBROUTINE clawloop


PROGRAM ptr_array
IMPLICIT NONE
TYPE :: ptr
  REAL, DIMENSION(:), POINTER :: p
END TYPE ptr
TYPE (ptr), DIMENSION(3) :: p1
REAL, DIMENSION(4), TARGET :: a = [1., 2., 3., 4.]
REAL, DIMENSION(4), TARGET :: b = [5., 6., 7., 8.]
REAL, DIMENSION(4), TARGET :: c = [9., 10., 11., 12.]
p1(1)%p => a
p1(2)%p => b
p1(3)%p => c
WRITE(*, *) p1(3)%p
WRITE(*, *) p1(2)%p(3)
END PROGRAM ptr_array


! { dg-do run }
      integer i, j /1/, g/2/, h ! { dg-warning "" "" }
      integer k, l(3) /2*2,1/   ! { dg-warning "" "" }
      real pi /3.1416/, e       ! { dg-warning "" "" }

      if (j /= 1) call abort ()
      if (g /= 2) call abort ()
      if (any(l /= (/2,2,1/))) call abort ()
      if (pi /= 3.1416) call abort ()
      end


      SUBROUTINE copy(aout,ain,n)
      INTEGER n
      DOUBLE PRECISION ain(n,n),aout(n,n)
      INTEGER i,j
      do 12 i=1,n
        do 11 j=1,n
          aout(j,i)=ain(j,i)
11      continue
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/copy.for


program vin
  integer::i
  do i =1,10

  if (i == 5) cycle
  if (i == 9) exit
  print *,i
  end do
end program vin


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program ftest

! very simple fortran program.  used to test compile and run
! of fortran.  if successful, will print a message and exit.

integer :: i, j

   print *, "program start"
   i = 2
   j = 3

   print *, "2 + 3 = ", i + j

   print *, "program end"

end program ftest

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


! { dg-do compile }
! { dg-options "-Wall" }
!
! PR fortran/54199
!
subroutine test()
contains
  real function fraction(x) ! { dg-warning "'fraction' declared at .1. may shadow the intrinsic of the same name.  In order to call the intrinsic, explicit INTRINSIC declarations may be required." }
    real :: x
    fraction = x
  end function fraction
end subroutine test


Program Ejemplo15
!
!		Aqui veremos el Uso del lazo CYCLE
!
IMPLICIT NONE

INTEGER :: ii, jj, kk

ii = 10
jj = 10

 Loop2: Do ii = 1, 15

			Print *, ' ii : ', ii

			IF (ii .LT. 10) CYCLE Loop2

 Loop1:		DO kk = 1, 20

				Print *,'Loop 1'
					IF (kk.lt.12) CYCLE Loop1
					Print *,'kk : ', kk

			END DO Loop1

		END Do  Loop2

End Program Ejemplo15


PROGRAM interface_example
!
!  Purpose:
!    To illustrate the use of interface blocks to create explicit
!    interfaces.  This program uses an interface block to create
!    an explicit interface to subroutine "sort", and then takes
!    advantage of that interface to use keyword arguments.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/08/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare interface to subroutine "sort"
INTERFACE
   SUBROUTINE sort(a,n)
   IMPLICIT NONE
   REAL, DIMENSION(:), INTENT(INOUT) :: a
   INTEGER, INTENT(IN) :: n
   END SUBROUTINE sort
END INTERFACE

! Data dictionary: declare local variable types & definitions
REAL, DIMENSION(6) :: array = (/ 1., 5., 3., 2., 6., 4. /)
INTEGER :: nvals = 6

! Call "sort" to sort data into ascending order.
CALL sort ( N=nvals, A=array)

! Write out sorted array.
WRITE (*,*) array

END PROGRAM interface_example


program main
implicit none
character (len=100) :: text
integer :: i,j,ierr
text = "42 abc"
i = 7
j = 8
block ! itmp and jtmp not used outside block
   integer :: itmp, jtmp
   ! try to read two integers
   read (text,*,iostat=ierr) itmp,jtmp
   if (ierr == 0) then
      i = itmp
      j = jtmp
   else ! try to read one integer
      read (text,*,iostat=ierr) itmp
      if (ierr == 0) i = itmp
   end if
end block
print*,"i, j =",i,j
end program main
! output with gfortran and ifort:
! i, j = 42 8


! Simple "Hello World" program
program hello

  use omp_lib
  implicit none

  integer :: nthreads, tid

  !$OMP PARALLEL PRIVATE(nthreads, tid)
  tid = OMP_GET_THREAD_NUM()
  print *, "Hello, world! I am thread ", tid

  !$OMP BARRIER

  if (tid .eq. 0) then
    nthreads = OMP_GET_NUM_THREADS()
    print *, "Number of threads = ", nthreads
  end if
  !$OMP END PARALLEL

end program hello


program initialize_stack
  implicit none
  integer          :: i
  real             :: r
  complex          :: cplx
  double precision :: d

  call write_var(i,r,cplx,d)

contains
subroutine write_var(i,r,cplx, d)
  implicit none
  integer, intent(in)          :: i
  real, intent(in)             :: r
  complex, intent(in)          :: cplx
  double precision, intent(in) :: d

 print*, 'Integer = ', i
 print*, 'Real single precision = ', r
 print*, 'Complex = ', cplx
 print*, 'Double prevision = ', d
end subroutine write_var
end program initialize_stack


PROGRAM compare
!
!  Purpose:
!    To compare two strings to see if they are equivalent,
!    ignoring case.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/14/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
INTEGER :: i                 ! Loop index
CHARACTER(len=20) :: str1    ! First string to compare
CHARACTER(len=20) :: str1a   ! Copy of first string to compare
CHARACTER(len=20) :: str2    ! Second string to compare
CHARACTER(len=20) :: str2a   ! Copy of second string to compare

! Prompt for the strings
WRITE (*,*) 'Enter first string to compare:'
READ (*,*) str1
WRITE (*,*) 'Enter second string to compare:'
READ (*,*) str2

! Make copies so that the original strings are not modified
str1a = str1
str2a = str2

! Now shift lower case letters to upper case.
DO i = 1, LEN(str1a)
   IF ( str1a(i:i) >= 'a' .AND. str1a(i:i) <= 'z' ) THEN
      str1a(i:i) = ACHAR ( IACHAR ( str1a(i:i) ) - 32 )
   END IF
END DO
DO i = 1, LEN(str2a)
   IF ( str2a(i:i) >= 'a' .AND. str2a(i:i) <= 'z' ) THEN
      str2a(i:i) = ACHAR ( IACHAR ( str2a(i:i) ) - 32 )
   END IF
END DO

! Compare strings and write result
IF ( str1a == str2a ) THEN
   WRITE (*,*) "'", str1, "' = '", str2, "' ignoring case."
ELSE
   WRITE (*,*) "'", str1, "' /= '", str2, "' ignoring case."
END IF

END PROGRAM compare


! Rank 0 reads in the array size.  This size is sent to the other ranks.  All
! ranks allocate the same array and set its values to zero.  Rank 0 populates
! this array with some arithmetic progression.
!
! Compile with
!
!   $ mpifort -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace barrier.f90
!
! Run with
!
!   $ mpirun -np 5 --oversubscribe ./a.out
program barrier
    use mpi_f08
    implicit none
    type(MPI_Comm)   :: comm
    type(MPI_Status) :: status
    integer :: my_rank, n_ranks, i, a_size
    integer, allocatable :: a(:)

    call MPI_Init()

    comm = MPI_COMM_WORLD

    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    a_size = 0
    if (my_rank == 0) then
        read *, a_size
        do i = 1, n_ranks - 1
            call MPI_Send(a_size, 1, MPI_INTEGER, i, 0, comm)
        end do
    else
        call MPI_Recv(a_size, 1, MPI_INTEGER, 0, 0, comm, status)
    end if
    allocate(a(a_size), source=0)

    call print_p2p(a, my_rank, n_ranks, comm)

    if (my_rank == 0) then
        a(:) = [ (i, i = 1, a_size) ]
    end if

    call print_p2p(a, my_rank, n_ranks, comm)

    if (allocated(a)) deallocate(a)
    call MPI_Finalize()

contains

    !---------------------------------------------------------------------------
    subroutine print_p2p(arr, my_id, n_ids, comm)
        integer,        intent(in) :: arr(:), my_id, n_ids
        type(MPI_Comm), intent(in) :: comm

        if (my_id == 0) then
            block
                integer              :: rank
                type(MPI_Status)     :: status
                integer, allocatable :: arr_out(:)
                allocate(arr_out, mold=arr)
                do rank = 0, n_ids - 1
                    if (rank == 0) then
                        arr_out(:) = arr(:)
                    else
                        call MPI_Recv(arr_out, size(arr_out), MPI_INTEGER, rank, 9, comm, status)
                    end if
                    print "(a, i0, a, *(i2, 1x))", "Rank ", rank, ", a(:)=", arr_out
                end do
                print *
                deallocate(arr_out)
            end block
        else
            call MPI_Send(arr, size(arr), MPI_INTEGER, 0, 9, comm)
        end if
        return
    end subroutine print_p2p
    !---------------------------------------------------------------------------
    subroutine print_barrier(arr, my_id, n_ids, comm)
        integer,        intent(in) :: arr(:), my_id, n_ids
        type(MPI_Comm), intent(in) :: comm
        integer :: rank

        do rank = 0, n_ids - 1
            if (rank == my_id) then
                print "(a, i0, a, *(i2, 1x))", "Rank ", rank, ", a(:)=", arr
            end if
            call MPI_Barrier(comm)
        end do
        if (my_id == 0) print *
        return
    end subroutine print_barrier
    !---------------------------------------------------------------------------

end program barrier


PROGRAM test_vector
!
!  This program tests the vector class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE vector_class                  ! Import vector class
IMPLICIT NONE

! Declare variables
REAL,DIMENSION(6) :: array        ! Array of data to load / save
INTEGER :: istat                  ! Allocate status
TYPE(vector),POINTER :: my_vec    ! Test object

! Create an object of type "vector" using the pointer
ALLOCATE( my_vec, STAT=istat )

! Save an array of data in this object.
array = (/ 1., 2., 3., 4., 5., 6. /)
CALL my_vec%set_vector(array)

! Retrieve the data from this vector.
array = 0
CALL my_vec%get_vector(array)
WRITE (*,'(A,6F6.1)') 'vector = ', array

! Destroy this object
WRITE (*,*) 'Deallocating vector object ...'
DEALLOCATE( my_vec, STAT=istat )

END PROGRAM test_vector


program reutilizar
    real :: f, a
    read*, a
    if (a<4) then
        f=1
        print*, f
    else if (a>4) then
        f=2
        print*, f
    end if
end program reutilizar


PROGRAM bad_call
!
!  Purpose:
!    To illustrate misinterpreted calling arguments.
!
IMPLICIT NONE
REAL :: x = 1.                ! Declare real variable x.
CALL bad_argument ( x )       ! Call subroutine.
END PROGRAM bad_call

SUBROUTINE bad_argument ( i )
IMPLICIT NONE
INTEGER :: i                  ! Declare argument as integer.
WRITE (*,*) 'I = ', i         ! Write out i.
END SUBROUTINE bad_argument


program main
IMPLICIT NONE
double precision :: a
double precision :: b
a=3.0
b=4.0
print*, a
END PROGRAM main


program loop_index
implicit none
integer :: i
do i=1,3
   call sub(i) ! invalid since this changes i
   print*,i,i**2
end do
contains
subroutine sub(i)
integer :: i
! gfortran gives an error and ifort warns if
! i is declared intent(in out)
i = 2*i
end subroutine sub
end program loop_index
! gfortran, ifort, and lfortran output:
!            2           4
!            6          36
! flang and g95 output:
!  2 4
!  6 36
!  14 196


      program test
      integer j,k, jlast, klast
!$omp parallel
!$omp do private(j,k) collapse(2) lastprivate(jlast, klast)
      do k = 1,2
        do j = 1,3
           jlast=j
           klast=k
        enddo
      enddo
!$omp end do
!$omp single
      print *, klast, jlast
!$omp end single
!$omp end parallel
      end program test


! chk_dim_15.f90 --
!     Check: does the compiler support arrays with 15 dimensions
!
program chk_dim_15
    implicit none

    real, dimension(2,2,2,2,2 ,2,2,2,2,2 ,2,2,2,2,2) :: array

    write( *, '(a)'      ) 'The compiler supports arrays of at least 15 dimensions:'
    write( *, '(a,i0)'   ) '    Total size: ', size(array)
    write( *, '(a,i0)'   ) '    Dimensions: ', size(shape(array))
    write( *, '(a,20i3)' ) '    Shape:      ', shape(array)
end program chk_dim_15


! Sourced allocation in Object-oriented programming (Metcalf et al., 2018) 15.4.4 (p.298-)
! allocate (a, source=b) は配列bのindexの下限，上限が配列aに引き継がれる
module mod_source_allocation
    implicit none
    type :: t
        integer :: x
        real :: y
    end type t

contains

    subroutine s_set(b)
        ! Set lower and upper bounds
        ! 次行はtype(t)でもよいが，tを拡張した型に対応できるclass(t)が汎用的
        class(t), intent(in) :: b(:)                                 ! 形状引継ぎ仮配列 assumed-shape array
        ! 割付仮配列も可能
        !   割付仮配列とする場合の要件：実引数も割付配列，実引数と仮引数は同一type，引用仕様明示
        !   同一typeの条件より，仮引数をclassにするとエラーとなる
        !   type(t), intent(in), allocatable  :: b(:)                   ! 割付仮配列
        !!! class(t), intent(in), allocatable  :: b(:)                ! Error
        class(t), allocatable :: a(:)
        allocate (a(lbound(b,1):ubound(b,1)), source=b)  ! 配列indexの下限と上限を指定
        print *, 's_set a=', a(:)%x, a(:)%y
    end subroutine s_set

    subroutine s(b)
        class(t) :: b(:)
        class(t), allocatable :: a(:)
        allocate (a, source=b)                           ! 配列indexの下限と上限を指定しない
        print *, 's a=', a(:)%x, a(:)%y
    end subroutine s

end module mod_source_allocation

program source_allocation
    use mod_source_allocation
    implicit none

    type(t), allocatable :: b(:)
    allocate(t :: b(0:1))                                ! 配列indexの下限0，上限1と指定
    b(0) = t(1, 1.0)
    b(1) = t(2, 2.0)
    print *, 'b=', b%x, b%y
    ! 配列bのindexの下限，上限を組込関数lbount()，ubound()から取得
    call s_set(b)
    ! 配列indexの下限・上限は実引数から取得
    call s(b)

end program source_allocation


! =========================================================
!> Check for NANs in solution q
subroutine check4nans(meqn,mbc,mx,my,q,t,ichecknan)

    implicit none

    ! Input
    integer, intent(in) ::  meqn, mbc, mx, my, ichecknan
    real(kind=8), intent(in) :: t, q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer :: i, j, m

    ! print *,'Checking for NANs at ichecknan = ',ichecknan
    ! print *,'  mx = ',mx,'  my = ',my,'  meqn = ',meqn

    do i=1-mbc,mx+mbc
        do j=1-mbc,my+mbc
            do m=1,meqn
                if (.not. (q(m,i,j) == q(m,i,j))) then
                    ! true if q(i,j,m) = NAN
                    print *, 'SOLUTION ERROR --- ABORTING CALCULATION'
                    print *, 'At ichecknan = ',ichecknan
                    print *, '   mx,my,t:',mx,my,t
                    print *, '   m,i,j:',m,i,j
                    print *, '   q(m,i,j) = ',q(m,i,j)
                    stop
                endif
            enddo
        enddo
    enddo

    ! Uncomment the next line if desired when debugging:
    ! print *,'No NANs at ichecknan = ',ichecknan,' at t = ',t

end subroutine check4nans


subroutine mysub(a, B, C)

    integer, parameter :: rk = selected_real_kind(15,300)

    integer :: a
    real(rk) :: B(10,20)
    real(rk) :: C(30)

    a = 42
    B = 42.0_rk
    C = 84.0_rk

end subroutine mysub


PROGRAM test_ptr3
IMPLICIT NONE
REAL, POINTER :: p1, p2, p3
REAL, TARGET :: a = 11., b = 12.5, c = 3.141592
NULLIFY ( p1, p2, p3)     ! Nullify pointers
WRITE (*,*) ASSOCIATED(p1)
p1 => a                   ! p1 points to a
p2 => b                   ! p2 points to b
p3 => c                   ! p3 points to c
WRITE (*,*) ASSOCIATED(p1)
WRITE (*,*) ASSOCIATED(p1,b)
END PROGRAM test_ptr3


PROGRAM hello_f
  USE mpi
  IMPLICIT NONE
  INTEGER :: ierr
  INTEGER :: thistask
  INTEGER :: ntask

  CALL mpi_init(ierr)
  CALL mpi_comm_rank(MPI_COMM_WORLD, thistask, ierr)
  CALL mpi_comm_size(MPI_COMM_WORLD, ntask, ierr)

  WRITE (*,"(A,I0,A,I0)") "Hello, World! from task ", thistask, " of ",ntask

  CALL mpi_finalize(ierr)
END PROGRAM hello_f


    program demo_system_clock
    implicit none
    integer, parameter :: wp = kind(1.0d0)
    integer :: count, count_rate, count_max
    integer :: start, finish
    real    :: time_read

       call system_clock(count, count_rate, count_max)
       write(*,*) count, count_rate, count_max

       call system_clock(start, count_rate)
       ! <<<< code to time
       call system_clock(finish)
       time_read=(finish-start)/real(count_rate,wp)
       write(*,'(a30,1x,f7.4,1x,a)') 'time * : ', time_read, ' seconds'

    end program demo_system_clock


! Created By EverLookNeverSee@GitHub on 10/04/20
! If the range -999999 to 999999 is desired, k6 may be
! established as a constant with an appropriate value
! by the statement.

program main
    implicit none
    ! defining desired kind and testing it
    integer, parameter :: k6 = selected_int_kind(6)
    integer :: x = 1_k6
    print *, "x = ", x
end program main


! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Test the fix for PR83567 in which the parameterized component 'foo' was
! being deallocated before return from 'addw', with consequent segfault in
! the main program.
!
! Contributed by Berke Durak  <berke.durak@gmail.com>
! The function 'addvv' has been made elemental so that the test can check that
! arrays are correctly treated and that no memory leaks occur.
!
module pdt_m
  implicit none
  type :: vec(k)
     integer, len :: k=3
     integer :: foo(k)=[1,2,3]
  end type vec
contains
  elemental function addvv(a,b) result(c)
    type(vec(k=*)), intent(in) :: a
    type(vec(k=*)), intent(in) :: b
    type(vec(k=a%k)) :: c

    c%foo=a%foo+b%foo
  end function
end module pdt_m

program test_pdt
  use pdt_m
  implicit none
  type(vec) :: u,v,w, a(2), b(2), c(2)
  integer :: i

  u%foo=[1,2,3]
  v%foo=[2,3,4]
  w=addvv(u,v)
  if (any (w%foo .ne. [3,5,7])) STOP 1
  do i = 1 , a(1)%k
    a%foo(i) = i + 4
    b%foo(i) = i + 7
  end do
  c = addvv(a,b)
  if (any (c(1)%foo .ne. [13,15,17])) STOP 2
end program test_pdt
! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_malloc" 9 "original" } }


! This is part of the netCDF package.
! Copyright 2006 University Corporation for Atmospheric Research/Unidata.
! See COPYRIGHT file for conditions of use.

! This is a simple example which reads a small dummy array, from a
! netCDF data file created by the companion program simple_xy_wr.f90.

! This program is part of the netCDF tutorial:
! http://www.unidata.ucar.edu/software/netcdf/docs/tutorial_8dox.html

! Full documentation of the netCDF Fortran 90 API can be found at:
! http://www.unidata.ucar.edu/software/netcdf/docs-fortran/f90_The-NetCDF-Fortran-90-Interface-Guide.html

! Ed Hartnett

program simple_xy_rd
  use netcdf
  implicit none

  ! This is the name of the data file and variable.
  character (len = *), parameter :: FILE_NAME = "simple_xy_nc4.nc"
  character (len = *), parameter :: VAR_NAME = "data"

  ! We are reading 2D data, a 12 x 6 grid.
  integer, parameter :: NX = 6, NY = 12, MAX_DIMS = 2
  integer :: data_in(NY, NX)

  ! This will be the netCDF ID for the file and data variable.
  integer :: ncid, varid

  ! Information we will read about the variable.
  character (len = nf90_max_name) :: name
  integer :: xtype, ndims, dimids(MAX_DIMS), natts
  integer :: chunksizes(MAX_DIMS), deflate_level, endianness
  logical :: contiguous, shuffle, fletcher32

  ! Loop indexes, and error handling.
  integer :: x, y

  ! Open the file. NF90_NOWRITE tells netCDF we want read-only access
  ! to the file.
  call check( nf90_open(FILE_NAME, NF90_NOWRITE, ncid) )

  ! Get the varid of the data variable, based on its name.
  call check( nf90_inq_varid(ncid, VAR_NAME, varid) )

  ! Learn about the variable. This uses all optional parameters.
  call check( nf90_inquire_variable(ncid, varid, name, xtype, ndims, &
       dimids, natts, contiguous = contiguous, chunksizes = chunksizes, &
       deflate_level = deflate_level, shuffle = shuffle, &
       fletcher32 = fletcher32, endianness = endianness) )

  ! Make sure we got the correct answers. These depend on what was set
  ! when creating the file in simple_xy_nc4_wr.f90. Endianness will be
  ! whatever is native for the machine that's building this example.
  if (name .ne. VAR_NAME .or. xtype .ne. NF90_INT .or. ndims .ne. 2 .or. &
       natts .ne. 0 .or. contiguous .or. .not. shuffle .or. &
       deflate_level .ne. 1 .or. fletcher32) stop 3

  ! Read the data.
  call check( nf90_get_var(ncid, varid, data_in) )

  ! Check the data.
  do x = 1, NX
     do y = 1, NY
        if (data_in(y, x) /= (x - 1) * NY + (y - 1)) then
           print *, "data_in(", y, ", ", x, ") = ", data_in(y, x)
           stop "Stopped"
        end if
     end do
  end do

  ! Close the file, freeing all resources.
  call check( nf90_close(ncid) )

  print *,"*** SUCCESS reading example file ", FILE_NAME, "! "

contains
  subroutine check(status)
    integer, intent ( in) :: status

    if(status /= nf90_noerr) then
      print *, trim(nf90_strerror(status))
      stop 2
    end if
  end subroutine check
end program simple_xy_rd


Program Ejemplo10
!Aqui usaremos las sentencias de control
! IF, THEN, ELSE IF, ELSE, END IF.
!
!Adem�s haremos una introduccion a los operadores l�gicos

IMPLICIT NONE

INTEGER :: ii

Print *, 'Ingrese un numero entero del 1 al 10 :'
Read *, ii

	IF (ii == 1) THEN
		Print *, 'Numero Uno'
	ELSE IF (ii == 2) THEN
		Print *, 'Numero Dos'
	ELSE IF (ii == 3) THEN
		Print *, 'Numero Tres'
	ELSE IF (ii == 4) THEN
		Print *, 'Numero Cuatro'
	ELSE IF (ii == 5) THEN
		Print *, 'Numero Cinco'
	ELSE IF (ii == 6) THEN
		Print *, 'Numero Seis'
	ELSE IF (ii == 7) THEN
		Print *, 'Numero Siete'
	ELSE IF (ii == 8) THEN
		Print *, 'Numero Ocho'
	ELSE IF (ii == 9) THEN
		Print *, 'Numero Nueve'
	ELSE IF (ii == 10) THEN
		Print *, 'Numero Diez'
	ELSE
		Print *, 'Numero Equivocado'
	END IF

	IF (ii < 1) THEN
		PRINT *, 'Numero Negativo'
	END IF

	!Otro modo de uso de la sentencia IF
	IF (ii .GE. 11) PRINT *, 'Numero Muy Grande'

END PROGRAM Ejemplo10


!If elseif else
program If_ELseIf
    implicit none

    real :: mark

    mark = 60

    if (mark < 40) then
        print *, "You are fail"

    else if (mark == 40) then
        print *, "Just Passed"

    else if (mark == 60) then
        print *, "Satisfactory"

    else if (mark == 80) then
        print *, "Very good"

    else if (mark == 100) then
        print *, "No words, You have full marks."
    else
        print *, "Doesn't match to above condition"

    end if
end program If_ELseIf


! chk_associate --
!     Check: does the compiler support the ASSOCIATE construct?
!
program chk_associate
    implicit none

    type mytype
        real :: x, y
    endtype mytype

    type(mytype) :: coords
    real         :: xcoord

    coords = mytype( 0.0, 0.0 )

    xcoord = 1.0
    associate( x => coords%x )
        x = xcoord
    end associate

    write( *, '(a,f10.4)' ) 'X-coordinate set to: ', coords%x
    if ( xcoord == coords%x ) then
        write( *, '(a)' ) '    (value is as expected)'
    else
        write( *, '(a)' ) '    Unexpected value - please check!'
    endif
end program chk_associate


! Demonstrate allocation on assignment, "plain" allocate and allocate with source and mold, and deallocate
program alloc
implicit none
integer, allocatable :: v(:)
v = [4,9]     ! allocation upon assignmment
deallocate(v) ! necessary for line below to work -- cannot allocate an array that is already allocated
allocate (v,source=[4,9]) ! same effect as v = [4,9]
print*,v                  ! 4 9
deallocate(v)
allocate (v(2))
print*,v                  ! random output since v not set
deallocate(v)
allocate (v,mold=[4,9])   ! same effect as allocate (v(2)) -- does not set the elements of v
print*,v                  ! random output since v not set
end program alloc


PROGRAM doloop
    IMPLICIT NONE

    ! integer :: i, j,  x(10) = 0
    ! ! read (*, *) a, b, c

    ! do i = 1, 6
    !     write(*, 11) i
    !     11 format("for each i = " i1)
    !     do j = 1, 3
    !         write(*, 10) j
    !         10 format("j = " i1)
    !     enddo
    ! enddo

    ! write(*, 89) 856
    ! 89 format("The value is " i3)

    ! do list = max(a, b, c), min(a, b, c), -2
    !     write(*, *) list
    ! enddo

    ! do count = -3, 4, 2
    !     write(*, *)  count, count*count, count*count*count;
    ! enddo

    ! print *, sum

END PROGRAM doloop


MODULE mymodule

  IMPLICIT NONE
  SAVE

  INTEGER :: module_int
  INTEGER, PARAMETER :: module_parameter = 10
  REAL :: module_real

END MODULE mymodule

PROGRAM driver

  USE mymodule
  IMPLICIT NONE
  INTEGER :: myint

  PRINT *, module_parameter
  myint = module_parameter
  module_int = module_parameter
  module_real = REAL(module_int)

END PROGRAM driver


program  WORKSHARE1

    INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM, N, I
    PARAMETER (N = 10000)
    REAL A(N), B(N), C(N)

    ! Some initializations
    CALL OMP_SET_NUM_THREADS(4)

    !$OMP parallel do private (I) shared(A)
    DO I = 1, N
        A(I) = I
    ENDDO
    !$OMP end parallel do

    B = A

    !$OMP PARALLEL SHARED(A,B,C) PRIVATE(I,TID)

    TID = OMP_GET_THREAD_NUM()
    IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads =', NTHREADS
    END IF
    PRINT *, 'Thread', TID, ' starting...'

    !$OMP DO
    DO I = 1, N
        C(I) = A(I) + B(I)
        WRITE(*, 100) TID, I, C(I)
        100 FORMAT(' Thread', I2, ': C(', I3, ')=', F8.2)
    ENDDO
    !$OMP END DO NOWAIT

    PRINT *, 'Thread', TID, ' done.'

    !$OMP END PARALLEL

    return
END


! { dg-do compile }
! { dg-options "-Wrealloc-lhs-all -Wrealloc-lhs" }
!
! PR fortran/52196
!
implicit none
type t
  integer :: x
end type t
integer, allocatable :: a(:), b
real, allocatable :: r(:)
type(t), allocatable :: c(:)
character(len=:), allocatable :: str
character(len=:), allocatable :: astr(:)

allocate(a(2), b, c(1))
b = 4          ! { dg-warning "Code for reallocating the allocatable variable" }
a = [b,b]      ! { dg-warning "Code for reallocating the allocatable array" }
c = [t(4)]     ! { dg-warning "Code for reallocating the allocatable variable" }
a = 5          ! no realloc
c = t(5)       ! no realloc
str = 'abc'    ! { dg-warning "Code for reallocating the allocatable variable" }
astr = 'abc'   ! no realloc
astr = ['abc'] ! { dg-warning "Code for reallocating the allocatable array" }
a = reshape(a,shape(a)) ! { dg-warning "Code for reallocating the allocatable array" }
r = sin(r)
r = sin(r(1))  ! no realloc
b = sin(r(1))  ! { dg-warning "Code for reallocating the allocatable variable" }

a = nar() ! { dg-warning "Code for reallocating the allocatable array" }
a = nar2() ! { dg-warning "Code for reallocating the allocatable array" }
contains
  function nar()
    integer,allocatable :: nar(:)
  end function
  function nar2()
    integer :: nar2(8)
  end function
end


! $UWHPSC/codes/fortran/example1.f90

program example1

    implicit none
    real (kind=8) :: x,y,z

    x = 3.d0
    y = 2.d-1
    z = x + y
    print *, "z = ", z

end program example1


program hello_coarrays
  ! A coarray variant of a hello world program.
  ! Listing 1.1 in the book.
  implicit none

  integer :: a[*]
  integer :: i

  a = this_image()

  if (this_image() == 1) then
    do i = 1, num_images()
      print *, 'Value on image', i, 'is', a[i]
    end do
  end if

end program hello_coarrays


MODULE mymodule

 IMPLICIT NONE
 CONTAINS

  SUBROUTINE assignfn(arg1, arg2)
    INTEGER :: arg1, arg2
    arg2 = arg1
  END SUBROUTINE assignfn

END MODULE mymodule

PROGRAM driver
  USE mymodule
  IMPLICIT NONE

  CALL assignfn(1234,5678)
END PROGRAM driver


program scatter

implicit none
include 'mpif.h'

! Defining the variables and parameters

      integer :: rank, size, ierr
      integer, parameter :: length = 4
      integer, parameter :: iroot = 0
      integer, dimension(length) :: b
      integer :: sendcount, recvcount
      integer :: recv_buff, i

      call MPI_INIT(ierr)

      call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)

      if (size.lt.length) then
                print *, "Decrease the length of the scattering array !"
      end if

      if(rank.eq.iroot) then
              do i = 1, length
                        b(i) = i
              end do
      end if

      sendcount = 1
      recvcount = sendcount

      call MPI_SCATTER(b, sendcount, MPI_INTEGER, &
                       recv_buff, recvcount, MPI_INTEGER, &
                       iroot, MPI_COMM_WORLD, ierr)

      print *, "P(", rank, "): recv buffer :", recv_buff

      call MPI_FINALIZE(ierr)

end program


module special

use utils

interface func
    module procedure ifunc, rfunc
end interface

contains

integer function ifunc(x)

    integer, intent(in) :: x
    ifunc = x * 42

end function ifunc

real(rk) function rfunc(x)

    real(rk), intent(in) :: x
    rfunc = x / 42.0_rk

end function rfunc

end module special


program ex26

    use utils
    use iso_fortran_env

    implicit none

    real(rk) :: a(5)
    integer :: i

    read(*,*) a(1), a(2), a(3), a(4), a(5)
    read(input_unit, *) (a(i), i=1,5)
    write(*,*) (a(i), i=1,5)
    write(output_unit, *) (a(i), i=1,5)

    call printVector(a, 'a')

end program ex26


! RUN: %S/test_errors.sh %s %t %flang -fopenmp

! OpenMP Version 4.5
! 2.8.1 simd Construct
! Semantic error for correct test case

program omp_simd
  integer i, j, k
  integer, allocatable :: a(:)

  allocate(a(10))

  !$omp simd aligned(a)
  do i = 1, 10
    a(i) = i
  end do
  !$omp end simd

  print *, a

end program omp_simd


PROGRAM bounds
IMPLICIT NONE
  INTEGER :: i
  REAL, DIMENSION(5) :: a = 0

  CALL sub1(a, 5, 6)

  DO i = 1, 6
    WRITE(*, 100) i, a(i)
    100 FORMAT ('A(',I1, ') = ', F6.2)
  END DO

END PROGRAM bounds

SUBROUTINE sub1(a, ndim, n)
IMPLICIT NONE
  INTEGER, INTENT(IN) :: ndim
  REAL, INTENT(OUT), DIMENSION(ndim) :: a
  INTEGER, INTENT(IN) :: n
  INTEGER :: i

  DO i = 1, n
    a(i) = i
  END DO

END SUBROUTINE sub1