! RUN: %S/test_errors.sh %s %t %f18 -fopenacc

! Data-Mapping Attribute Clauses
! 2.15.14 default Clause

subroutine default_none()
  integer a(3)

  A = 1
  B = 2
  !$acc parallel default(none) private(c)
  !ERROR: The DEFAULT(NONE) clause requires that 'a' must be listed in a data-mapping clause
  A(1:2) = 3
  !ERROR: The DEFAULT(NONE) clause requires that 'b' must be listed in a data-mapping clause
  B = 4
  C = 5
  !$acc end parallel
end subroutine default_none

program mm
  call default_none()
end


#
# test logical operators
#

print("Testing logical operators...")
errors = 0

try assert true and true rescue errors += 1
try assert true and false rescue nil else errors += 1
try assert false and true rescue nil else errors += 1
try assert false and false rescue nil else errors += 1

try assert true or true rescue errors += 1
try assert true or false rescue errors += 1
try assert false or true rescue errors += 1
try assert false or false rescue nil else errors += 1

print(if errors "Some tests failed ({errors}) errors\n" else "passed!\n")


module example_mod
  public :: int_sum
contains
  function int_sum(i,j) result(k)
    integer :: i,j,k
    k = i + j
  end function int_sum
end module example_mod


module module_13
implicit none

contains

integer function f1()
    f1 = f2()
end function

integer function f2()
    f2 = 5
end function

end module module_13

program main
use module_13
implicit none
integer :: f
f = f1()
print *, f
end program main


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! Acknowledgements: These testing routines are based on
! test_nvector.c written by David Gardner and Slaven Peles @ LLNL.
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! These test functions are designed to check the fortran interface
! to an NVECTOR module implementation. It does not test every
! function. It tests the N_VMake constructor, one standard vector
! operation (N_VConst), N_VGetArrayPointer, and one fused operation.
! -----------------------------------------------------------------

module test_fnvector
  use, intrinsic :: iso_c_binding
  use fsundials_nvector_mod
  use fsundials_types_mod
  use test_utilities
  implicit none

  integer(C_INT), external :: check_ans
  logical, external        :: has_data

contains

integer(C_INT) function Test_FN_VMake(X, local_length, myid) &
    result(failure)
  implicit none

  type(N_Vector)  :: X
  integer(C_LONG) :: local_length
  integer(C_INT)  :: myid

  if (.not. has_data(X)) then
    print *, '(I4)', '>>> FAILED test -- FN_VMake, Proc ', myid
    print *, '    vector data is not associated'
    failure = 1
    return
  end if

  if (myid == 0) then
    print *, 'PASSED test -- FN_VMake'
  end if

  failure = 0
end function Test_FN_VMake

!! ----------------------------------------------------------------------
!! NOTE: This routine depends on FN_VConst to check vector data.
!! ----------------------------------------------------------------------
integer(C_INT) function Test_FN_VGetArrayPointer(W, local_length, myid) &
    result(failure)
  implicit none

  type(N_Vector)  :: W
  integer(C_LONG) :: local_length
  integer(C_INT)  :: myid

  ! check vector data
  if (.not. has_data(W)) then
    print *, '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid
    print *, '    Vector data == NULL \n\n'
    failure = 1
    return;
  end if

  call FN_VConst(NEG_HALF, W)
  failure = check_ans(NEG_HALF, W, local_length)

  if (failure > 0) then
    print *, '(I2)', '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid
    print *, '    Failed FN_VConst check \n\n'
    failure = 1
    return
  end if

  if (myid == 0) then
    print *, 'PASSED test -- FN_VConst'
    print *, 'PASSED test -- FN_VGetArrayPointer'
  end if

  failure = 0
end function Test_FN_VGetArrayPointer

integer(C_INT) function Test_FN_VLinearCombination(X, local_length, myid) &
    result(failure)

  type(N_Vector)          :: X
  integer(C_LONG)         :: local_length
  integer(C_INT)          :: myid, ierr
  type(N_Vector), pointer :: Y1, Y2, Y3
  type(c_ptr), target     :: V(3)
  type(c_ptr)             :: Vptr
  real(C_DOUBLE)          :: c(3)

  failure = 0

  ! create vectors for testing
  Y1 => FN_VClone(X)
  Y2 => FN_VClone(X)
  Y3 => FN_VClone(X)

  ! set vectors in vector array
  V = (/c_loc(Y1), c_loc(Y2), c_loc(Y3)/)
  Vptr = c_loc(V)

  ! initialize c values
  c = ZERO

  !
  ! Case 1a: V[0] = a V[0], FN_VScale
  !

  ! fill vector data
  call FN_VConst(TWO, Y1)

  ! set scaling factors
  c =  HALF

  ierr = FN_VLinearCombination(1, c, Vptr, Y1)

  ! Y1 should be vector of +1
  if (ierr == 0) then
    failure = check_ans(ONE, Y1, local_length)
  else
    failure = 1
  end if

  if (failure > 0) then
    print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 1a, Proc ', myid
  else if (myid == 0) then
    print *, 'PASSED test -- FN_VLinearCombination Case 1a'
  end if

  !
  ! Case 3a: V[0] = V[0] + b V[1] + c V[2]
  !

  call FN_VConst(TWO, Y1)
  call FN_VConst(NEG_TWO, Y2)
  call FN_VConst(NEG_ONE, Y3)

  c(1) = ONE
  c(2) = HALF
  c(3) = NEG_TWO

  ierr = FN_VLinearCombination(3, c, Vptr, Y1)

  ! Y1 should be vector of +3
  if (ierr == 0) then
    failure = check_ans(TWO+ONE, Y1, local_length)
  else
    failure = 1
  end if

  if (failure > 0) then
    print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 3a, Proc ', myid
  else if (myid == 0) then
    print *, 'PASSED test -- FN_VLinearCombination Case 3a'
  end if

  ! Free vectors
  call FN_VDestroy(Y1);
  call FN_VDestroy(Y2);
  call FN_VDestroy(Y3);

end function Test_FN_VLinearCombination

end module


!
! This file is part of LIBPFASST.
!
!>  Module for reading parameters for the problem  y'=lam1*y+lam2*y
module probin
  use pfasst
  use pf_mod_mpi

  !  The namlist for local variables
  integer, save :: num_grid_points, nspace, ntime, space_dim, max_space_v_cycles
  integer, save :: solver_type, mgrit_n_init, mgrit_refine_factor, nsteps_rk(PF_MAXLEVS)
  logical, save :: FAS_flag, FCF_flag
  real(pfdp), save :: init_cond
  real(pfdp), save :: dt     ! time step
  real(pfdp), save :: T0, Tfin   ! Final time
  integer, save :: nsteps    ! number of time steps
  integer, save :: imex_stat
  integer, save :: ark_stat
  integer, save :: rk_order
  character(len=128), save :: pfasst_nml  ! file for reading pfasst parameters

  namelist /params/ space_dim, num_grid_points, init_cond, nspace, ntime, dt, T0, Tfin, nsteps, pfasst_nml, max_space_v_cycles
  namelist /params/ mgrit_n_init, mgrit_refine_factor, imex_stat, ark_stat, solver_type, nsteps_rk, FAS_flag, rk_order, FCF_flag

contains

  subroutine probin_init(pf_fname)
    character(len=*), intent(inout) :: pf_fname

    !  Some local variables for reading
    character(len=128) :: arg  !  command line argument
    character(len=128)    :: probin_fname   !<  file name for input parameters
    character(len=256) :: istring           ! stores command line argument
    character(len=1024) :: message          ! use for I/O error messages
    integer :: ios,iostat
    integer :: i   !  loop variable
    integer :: un  !  file read unit
    integer :: nproc, rank, error

    call mpi_comm_size(MPI_COMM_WORLD, nproc, error)
    call mpi_comm_rank(MPI_COMM_WORLD, rank,  error)

    !> Set the name of the input file
    probin_fname = "probin.nml" ! default file name - can be overwritten on the command line
    if (command_argument_count() >= 1) &
         call get_command_argument(1, value=probin_fname)

    !> set defaults
    nsteps  = -1
    nsteps_rk = -1

    nspace = 1
    ntime = nproc
    num_grid_points = 3
    init_cond = 50.0
    space_dim = 2
    max_space_v_cycles = 100

    dt      = 0.01_pfdp
    T0      = 0.0_pfdp
    Tfin    = 1.0_pfdp
    pfasst_nml=probin_fname

    mgrit_n_init = 10
    mgrit_refine_factor = 2
    imex_stat = 2
    ark_stat = 2
    rk_order = 1

    FAS_flag = .false.
    FCF_flag = .true.
    solver_type = 0

    !>  Read in stuff from input file
    un = 9
    write(*,*) 'opening file ',TRIM(probin_fname), '  for input'
    open(unit=un, file = probin_fname, status = 'old', action = 'read')
    read(unit=un, nml = params)
    close(unit=un)

    !>  Read the command line
    i = 0
    do
       call get_command_argument(i, arg)
       if (LEN_TRIM(arg) == 0) EXIT
       if (i > 0) then
          istring="&PARAMS "//TRIM(arg)//" /"
          READ(istring,nml=params,iostat=ios,iomsg=message) ! internal read of NAMELIST
       end if
       i = i+1
    end do

    !  Reset dt if Tfin is set
    if (Tfin .gt. 0.0) dt = Tfin/dble(nsteps)

    !  Return the name of the file from which to read PFASST parameters
    pf_fname=pfasst_nml
  end subroutine probin_init

  !>  Subroutine to output run parameters
  subroutine print_loc_options(pf, un_opt)
    type(pf_pfasst_t), intent(inout)           :: pf
    integer,           intent(in   ), optional :: un_opt
    integer :: un = 6

    integer :: nproc, rank, error

    call mpi_comm_size(MPI_COMM_WORLD, nproc, error)
    call mpi_comm_rank(MPI_COMM_WORLD, rank,  error)

    if (pf%rank /= 0) return
    if (present(un_opt)) un = un_opt

    !>  Output the PFASST options with the LibPFASST routine
    call pf_print_options(pf,un_opt=un)

    if (rank == 0) then
       !  Print out the local parameters
       write(un,*) '=================================================='
       write(un,*) ' '
       write(un,*) 'Local Variables'
       write(un,*) '----------------'
       write(un,*) 'nsteps: ', nsteps, '! Number of steps'
       write(un,*) 'Dt:     ', Dt, '! Time step size'
       write(un,*) 'Tfin:   ', Tfin,   '! Final time of run'
       write(un,*) 'num spatial grid points (on each side of square domain) per processor:   ', num_grid_points
       write(un,*) 'num spatial procs per temporal proc:   ',   nspace
       write(un,*) 'num temporal procs:   ',   ntime
       write(un,*) 'Constant initial condition:   ', init_cond
       write(un,*) 'Number of spacial dimensions:   ', space_dim
       write(un,*) 'Number of Hypre V-cycles:   ', max_space_v_cycles

       write(un,*) 'PFASST parameters read from input file ', pfasst_nml
       write(un,*) '=================================================='
    end if
  end subroutine print_loc_options

end module probin


module rkf45_kinds

    !> REAL32: Single Precision
    !> REAL64: Double Precision

    use, intrinsic :: iso_fortran_env, only: real32, real64
    implicit none
    private

    public :: rk

    !> REAL Precision
    integer, parameter :: rk = real32

end module rkf45_kinds


! { dg-do run }
! { dg-options "-O0" }
! This tests the patch for PR24311 in which the PRINT statement would
! ICE on trying to print a MERGE statement with character constants
! for the first two arguments.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
  integer, dimension(6) :: i = (/1,0,0,1,1,0/)
  print '(6a1)', Merge ("a", "b", i  == 1) ! { dg-output "abbaab" }
  end


module kind_parameters
    ! Kind paramters for single/ double precision
    ! Pratanu Roy, April 2014

    integer, parameter :: dp = KIND(1.0d0)
    integer, parameter :: sp = KIND(1.0e0)

end module kind_parameters


program main_all
    use :: functions_mod
    implicit none
    real :: x = 13.0

    print *, f1(x)

end program main_all


! This module implements a basic functionality for a singly-linked list that is
! managed with the head pointers to emulate a LIFO stack.  The interface methods
! are given as module procedures:
! - stack_init (nullify both pointers);
! - stack_is_empty (test for null head);
! - stack_push (append to the head;
! - stack_pop (remove from the head);
! - stack_display (walk and print values).
module stack_mod
    implicit none

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

contains

    subroutine stack_init(head)
        type(a_sll_node), pointer, intent(inout) :: head
        head => null()
        return
    end subroutine stack_init

    logical function stack_is_empty(head)
        type(a_sll_node), pointer, intent(in) :: head
        !
        stack_is_empty = .not.associated(head)
        return
    end function stack_is_empty

    ! Prepend (push) a new node the list's head in the LIFO stack model.
    ! Pushing to an empty or non-empty list is the same.  There are three steps:
    !  1) create a new node taget in the heap using an extra pointer (temp);
    !  2) initialize the new node: add the value and set the next pointer to the
    !     list's head;
    !  3) point the list's head to this node to make it first in the list.
    subroutine stack_push(head, val)
        type(a_sll_node), pointer, intent(inout) :: head
        integer,                   intent(in)    :: val
        !
        type(a_sll_node), pointer :: temp

        allocate(temp)
        temp%val = val
        temp%next => head
        head => temp
        return
    end subroutine stack_push

    ! Pop the first value from the list's head and remove the corresponding
    ! node.  Do it in three steps (deletion method 2):
    !  1) the temporary pointer remembers the head;
    !  2) point the head to the next node;
    !  3) deallocate the temporary pointer (the 1st node).
    integer function stack_pop(head)
        type(a_sll_node), pointer, intent(inout) :: head
        !
        type(a_sll_node), pointer :: temp

        temp => head
        head => head%next
        stack_pop = temp%val ! return value
        deallocate(temp)
        return
    end function stack_pop

    ! Walk through the list and print the stored values.
    ! 1) point the temp pointer to the head;
    ! 2) advance the temp pointer to temp%next until temp is null();
    ! 3) while moving, print the value of the current node.
    subroutine stack_display(head)
        type(a_sll_node), pointer, intent(in) :: head
        !
        type(a_sll_node), pointer :: temp

        temp => head
        do while (.not.stack_is_empty(temp))
            write(*, "(a, i0, a)", advance="no") "(", temp%val, ")->"
            temp => temp%next
        end do
        print "(a)", "null()"
        return
    end subroutine stack_display

    ! Destroy the stack (delete all elements) by popping every first node from
    ! the head util the list is empty.
    subroutine stack_destroy(head)
        type(a_sll_node), pointer, intent(inout) :: head
        !
        integer :: val

        do
            if (stack_is_empty(head)) exit
            val = stack_pop(head)
        end do
        return
    end subroutine stack_destroy

end module stack_mod


program arr1
  integer :: i ,j
outer:  do i =1,10
    do j =1,10
     if (j == 6) exit outer
    end do
  end do outer
  print *,"inner indvar usage", j

end program arr1


program main
  use iso_fortran_env, only : event_type
  implicit none
  type(event_type), allocatable :: greeting_ready(:)[:]
  type(event_type) ok_to_overwrite[*]
  integer, parameter :: greeter=1, max_greeting_length=64
  character(len=max_greeting_length) greeting[*]

  ! integer, parameter :: n = num_images() ! invalid

  associate(me=>this_image(), n=>num_images()) ! n is immutable within this block

    allocate(greeting_ready(2:n)[*])

    if (me/=greeter) then
      write(greeting, *) "Hello from image ",me," of ", n
      event post(greeting_ready(me)[greeter])
    else
      print *,"Hello from image ",me," of ", n
      block
        logical greeting_not_printed(2:n)
        integer count, image

        greeting_not_printed = .true.

        spin: &
        do while(any(greeting_not_printed))
          do image=2,n
            call event_query(greeting_ready(image), count)
            if (greeting_not_printed(image) .and. count>0) then
              event wait(greeting_ready(image))
              print *,greeting[image]
              greeting_not_printed(image) = .false.
            end if
          end do
        end do spin

      end block
    end if

  end associate

end program main


program memoria
  implicit none
  real, dimension (:), allocatable :: v
  integer :: i,n
  print*, "inserte un valor entero"
  read*, n
  allocate(v(n))
  do i=1, n
    if(i==8 .or. i==20)cycle
    v(i)=i
  end do

  open(unit=10, file="prueba9.txt", status="replace", action="write")
  do i=1,n
    write(10,*), v(i)
  end do
  close(10)
  deallocate (v)
end program


! { dg-do compile }
!
! PR fortran/34655
!
! Check for F2003's 5.5.2.5 Restrictions on common and equivalence
! Test case contributed by Joost VandeVondele.
!
implicit none
type data_type
 sequence
 integer :: I = 7
end type data_type

type data_type2
 sequence
 integer :: I
end type data_type2

type(data_type) :: dd, ff
type(data_type2) :: gg
integer :: j, k, m
EQUIVALENCE(dd,J) ! { dg-error "with default initialization cannot be in EQUIVALENCE with a variable in COMMON" }
EQUIVALENCE(ff,k)
EQUIVALENCE(gg,m)
COMMON /COM/ j
COMMON /COM/ m
END


PROGRAM variables
  IMPLICIT NONE
  CHARACTER(LEN=20) :: mystring
  INTEGER, PARAMETER :: myint = 10
  REAL :: myfloat1, myfloat2
  COMPLEX :: mycomplex
END PROGRAM variables


      module testmod
      implicit none
      integer, parameter :: i = 20

      end module testmod


MODULE character_subs
CONTAINS
  FUNCTION abc(n)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: n
  CHARACTER(len=n) :: abc
  character(len=26) :: alphabet = 'abcdefghijklmnopqrstuvwxyz'
  abc = alphabet(1:n)
  END FUNCTION abc
END MODULE character_subs

PROGRAM test_abc
USE character_subs
IMPLICIT NONE
INTEGER :: n
WRITE(*, *) "Enter string length: "
READ(*, *) n
WRITE(*, *) 'The string is: ', abc(n)
END PROGRAM test_abc


! { dg-do compile }
! { dg-options "-std=f95" }
! PR35754 -std=f95: Reject "1P2E12.4" w/o a comma after the "P"
! PR
! Test case provided by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
      character(40) :: fmt_string
      write(*, '(1P2E12.4)') 1.0 ! { dg-error "Comma required" }
      write(*, '(1PT12,F12.4)') 1.0 ! { dg-error "Comma required" }
      write(*, '(1PE12.4)') 1.0 ! This is OK by the standard 10.1.1
      write (*,'(1PD24.15,F4.2,0P)') 1.0d0 ! This OK too.
      end


program format_example

  implicit none

  ! Declare a number to print:
  real :: x = 1234.56789
  ! Create an array of format specifiers to test on our number:
  integer, parameter :: nCode = 5
  character(len=6), dimension(nCode) :: code = &
       (/' f10.4',' e10.4', 'ES10.4', ' G10.4', ' G10.3'/)

  ! Other variables we need:
  character(len=13) :: FormatNow
  integer :: i

  ! Loop over each format specifier:
  do i=1,nCode
     ! Build a format code to use:
     write(FormatNow,"('(2a,',a,',a)')")code(i)
     ! Apply format code to print number:
     write(*,FormatNow) code(i),"|", x,"|"
  end do
end program format_example


program i
  integer ::a
  a = 3
  print *,a
end program i


PROGRAM shw
  IMPLICIT NONE
  REAL (KIND =8) :: r         ! Input number
  REAL (KIND=8)  :: s         ! Result

  !  Get a number from user
  WRITE(*,*) 'Input a number: '
  READ(*,*) r
  !  Calculate the sine of the number
  s = SIN(r)
  !  Write result to screen
  WRITE(*,*) 'Hello World! SINE of ', r, ' =', s

END PROGRAM shw


program alloctest
  integer, allocatable :: a(:)
  integer, allocatable :: b(:)
  integer :: i
  integer :: st

  allocate(a(6), b(8), stat = st)
  print *, "Allocation status ", st

  do i = 1, 6
    a(i) = i
  end do

  do i = 1, 10
    b(i) = i
  end do

  print *, a
  print *, b
  deallocate(a, b, stat = st)
  print *, "De Allocation status ", st
end program alloctest


MODULE types
!
!  Purpose:
!    To define the derived data type used for the customer
!    database.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare type personal_info
TYPE :: personal_info
   CHARACTER(len=12) :: first        ! First name
   CHARACTER         :: mi           ! Middle Initial
   CHARACTER(len=12) :: last         ! Last name
   CHARACTER(len=26) :: street       ! Street Address
   CHARACTER(len=12) :: city         ! City
   CHARACTER(len=2)  :: state        ! State
   INTEGER           :: zip          ! Zip code
END TYPE personal_info

END MODULE types

PROGRAM customer_database
!
!  Purpose:
!    To read in a character input data set, sort it into ascending
!    order using the selection sort algorithm, and to write the
!    sorted data to the standard output device.  This program calls
!    subroutine "sort_database" to do the actual sorting.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
!
USE types                      ! Declare the module types
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: MAX_SIZE = 100  ! Max addresses in database

! Data dictionary: declare external functions
LOGICAL, EXTERNAL :: lt_last     ! Comparison fn for last names
LOGICAL, EXTERNAL :: lt_city     ! Comparison fn for cities
LOGICAL, EXTERNAL :: lt_zip      ! Comparison fn for zip codes

! Data dictionary: declare variable types & definitions
TYPE(personal_info), DIMENSION(MAX_SIZE) :: customers
                                 ! Data array to sort
INTEGER :: choice                ! Choice of how to sort database
LOGICAL :: exceed = .FALSE.      ! Logical indicating that array
                                 !   limits are exceeded.
CHARACTER(len=20) :: filename    ! Input data file name
INTEGER :: i                     ! Loop index
INTEGER :: nvals = 0             ! Number of data values to sort
INTEGER :: status                ! I/O status: 0 for success
TYPE(personal_info) :: temp      ! Temporary variable for reading

! Get the name of the file containing the input data.
WRITE (*,*) 'Enter the file name with customer database: '
READ (*,'(A20)') filename

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=9, FILE=filename, STATUS='OLD', IOSTAT=status )

! Was the OPEN successful?
fileopen: IF ( status == 0 ) THEN       ! Open successful

   ! The file was opened successfully, so read the customer
   ! database from it.
   DO
      READ (9, 1010, IOSTAT=status) temp   ! Get value
      1010 FORMAT (A12,1X,A1,1X,A12,1X,A26,1X,A12,1X,A2,1X,I5)
      IF ( status /= 0 ) EXIT              ! Exit on end of data
      nvals = nvals + 1                    ! Bump count
      size: IF ( nvals <= MAX_SIZE ) THEN  ! Too many values?
         customers(nvals) = temp           ! No: Save value in array
      ELSE
         exceed = .TRUE.                   ! Yes: Array overflow
      END IF size
   END DO

   ! Was the array size exceeded?  If so, tell user and quit.
   toobig: IF ( exceed ) THEN
      WRITE (*,1020) nvals, MAX_SIZE
      1020 FORMAT (' Maximum array size exceeded: ', I6, ' > ', I6 )
   ELSE

      ! Limit not exceeded: find out how to sort data.
      WRITE (*,1030)
      1030 FORMAT (1X,'Enter way to sort database:',/, &
                   1X,'  1 -- By last name ',/, &
                   1X,'  2 -- By city ',/, &
                   1X,'  3 -- By zip code ')
      READ (*,*) choice

      ! Sort database
      SELECT CASE ( choice)
      CASE (1)
         CALL sort_database (customers, nvals, lt_last )
      CASE (2)
         CALL sort_database (customers, nvals, lt_city )
      CASE (3)
         CALL sort_database (customers, nvals, lt_zip )
      CASE DEFAULT
         WRITE (*,*) 'Invalid choice entered!'
      END SELECT

      ! Now write out the sorted data.
      WRITE (*,'(A)') ' The sorted database values are: '
      WRITE (*,1040) ( customers(i), i = 1, nvals )
      1040 FORMAT (1X,A12,1X,A1,1X,A12,1X,A26,1X,A12,1X,A2,1X,I5)

   END IF toobig

ELSE fileopen

   ! Status /= 0, so an open error occurred.
   WRITE (*,'(A,I6)') ' File open error: IOSTAT = ', status

END IF fileopen

END PROGRAM customer_database

SUBROUTINE sort_database (array, n, lt_fun )
!
!  Purpose:
!    To sort array "array" into ascending order using a selection
!    sort, where "array" is an array of the derived data type
!    "personal_info".  The sort is based on the external
!    comparison function "lt_fun", which will differ depending on
!    which component of the derived type array is used for
!    comparison.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/04/06    S. J. Chapman        Original code
!
USE types                      ! Declare the module types
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n                  ! Number of values
TYPE(personal_info), DIMENSION(n), INTENT(INOUT) :: array
                                          ! Array to be sorted
LOGICAL, EXTERNAL :: lt_fun               ! Comparison function

! Data dictionary: declare local variable types & definitions
INTEGER :: i                   ! Loop index
INTEGER :: iptr                ! Pointer to smallest value
INTEGER :: j                   ! Loop index
TYPE(personal_info) :: temp    ! Temp variable for swaps

! Sort the array
outer: DO i = 1, n-1

   ! Find the minimum value in array(i) through array(n)
   iptr = i
   inner: DO j = i+1, n
      minval: IF ( lt_fun(array(J),array(iptr)) ) THEN
         iptr = j
      END IF minval
   END DO inner

   ! iptr now points to the minimum value, so swap array(iptr)
   ! with array(i) if i /= iptr.
   swap: IF ( i /= iptr ) THEN
      temp        = array(i)
      array(i)    = array(iptr)
      array(iptr) = temp
   END IF swap

END DO outer
END SUBROUTINE sort_database

LOGICAL FUNCTION lt_last (a, b)
!
!  Purpose:
!    To compare variables "a" and "b" and determine which
!    has the smaller last name (lower alphabetical order).
!
USE types                    ! Declare the module types
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
TYPE (personal_info), INTENT(IN) :: a, b

! Make comparison.
lt_last = LLT ( a%last, b%last )

END FUNCTION lt_last

LOGICAL FUNCTION lt_city (a, b)
!
!  Purpose:
!    To compare variables "a" and "b" and determine which
!    has the smaller city (lower alphabetical order).
!
USE types                    ! Declare the module types
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
TYPE (personal_info), INTENT(IN) :: a, b

! Make comparison.
lt_city = LLT ( a%city, b%city )

END FUNCTION lt_city

LOGICAL FUNCTION lt_zip (a, b)
!
!  Purpose:
!    To compare variables "a" and "b" and determine which
!    has the smaller zip code (lower numerical value).
!
USE types                    ! Declare the module types
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
TYPE (personal_info), INTENT(IN) :: a, b

! Make comparison.
lt_zip = a%zip < b%zip

END FUNCTION lt_zip


      program ifthenelse05

      read *,i

      if(i.eq.0) then
         print *, i
         go to 1

 1    elseif(i.eq.1) then
         print *, i+1
      else
         print *,i-1
      endif

      end


PROGRAM rainfall
    IMPLICIT NONE
    REAL, dimension(:), allocatable:: a
    INTEGER:: n, i

    read (*, *) n
    allocate(a(n))
    read (*, *) (a(i), i = 1, n)
    ! REAL::  sum = 0, ans = 0
    ! open(unit=10,file='input.txt')
    DO i = 1, n
        write(*, *) a(i)
    ENDDO
    ! ans = sum/12
    ! write(*, *) ans
    ! Close (10)

END


program pg10  ! A subroutine contained in a parent program
              ! can access parent variables
    implicit none
    integer :: q1, i141, i42
    i141 = 141
    i42  = 42
    q1   = 11
    call insub1(q1)
    print *, "q1: ", q1
    print *, "i42: ", i42

contains
    subroutine insub1(qin)
        implicit none
        integer, intent(inout) :: qin
        qin = qin + i141
        i42 = 1042
        return
    end subroutine insub1

end program pg10


program omp_par_do
  implicit none

  integer, parameter :: n = 100
  real, dimension(n) :: dat, result
  integer :: i

  !$OMP PARALLEL DO
  do i = 1, n
     result(i) = my_function(dat(i))
  end do
  !$OMP END PARALLEL DO

contains

  function my_function(d) result(y)
    real, intent(in) :: d
    real :: y

    ! do something complex with data to calculate y
  end function my_function

end program omp_par_do


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: dble_test
subroutine dble_test(a)
  real :: a
  ! CHECK: fir.convert {{.*}} : (f32) -> f64
  print *, dble(a)
end subroutine


! Runs a program in parallel using MPI
! (https://en.wikipedia.org/wiki/Message_Passing_Interface)
module HelloMpi
use mpi
use Constants, only: OUTPUT_LENGTH
implicit none
private
public :: hello_mpi

contains

!
! Print the ID of the process and the total number of them.
!
! Inputs:
! --------
!
! silent : if true, do not print to output (used in unit tests)
!
! Outputs:
! -------
!
! Returns: hello world string from the process
!
function hello_mpi(silent) result(result)
  logical, intent(in) :: silent
  character(len=OUTPUT_LENGTH) :: result

  integer :: ifail
  integer :: rank, size

  call mpi_init(ifail)

  call mpi_comm_rank(MPI_COMM_WORLD, rank, ifail)
  call mpi_comm_size(MPI_COMM_WORLD, size, ifail)

  ! Print the ID of the process and the total number of them
  write(result, '(a, x, i0, x, a, x, i0)') "Hello from rank", rank, "of", size
  if (.not. silent) write (0, *) trim(result)

  call mpi_finalize(ifail)
end function

end module HelloMpi


program ch0908
    ! Simple g Edit Descriptor Example
    implicit none

    integer :: i
    real :: r1 = 1.23456
    real :: r2 = 1.23456

    print 100
    print 110
    do i = 1, 10
        print 120, i, r1, r2
        r1 = r1/10.
        r2 = r2*10.
    end do

100 format (' ', '123 123456789012 123456789012')
110 format ('  i3 g12.4        g12.4')
120 format (' ', i3, ' ', g12.4, ' ', g12.4)
end program


!> @ingroup swap
!>
!> @brief
!> Swap two real values.
!>
!> @details
!> Swap two real values.
!>
!> @param x
!> The first value to be swapped.
!>
!> @param y
!> The second value to be swapped.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
elemental subroutine swap_real(x,y)
  ! Arguments
  real, intent(inout) :: x
  real, intent(inout) :: y

  ! Variables
   real :: temp

  ! Main
  temp = x
  x = y
  y = temp

end subroutine swap_real


subroutine foo(i,j)
implicit none
common /block/ blocki
save /block/
integer :: blocki=0,i,j
blocki=blocki+i
j=blocki
end subroutine

program p
integer j
call foo(2,j)
call foo(2,j)
if (j == 4) then
print *, 'OK'
else
print *,j
end if
end program


! $UWHPSC/codes/fortran/arraypassing3.f90

program arraypassing3

    implicit none
    real(kind=8) :: x,y
    integer :: i,j

    x = 1.
    y = 2.
    i = 3
    j = 4
    call setvals(x)
    print *, "x = ",x
    print *, "y = ",y
    print *, "i = ",i
    print *, "j = ",j

contains

subroutine setvals(a)
    ! subroutine that sets values in an array a of length 3.
    implicit none
    real(kind=8), intent(inout) :: a(3)
    integer i
    do i = 1,3
        a(i) = 5.
        enddo
end subroutine setvals

end program arraypassing3


PROGRAM subroutines
    IMPLICIT NONE

    ! REAL :: x, y
    ! READ *, x
    ! CALL Negative(x, y)
    ! PRINT *, y
    ! CONTAINS
    ! SUBROUTINE Negative(x, y)
    !     REAL:: x, y
    !     y = -x
    !     Return
    ! END SUBROUTINE

    REAL, allocatable:: x(:)
    REAL:: z
    INTEGER:: y = 5
    allocate(x(y))
    CALL fill(x, y, z)
    print *, x
    print *, y
    print *, z

    ! CONTAINS
    ! SUBROUTINE fill(array)
    !     REAL, DIMENSION(:) :: array
    !     array = 5
    !     array(4) = 7
    ! END SUBROUTINE

END

SUBROUTINE fill(x, y, z)
    IMPLICIT NONE
    INTEGER:: y
    REAL:: x(y)
    REAL:: z
    x = 3
    z = x(1) + x(2)

    ! REAL, DIMENSION(:), allocatable :: x
    ! allocate(x(5))
    x = 3
END SUBROUTINE


PROGRAM reduce

  USE mpi
  IMPLICIT NONE

  INTEGER, PARAMETER :: tag = 100

  INTEGER :: rank, recv
  INTEGER :: nproc, ierr

  CALL MPI_Init(ierr)

  CALL MPI_Comm_size(MPI_COMM_WORLD, nproc, ierr)
  CALL MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)

  CALL MPI_Allreduce(rank, recv, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
  PRINT *, 'On rank ', rank, ' MPI_Allreduce gives maximum rank as ', recv

  CALL MPI_Finalize(ierr)

END PROGRAM reduce


module m
implicit none
type :: date_t
   integer :: year, month, day
end type date_t
type :: daily_temperature_t
   type(date_t) :: date
   real :: high, low
end type daily_temperature_t
end module m
!
program derived_type_composition
use m, only: daily_temperature_t, date_t
implicit none
type(daily_temperature_t) :: x
character (len=*), parameter :: fmt = "(*(1x,g0))"
! use default constructors of daily_temperature_t and date_t
x = daily_temperature_t(date_t(2022,2,12),high=30.0,low=10.0)
print fmt,x ! 2022 2 12 30.0000000 10.0000000
print fmt,x%date%year ! 2022
end program derived_type_composition


program segmentation_fault
implicit none
integer :: i

real,dimension(4) :: one_array
write(*,*) "one_array elements: From",loc(one_array),"to",loc(one_array)+4*9
write(*,*) "i location relative to one_array(0):", loc(i)-loc(one_array)
write(*,*)

write(*,*) '                              index          memory address'
do i = 1,10
    write(*,*) 'Writing "10" for index',i, "  at",loc(one_array(i))-loc(one_array)
    one_array(i)=10
enddo
end program


PROGRAM simple_if

  IMPLICIT NONE
  INTEGER :: test, candidate

  test = 2
  candidate = 4

  IF (test /= candidate) PRINT *, 'Test ', test, &
      ' not equal to candidate ', candidate

END PROGRAM simple_if


! { dg-do compile }
!
! PR 44718: Procedure-pointer name is wrongly regarded as "external procedure"
!
! Contributed by John McFarland <john.mcfarland@swri.org>

MODULE m

 IMPLICIT NONE

CONTAINS

 FUNCTION func(x) RESULT(y)
   INTEGER :: x,y
   y = x *2
 END FUNCTION func

 SUBROUTINE sub(x)
   INTEGER :: x
   PRINT*, x
 END SUBROUTINE sub

 SUBROUTINE use_func()
   PROCEDURE(func), POINTER :: f
   INTEGER :: y
   f => func
   y = f(2)
 END SUBROUTINE use_func

 SUBROUTINE use_sub()
   PROCEDURE(sub), POINTER :: f
   f => sub
   CALL f(2)
 END SUBROUTINE use_sub

END MODULE m


use IOClass
implicit none

real(real64),allocatable :: a(:,:)
type(IO_) :: f

a = f%import("test.csv",num_column=2)

a(1,1) = 2.0d0
print *, a(:,1)

call f%export("test2.csv",a)

end


program loop_bound
implicit none
integer :: i,n
n = 3
do i=1,n
   n = n - 1
   ! n has changed, but # of iterations is fixed at 3
   print*,"i,n=",i,n
end do
print*,"i,n=",i,n
print*
! The above is confusing and could be written as follows:
i = 1
n = 3
do
   n = n - 1
   print*,"i,n=",i,n
   i = i + 1
   if (i > 3) exit
end do
print*,"i,n=",i,n
end program loop_bound
! output:
!  i,n=           1           2
!  i,n=           2           1
!  i,n=           3           0
!  i,n=           4           0
!
!  i,n=           1           2
!  i,n=           2           1
!  i,n=           3           0
!  i,n=           4           0


      program main
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c             Add Coordinates to a GSLIB Gridded File
c             ***************************************
c
c Takes a 3-D realization that is stored in the order implicit to GSLIB
c grid files and adds coordinates (for transfer to other programs, error
c checking, and so on)
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter (MAXLEN=132,MAXFIL=512,VERSION=2.907)
      character str*512,datafl*512,outfl*512,fmt*36,label*20
      logical   testfl
      data      lin/1/,lout/2/
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' ADDCOORD Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      do i=1,512
            str(i:i) = ' '
      end do
      call getarg(1,str)
      if(str(1:1).eq.' ')then
            write(*,*) 'Which parameter file do you want to use?'
            read (*,'(a)') str
      end if
      if(str(1:1).eq.' ') str(1:20) = 'addcoord.par        '
      inquire(file=str,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'addcoord.par        ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str,status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a4)',end=98) str(1:4)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      read(lin,'(a512)',err=98) datafl
      call chknam(datafl,MAXFIL)
      write(*,*) 'Data File = ',datafl(1:40)

      read(lin,'(a512)',err=98) outfl
      call chknam(outfl,MAXFIL)
      write(*,*) 'Output File = ',outfl(1:40)

      read(lin,*,err=98) isim
      write(*,*) 'Realization number = ',isim

      read(lin,*,err=98) nx,xmn,xsiz
      write(*,*) 'X grid size = ',nx,xmn,xsiz

      read(lin,*,err=98) ny,ymn,ysiz
      write(*,*) 'Y grid size = ',ny,ymn,ysiz

      read(lin,*,err=98) nz,zmn,zsiz
      write(*,*) 'Z grid size = ',nz,zmn,zsiz

      write(*,*)
      close(lin)
c
c Format?
c
      ix = 7
      xbig = max(abs(xmn),abs(xmn+real(nx-1)*xsiz))
      if(xbig.gt.1) ix = 6
      if(xbig.gt.10) ix = 5
      if(xbig.gt.100) ix = 4
      if(xbig.gt.1000) ix = 3
      if(xbig.gt.10000) ix = 2
      if(xbig.gt.100000) ix = 1
      if(xbig.gt.1000000) ix = 0
      iy = 7
      ybig = max(abs(ymn),abs(ymn+real(ny-1)*ysiz))
      if(ybig.gt.1) iy = 6
      if(ybig.gt.10) iy = 5
      if(ybig.gt.100) iy = 4
      if(ybig.gt.1000) iy = 3
      if(ybig.gt.10000) iy = 2
      if(ybig.gt.100000) iy = 1
      if(ybig.gt.1000000) iy = 0
      iz = 7
      zbig = max(abs(zmn),abs(zmn+real(nz-1)*zsiz))
      if(zbig.gt.1) iz = 6
      if(zbig.gt.10) iz = 5
      if(zbig.gt.100) iz = 4
      if(zbig.gt.1000) iz = 3
      if(zbig.gt.10000) iz = 2
      if(zbig.gt.100000) iz = 1
      if(zbig.gt.1000000) iz = 0
      write(fmt,101) ix,iy,iz
 101  format('(f10.',i1,',1x,f10.',i1,',1x,f10.',i1,',1x,a)')
      write(*,*) 'Format: ',fmt
c
c Read in the data (if the file exists):
c
      inquire(file=datafl,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the data file does not exist,'
            write(*,*) '        check for the file and try again  '
            stop
      endif
      open(lout,file=outfl,status='UNKNOWN')
      open(lin,file=datafl,status='OLD')
      read(lin,'(a)',err=99) str
      read(lin,*,err=99)     nvari
      write(lout,200)
 200  format('ADDCOORD Output')
      write(lout,201) nvari+3,nx,ny,nz
 201  format(4(1x,i4))
      write(lout,202)
 202  format('X',/,'Y',/,'Z')
      do i=1,nvari
            read(lin,'(a20)',err=99) label
            write(lout,'(a20)') label
      end do
c
c Get input/output files ready:
c
c
c Get to the right realization:
c
      do i=1,isim-1
            do iz=1,nz
                  do iy=1,ny
                        do ix=1,nx
                              read(lin,*)
                        end do
                  end do
            end do
      end do
c
c Loop over grid
c
      do iz=1,nz
            zz = zmn + real(iz-1)*zsiz
            do iy=1,ny
                  yy = ymn + real(iy-1)*ysiz
                  do ix=1,nx
                        xx = xmn + real(ix-1)*xsiz
                        read(lin,'(a80)') str(1:80)
                        call strlen(str,80,lostr)
                        write(lout,fmt) xx,yy,zz,str(1:lostr)
                  end do
            end do
      end do
c
c Finished:
c
      close(lin)
      close(lout)
      write(*,9998) VERSION
 9998 format(/' ADDCOORD Version: ',f5.3, ' Finished'/)
      stop
 98   stop ' ERROR in parameter file'
 99   stop ' ERROR in data file'
      end

      subroutine makepar
c-----------------------------------------------------------------------
c
c                      Write a Parameter File
c                      **********************
c
c
c
c-----------------------------------------------------------------------
      lun = 99
      open(lun,file='addcoord.par',status='UNKNOWN')
      write(lun,10)
 10   format('                  Parameters for ADDCOORD',/,
     +       '                  ***********************',/,/,
     +       'START OF PARAMETERS:')

      write(lun,11)
 11   format('sgsim.out                         ',
     +       '-file with data')
      write(lun,12)
 12   format('addcoord.out                      ',
     +       '-file for output')
      write(lun,13)
 13   format('1                                 ',
     +       '-realization number')
      write(lun,14)
 14   format('50  2.5     5.0                   ',
     +       '-nx,xmn,xsiz')
      write(lun,15)
 15   format('50  2.5     5.0                   ',
     +       '-ny,ymn,ysiz')
      write(lun,16)
 16   format('1   0.5     1.0                   ',
     +       '-nz,zmn,zsiz')

      close(lun)
      return
      end

      subroutine chknam(str,len)
c-----------------------------------------------------------------------
c
c                   Check for a Valid File Name
c                   ***************************
c
c This subroutine takes the character string "str" of length "len" and
c removes all leading blanks and blanks out all characters after the
c first blank found in the string (leading blanks are removed first).
c
c
c
c-----------------------------------------------------------------------
      parameter (MAXLEN=132)
      character str(MAXLEN)*1
c
c Remove leading blanks:
c
      do i=1,len-1
            if(str(i).ne.' ') then
                  if(i.eq.1) go to 1
                  do j=1,len-i+1
                        k = j + i - 1
                        str(j) = str(k)
                  end do
                  do j=len,len-i+2,-1
                        str(j) = ' '
                  end do
                  go to 1
            end if
      end do
 1    continue
c
c Find first blank and blank out the remaining characters:
c
      do i=1,len-1
            if(str(i).eq.' ') then
                  do j=i+1,len
                        str(j) = ' '
                  end do
                  go to 2
            end if
      end do
 2    continue
c
c Return with modified file name:
c
      return
      end

      subroutine strlen(str,MAXLEN,lostr)
c-----------------------------------------------------------------------
c
c      Determine the length of the string minus trailing blanks
c
c
c
c-----------------------------------------------------------------------
      character str*132
      lostr = MAXLEN
      do i=1,MAXLEN
            j = MAXLEN - i + 1
            if(str(j:j).ne.' ') return
            lostr = lostr - 1
      end do
      return
      end


module kinds_m
    use, intrinsic :: iso_fortran_env, only: int8, int16, int32, int64, real32, real64, real128

    implicit none
    private

    public :: i1, i2, i4, i8, r4, r8, r16

    integer(int32), parameter :: i1 = int8
    integer(int32), parameter :: i2 = int16
    integer(int32), parameter :: i4 = int32
    integer(int32), parameter :: i8 = int64
    integer(int32), parameter :: r4 = real32
    integer(int32), parameter :: r8 = real64
    integer(int32), parameter :: r16 = real128

end module kinds_m


program main

   integer(kind=4) :: i = 9, j
   real(kind=8) :: x = 3.14, y, z
   complex(kind=4) :: sec = (-1, 1)
   character(len=20, kind=1) :: word = "Electron"
   logical(kind=1) :: is_good, is_bad

   print *, 'Integer   : ', i
   print *, 'Real      : ', x
   print *, 'Complex   : ', sec
   print *, 'Character : ', word
   print *, 'Logical   : ', is_good

end program


PROGRAM outputdata
  IMPLICIT NONE

  REAL, DIMENSION(100) :: x, y
  INTEGER              :: i
  CHARACTER (len=200)  :: text
  CHARACTER (len=10)   :: postfix
  postfix = '.txt'
  text = 'I HOPE U CAN UNDERSTAND, THE SPACE IS VERY LIMITED, SO U NeeD TO BE MAKE GOOD USE OF IT'
  OPEN(9, file = 'secrets'//postfix, status = 'new')

  WRITE (9,*) text
  CLOSE(9)

  DO i = 1, 100
     x(i) = 0.1 * i
     y(i) = SIN(x(i))
  END DO

  !output data into a file
  OPEN(1, file = 'data1.dat',status = 'new')
  DO i = 1, 100
     WRITE (1,*) x(i), y(i)
  END DO

  CLOSE(1)

END PROGRAM outputdata


!! R560 implicit-stmt
!
! From NOTE 5.39
!
! Implicit typing is not affected by BLOCK constructs. For example, in
!
!TODO - very AMBIGUOS

     SUBROUTINE S(N)
       !...
       IF (N>0) THEN
         BLOCK
           NSQP = CEILING(SQRT(DBLE(N)))
         END BLOCK
       END IF
!...
       IF (N>0) THEN
         BLOCK
           PRINT *,NSQP
         END BLOCK
       END IF
     END SUBROUTINE
!
! even if the only two appearances of NSQP are within the BLOCK constructs,
! the scope of NSQP is the whole subroutine S.


PROGRAM bad
IMPLICIT NONE
INTEGER :: i
INTEGER, DIMENSION(3) :: subs = (/ 1, 8, 11 /)
INTEGER, DIMENSION(16), TARGET :: info = (/ (i, i=1,16) /)
INTEGER, DIMENSION(:), POINTER :: ptr1
ptr1 => info(subs)
WRITE (*,'(A,16I3)') ' ptr1 = ', ptr1
END PROGRAM bad


! adapted from "I’ve Come Here For An Argument, Side 2"
! https://stevelionel.com/drfortran/
subroutine sub(i)
integer :: i
! gfortran gives compile-time error for program if i is intent(in out)
print*,"entering sub, i=",i
if (i > 2) i = i + 1
print*,"exiting sub, i=",i
end subroutine sub

program main
implicit none
integer :: i = 3
call sub(i) ! valid
call sub(3) ! likely to cause "access violation" or "segmentation fault"
end program main


PROGRAM test_ptr
IMPLICIT NONE
REAL, POINTER :: p
REAL, TARGET :: t1 = 10., t2 = -17.
p => t1
WRITE(*, *) 'p, t1, t2', p, t1, t2
p => t2
WRITE(*, *) 'p, t1, t2', p, t1, t2
p = p + 4.
WRITE(*, *) 'p, t1, t2', p, t1, t2
p => t1
p = p + 4.
WRITE(*, *) 'p, t1, t2', p, t1, t2
END PROGRAM test_ptr


program hello90
	integer:: id, nthreads,omp_get_thread_num,omp_get_num_threads
	!$omp parallel private(id)
id = omp_get_thread_num()
	write (*,*) 'Hello World from thread', id
	!$omp barrier
	if ( id == 0 ) then
nthreads = omp_get_num_threads()
	write (*,*) 'There are', nthreads, 'threads'
	end if
	!$omp end parallel
	end program


! { dg-do run }
! { dg-options "-fcheck=do" }
! { dg-shouldfail "DO check" }
!
! PR fortran/34656
! Run-time check for modifing loop variables
!
program test
  implicit none
  real :: i, j, k
  j = 10.0
  k = 1.0
  do i = 1.0, j, k ! { dg-warning "must be integer" }
    call modLoopVar(i)
  end do
contains
  subroutine modLoopVar(x)
    real :: x
    x = x + 1
  end subroutine modLoopVar
end program test
! { dg-output "Fortran runtime error: Loop variable has been modified" }


module parallel
!this module contains subroutines and variables concerning the parallelisation
!of the code. This includes MPI and OpenMP.

    use MPI
    use vars
    use OMP_lib

    implicit none

    integer :: threads=2 !number of openMP threads per MPI process

    integer :: isize, irank !size and rank

    integer :: up, down !processes above and below the current one in the Cartesian topology

    integer :: comm=MPI_COMM_WORLD
    integer :: ierr

    integer, parameter :: ndims=1 !number of dimensions of parallelisation
    integer :: dims(ndims)
    logical :: periods(ndims) = (/ .false. /) !non periodic boundary conditions
    logical :: reorder = .false. !reorder the ranks for more efficiency?
    integer :: status(MPI_STATUS_SIZE)

    contains

    subroutine setup_MPI()

        implicit none

        call OMP_set_num_threads(threads) !set number of OpenMP Threads

        call MPI_Init(ierr)

        call MPI_Comm_size(MPI_COMM_WORLD, isize, ierr)

        if (modulo(ny_global,isize) .ne. 0) then
            print*, "Incompatible ny with number of processors"
            stop
        endif

        ny = ny_global/isize
        nx = nx_global

        !create Cartesian grid
        call MPI_Dims_create(isize,ndims,dims,ierr)
        if (ierr .ne. MPI_SUCCESS) then
        print*, "DIMS not created properly"
        stop
        endif

        CALL MPI_Cart_create(MPI_COMM_WORLD,ndims,dims,periods,reorder,comm,ierr)

        call MPI_Comm_rank(comm, irank, ierr)

        !find the processes above and below the current one
        call MPI_Cart_shift(comm,0,1,down,up,ierr)

        if (irank .eq. 0) then
            print*,"Running on ",isize," processes"
            print*,"With",threads," threads per process"
            print*,"Total parallel regions=",isize*threads
        endif

    end subroutine

    subroutine distribute_data()
    ! Takes the global arrays and distributes them to the processes

        call MPI_Scatter(u_global,nx*ny,MPI_REAL,u,nx*ny,MPI_REAL,0,comm,ierr)
        call MPI_Scatter(v_global,nx*ny,MPI_REAL,v,nx*ny,MPI_REAL,0,comm,ierr)

        call MPI_Scatter(psi_global,nx*ny,MPI_REAL,psi(1:nx,1:ny),nx*ny,MPI_REAL,0,comm,ierr)
        call MPI_Scatter(vort_global,nx*ny,MPI_REAL,vort(1:nx,1:ny),nx*ny,MPI_REAL,0,comm,ierr)

        call MPI_Scatter(boundary_global,nx*ny,MPI_INTEGER,boundary,nx*ny,MPI_INTEGER,0,comm,ierr)
        call MPI_Scatter(mask_global,nx*ny,MPI_INTEGER,mask,nx*ny,MPI_INTEGER,0,comm,ierr)

    end subroutine

    subroutine collate_data()
    !takes the local arrays and collects them into the global arrays

        call MPI_Gather(u,nx*ny,MPI_REAL,u_global,nx*ny,MPI_REAL,0,comm,ierr)
        call MPI_Gather(v,nx*ny,MPI_REAL,v_global,nx*ny,MPI_REAL,0,comm,ierr)

        call MPI_Gather(psi(1:nx,1:ny),nx*ny,MPI_REAL,psi_global,nx*ny,MPI_REAL,0,comm,ierr)
        call MPI_Gather(vort(1:nx,1:ny),nx*ny,MPI_REAL,vort_global,nx*ny,MPI_REAL,0,comm,ierr)

        call MPI_Gather(boundary,nx*ny,MPI_INTEGER,boundary_global,nx*ny,MPI_INTEGER,0,comm,ierr)
        call MPI_Gather(mask,nx*ny,MPI_INTEGER,mask_global,nx*ny,MPI_INTEGER,0,comm,ierr)

    end subroutine

    subroutine haloswap(array)
    ! swaps the halo values for 'array'

        implicit none
        real :: array(0:nx+1,0:ny+1)

        !send top, recieve bottom
        call MPI_Sendrecv(array(:,ny),nx+2,MPI_REAL,up,1,array(:,0),nx+2,MPI_REAL,down,1,comm,status,ierr)

        !send bottom, receive top
        call MPI_Sendrecv(array(:,1),nx+2,MPI_REAL,down,0,array(:,ny+1),nx+2,MPI_REAL,up,0,comm,status,ierr)

    end subroutine

end module


! chk_g0_format --
!     Check: does the compiler support the G0 format?
!
program chk_g0_format
    implicit none

    integer :: ierr
    integer :: x = 1
    real    :: y = 1.0

    write( *, '(a,g0)', iostat = ierr ) 'Integer value formatted via "G0":', x

    if ( ierr == 0 ) then
        write( *, '(a,g0)', iostat = ierr  ) 'Real value formatted via "G0":   ', y
    endif

    if ( ierr == 0 ) then
        write( *, '(a)' ) 'The Fortran 2008 "G0" format is supported for both integers and reals'
    else
        write( *, '(a)' ) 'The Fortran 2008 "G0" format is NOT supported'
    endif
end program chk_g0_format


!#if 0
!For the attached test file (assoc.f95 [below]) I get:
!
!/disks/utke/Apps/rose_inst/bin/testTranslator -rose:Fortran
!-rose:skipfinalCompileStep -rose:output assoc.r2f.f95 assoc.f95
!testTranslator:
!/disks/utke/Argonne/svn/CodeReps/anonymous/rose/src/frontend/OpenFortranParser_SAGE_Connection/FortranParserAc!tionROSE.C:9689:
!void c_action_if_then_stmt(Token_t*, Token_t*, Token_t*, Token_t*,
!Token_t*): Assertion
!(*(FortranParserState::getCurrentExpressionStack())).empty() == true
!failed.
!
!no output is produced.  Please let me know if you need more info or if I
!should create a bug report.
!
!jean
!#endif

program main
  real, target :: a, b
  real, pointer :: p, q
  nullify(p, q)
  if(associated(p)) then
     print *, "failed"
  end if
  a=3.
  p => a
  if(.NOT. (associated(p, a))) then
     print *, "failed"
  end if
  q => b
  nullify(q)
  if(associated(q)) then
     print *, "failed"
  else
     print *, "OK"
  end if
end program main


! RUN: %S/test_errors.sh %s %t %f18
! Check for type errors in DEALLOCATE statements

INTEGER, PARAMETER :: maxvalue=1024

Type dt
  Integer :: l = 3
End Type
Type t
  Type(dt) :: p
End Type

Type(t),Allocatable :: x

Real :: r
Integer :: s
Integer :: e
Integer :: pi
Character(256) :: ee
Procedure(Real) :: prp

Allocate(x)

!ERROR: Must have CHARACTER type, but is INTEGER(4)
Deallocate(x, stat=s, errmsg=e)

!ERROR: Must have INTEGER type, but is REAL(4)
!ERROR: Must have CHARACTER type, but is INTEGER(4)
Deallocate(x, stat=r, errmsg=e)

End Program


PROGRAM read_namelist
IMPLICIT NONE
INTEGER :: i = 1, j = 2
REAL :: a = -999., b = 0.
CHARACTER(len=12) :: string = 'Test string.'
NAMELIST / mylist / i, j, string, a, b
OPEN(7, FILE='input.nml', DELIM='APOSTROPHE')
WRITE(*, '(A)') 'Namelist file before update: '
WRITE(UNIT=*, NML=mylist)
READ(UNIT=7, NML=mylist)
WRITE(*, '(A)') 'Namelist file after update: '
WRITE(UNIT=*, NML=mylist)
END PROGRAM read_namelist


program if1
    integer :: i
    i = 5
    if (i == 5) print *, 'correct'
    if (i == 6) print *, 'incorrect'
    i = -2
40  i = i + 1
    if (i) 50, 60, 70
50  print *, 'i < 0'
    go to 40
60  print *, 'i == 0'
    go to 40
70  print *, 'i > 0'
end program


#if 0
For the attached test file when run like this:

/disks/utke/Apps/rose_inst/bin/testTranslator -rose:Fortran
-rose:skipfinalCompileStep -rose:output caseMultChoice.r2f.f95
caseMultChoice.f90
testTranslator:
/disks/utke/Argonne/svn/CodeReps/anonymous/rose/src/frontend/OpenFortranParser_SAGE_Connection/fortran_support.C:4651:
void generateAssignmentStatement(Token_t*, bool): Assertion
`(*(FortranParserState::getCurrentExpressionStack())).empty() == true'
failed.

Jean
#endif

program main
integer n
integer x
n=3
select case(n)
case(0)
x=1
case(1,3,5)
x=2
case default
x=3
end select
if( x.EQ.2) then
  print *, "OK"
else
 print *, "failed",X
end if
end program main


! RUN: bbc %s -o - | FileCheck %s

! CHECK-LABEL: compare
subroutine compare(x, c1, c2)
  character(len=4) c1, c2
  logical x
  ! CHECK: %[[RES:.*]] = fir.call @_FortranACharacterCompareScalar1
  ! CHECK: cmpi slt, %[[RES]],
  x = c1 < c2
end subroutine compare


PROGRAM test_ptr2
IMPLICIT NONE
REAL, POINTER :: p1, p2
REAL, TARGET :: t1 = 10., t2 = -17.
p1 => t1
p2 => p1
WRITE(*, '(A,4F8.2)') ' p1, p2, t1, t2 = ', p1, p2, t1, t2
p1 => p2
p2 => t1
WRITE(*, '(A,4F8.2)') ' p1, p2, t1, t2 = ', p1, p2, t1, t2
END PROGRAM test_ptr2


!!
!! Simple program to read fifi and return the array to hw1
!!
!!
MODULE io    ! Every Fortran program starts with a program statement

  use precise, only : defaultp
  ! all variable declarations come here (before CONTAINS)
  ! Except subroutines
  IMPLICIT NONE
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

CONTAINS

!! Subroutine to read the input file-----------------------------------
!! Subroutint to read the input file-----------------------------------
  SUBROUTINE input( inputfile, outputfile, title, &
                         npanels, npoints, &
                         panels, points,i,j)

!     INTEGER :: narg      ! Integer variables
     INTEGER :: i, j, n
     INTEGER :: npoints, npanels

     INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels

     CHARACTER(len=*) :: inputfile   ! file name
     CHARACTER(len=*) :: outputfile  ! file name
     CHARACTER(len=*) :: title

     LOGICAL :: flexists  ! a logical variable. I .true. or .false.

     REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: points

     ! Variable declarations go before any executable statement

     OPEN(10,file=inputfile) ! open the file

     ! Read the data-------------------------------------------------
     read(10,'(AAAAA)') title
     read(10,*) i,j
     read(10,*) npanels, npoints
     ALLOCATE( panels(4,npanels) )
     ALLOCATE( points(3,npoints) )
     read(10,*) panels
     read(10,*) points
     close(10)
     ! Finished Reading the data-------------------------------------

     ! Write the fifi data (just because I want to)------------------
     OPEN(20,file=outputfile)
     Write(20,*) ' Luke McCulloch, NAME 6160 Hw1, Outputfile '
     write(20,*)
     write(20,*) '(1.) Read the fifi data file and copy to "out.dat" '
     write(20,*) ' using the subroutine "input" via module "io"'
     write(20,*) '---------------------------------------------------------'
     write(20,*) title
     WRITE(20, FMT='(AI3A)') ' we have ', npanels, ' panels '
     WRITE(20, FMT='(AI3A)') ' we have ', npoints, ' points '
     write(20,'(4I4)') panels
     write(20,'(3D16.8)') points  ! Use Implicit do loop array formating
     write(20,*) '--------------------------------------------------------'

     close(20)

     write(*,*)  ! Blank space
     !  IF (ALLOCATED(points)) DEALLOCATE(points)
     !  IF (ALLOCATED(panels)) DEALLOCATE(panels)
     !  IF (ALLOCATED(panels)) DEALLOCATE(op)

  END SUBROUTINE input
!! End of Subroutine to read the data ----------------------------------
!! End of Subroutine to read the data ----------------------------------

!! Subroutine writes to file the data manipulated by the main program---
!! Subroutine writes to file the data manipulated by the main program---

  SUBROUTINE output( outputfile, op )

     CHARACTER(len=*) :: outputfile
     real(wp), allocatable, dimension(:,:) :: op

     Open(20,file= outputfile, Access= 'append', status='old')
     write(20,*)
     Write(20,*) ' Main program computation: the Matrix Inner Product '
     write(20,*) '---------------------------------------------------------------'
     write(20,*) ' (2.) Output data using the subroutine "output" in module "io" '
     write(20,*)
     write(20,'(3D16.8)') op
     write(20,*) '----------------------------------------------------------------'
     close(20)

  END SUBROUTINE output

!! End of Subroutine to write the data ---------------------------------
!! End of Subroutine to write the data ---------------------------------

END MODULE io


!
!(c) Matthew Kennel, Institute for Nonlinear Science (2004)
!
! Licensed under the Academic Free License version 1.1 found in file LICENSE
! with additional provisions found in that same file.
!
module kdtree2_precision_module

  implicit none
  private

  public :: kdkind

  integer, parameter :: sp = kind(0.0e0)
  integer, parameter :: dp = kind(0.0d0)

  ! You must comment out exactly one
  ! of the two lines.  If you comment
  ! out kdkind = sp then you get single precision
  ! and if you comment out kdkind = dp
  ! you get double precision.
  !
  integer, parameter :: kdkind = sp
  !integer, parameter :: kdkind = dp

end module kdtree2_precision_module


program hello90
use omp_lib
integer:: id, nthreads
  !$omp parallel private(id, nthreads)
  id = omp_get_thread_num()
  nthreads = omp_get_num_threads()
  write (*,'(A24,1X,I3,1X,A6,1X,I3,1X,A12,1X,I3,1X,A6,I3)') 'Hello, World from thread', id, &
	'out of', nthreads, 'from process', 0, 'out of', 1

  !$omp end parallel
end program


      program prog
      parameter(num=2)
      do ix=1,num
        write(6, *) ix
      enddo
      end


module aoc_utilities

    use iso_fortran_env

    implicit none

    private

    integer,parameter :: chunk_size = 100 !! for dynamic allocations

    type,public :: string
        character(len=:),allocatable :: str
        contains
        procedure,public :: to_int => string_to_int
    end type string

    public :: read_file_to_integer_array, read_file_to_integer64_array
    public :: number_of_lines_in_file
    public :: sort_ascending,sort_ascending_64
    public :: split
    public :: read_line_from_file
    public :: unique

contains

!****************************************************************
    function string_to_int(me) result(i)
    !! basic string to integer routine
    implicit none
    class(string),intent(in) :: me
    integer :: i
    read(me%str,*) i
    end function string_to_int

!****************************************************************
    function read_file_to_integer_array(filename) result(iarray)

    character(len=*),intent(in) :: filename
    integer,dimension(:),allocatable :: iarray

    integer :: i, iunit, n_lines, istat

    open(newunit=iunit, file=filename, iostat=istat)
    if (istat /= 0) error stop ' error reading file'

    n_lines = number_of_lines_in_file(iunit)
    allocate(iarray(n_lines))
    do i = 1, n_lines
        read(iunit, '(I10)') iarray(i)
    end do

    close(iunit)

    end function read_file_to_integer_array
!****************************************************************

!****************************************************************
    function read_file_to_integer64_array(filename) result(iarray)

    character(len=*),intent(in) :: filename
    integer(int64),dimension(:),allocatable :: iarray

    integer :: i, iunit, n_lines, istat

    open(newunit=iunit, file=filename, iostat=istat)
    if (istat /= 0) error stop ' error reading file'

    n_lines = number_of_lines_in_file(iunit)
    allocate(iarray(n_lines))
    do i = 1, n_lines
        read(iunit, *) iarray(i)
    end do

    close(iunit)

    end function read_file_to_integer64_array
!****************************************************************

!****************************************************************
    function number_of_lines_in_file(iunit) result(n_lines)

    implicit none

    integer,intent(in)  :: iunit   !! the file unit number
                                    !! (assumed to be open)
    integer :: n_lines   !! the number of lines in the file

    character(len=1) :: tmp
    integer :: istat

    rewind(iunit)
    n_lines = 0
    do
        read(iunit,fmt='(A1)',iostat=istat) tmp
        if (is_iostat_end(istat)) exit
        n_lines = n_lines + 1
    end do
    rewind(iunit)

    end function number_of_lines_in_file
!****************************************************************

!*******************************************************************************
!>
!  Sorts an integer array `ivec` in increasing order.
!  Uses a basic recursive quicksort
!  (with insertion sort for partitions with \(\le\) 20 elements).

    subroutine sort_ascending(ivec)

    implicit none

    integer,dimension(:),intent(inout) :: ivec

    integer,parameter :: max_size_for_insertion_sort = 20 !! max size for using insertion sort.

    call quicksort(1,size(ivec))

    contains

        recursive subroutine quicksort(ilow,ihigh)

        !! Sort the array

        implicit none

        integer,intent(in) :: ilow
        integer,intent(in) :: ihigh

        integer :: ipivot !! pivot element
        integer :: i      !! counter
        integer :: j      !! counter

        if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then

            ! do insertion sort:
            do i = ilow + 1,ihigh
                do j = i,ilow + 1,-1
                    if ( ivec(j) < ivec(j-1) ) then
                        call swap(ivec(j),ivec(j-1))
                    else
                        exit
                    end if
                end do
            end do

        elseif ( ihigh-ilow>max_size_for_insertion_sort ) then

            ! do the normal quicksort:
            call partition(ilow,ihigh,ipivot)
            call quicksort(ilow,ipivot - 1)
            call quicksort(ipivot + 1,ihigh)

        end if

        end subroutine quicksort

        subroutine partition(ilow,ihigh,ipivot)

        !! Partition the array, based on the
        !! lexical ivecing comparison.

        implicit none

        integer,intent(in)  :: ilow
        integer,intent(in)  :: ihigh
        integer,intent(out) :: ipivot

        integer :: i,ip

        call swap(ivec(ilow),ivec((ilow+ihigh)/2))
        ip = ilow
        do i = ilow + 1, ihigh
            if ( ivec(i) < ivec(ilow) ) then
                ip = ip + 1
                call swap(ivec(ip),ivec(i))
            end if
        end do
        call swap(ivec(ilow),ivec(ip))
        ipivot = ip

        end subroutine partition

    end subroutine sort_ascending
!*******************************************************************************

!*******************************************************************************
!>
    subroutine sort_ascending_64(ivec)

    implicit none

    integer(int64),dimension(:),intent(inout) :: ivec

    integer(int64),parameter :: max_size_for_insertion_sort = 20 !! max size for using insertion sort.

    call quicksort(1_int64,size(ivec,kind=int64))

    contains

        recursive subroutine quicksort(ilow,ihigh)

        !! Sort the array

        implicit none

        integer(int64),intent(in) :: ilow
        integer(int64),intent(in) :: ihigh

        integer(int64) :: ipivot !! pivot element
        integer(int64) :: i      !! counter
        integer(int64) :: j      !! counter

        if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then

            ! do insertion sort:
            do i = ilow + 1,ihigh
                do j = i,ilow + 1,-1
                    if ( ivec(j) < ivec(j-1) ) then
                        call swap64(ivec(j),ivec(j-1))
                    else
                        exit
                    end if
                end do
            end do

        elseif ( ihigh-ilow>max_size_for_insertion_sort ) then

            ! do the normal quicksort:
            call partition(ilow,ihigh,ipivot)
            call quicksort(ilow,ipivot - 1)
            call quicksort(ipivot + 1,ihigh)

        end if

        end subroutine quicksort

        subroutine partition(ilow,ihigh,ipivot)

        !! Partition the array, based on the
        !! lexical ivecing comparison.

        implicit none

        integer(int64),intent(in)  :: ilow
        integer(int64),intent(in)  :: ihigh
        integer(int64),intent(out) :: ipivot

        integer(int64) :: i,ip

        call swap64(ivec(ilow),ivec((ilow+ihigh)/2))
        ip = ilow
        do i = ilow + 1, ihigh
            if ( ivec(i) < ivec(ilow) ) then
                ip = ip + 1
                call swap64(ivec(ip),ivec(i))
            end if
        end do
        call swap64(ivec(ilow),ivec(ip))
        ipivot = ip

        end subroutine partition

    end subroutine sort_ascending_64
!*******************************************************************************
!*******************************************************************************
!>
!  Swap two integer values.

    pure elemental subroutine swap(i1,i2)

    implicit none

    integer,intent(inout) :: i1
    integer,intent(inout) :: i2

    integer :: tmp

    tmp = i1
    i1  = i2
    i2  = tmp

    end subroutine swap
!*******************************************************************************
!*******************************************************************************
!>
!  Swap two integer values.

    pure elemental subroutine swap64(i1,i2)

    implicit none

    integer(int64),intent(inout) :: i1
    integer(int64),intent(inout) :: i2

    integer(int64) :: tmp

    tmp = i1
    i1  = i2
    i2  = tmp

    end subroutine swap64
!*******************************************************************************

!*****************************************************************************************
!>
!  Split a character string using a token.
!  This routine is inspired by the Python split function.
!
!### Example
!````Fortran
!   character(len=:),allocatable :: s
!   type(string),dimension(:),allocatable :: vals
!   s = '1,2,3,4,5'
!   call split(s,',',vals)
!````

    pure subroutine split(str,token,vals)

    implicit none

    character(len=*),intent(in)  :: str
    character(len=*),intent(in)  :: token
    type(string),dimension(:),allocatable,intent(out) :: vals

    integer :: i          !! counter
    integer :: len_str    !! significant length of `str`
    integer :: len_token  !! length of the token
    integer :: n_tokens   !! number of tokens
    integer :: i1         !! index
    integer :: i2         !! index
    integer :: j          !! counters
    integer,dimension(:),allocatable :: itokens !! start indices of the
                                                !! token locations in `str`

    len_token = len(token)  ! length of the token
    n_tokens  = 0           ! initialize the token counter
    j         = 0           ! index to start looking for the next token

    ! first, count the number of times the token
    ! appears in the string, and get the token indices.
    !
    ! Examples:
    !  ',         '    --> 1
    !  '1234,67,90'    --> 5,8
    !  '123,      '    --> 4

    ! length of the string
    if (token == ' ') then
        ! in this case, we can't ignore trailing space
        len_str = len(str)
    else
        ! safe to ignore trailing space when looking for tokens
        len_str = len_trim(str)
    end if

    j = 1
    n_tokens = 0
    do
        if (j>len_str) exit      ! end of string, finished
        i = index(str(j:),token) ! index of next token in remaining string
        if (i<=0) exit           ! no more tokens found
        call expand_vector(itokens,n_tokens,i+j-1)  ! save the token location
        j = j + i + (len_token - 1)
    end do
    call expand_vector(itokens,n_tokens,finished=.true.)  ! resize the vector

    allocate(vals(n_tokens+1))

    if (n_tokens>0) then

        len_str = len(str)

        i1 = 1
        i2 = itokens(1)-1
        if (i2>=i1) then
            vals(1)%str = str(i1:i2)
        else
            vals(1)%str = ''  !the first character is a token
        end if

        !      1 2 3
        !    'a,b,c,d'

        do i=2,n_tokens
            i1 = itokens(i-1)+len_token
            i2 = itokens(i)-1
            if (i2>=i1) then
                vals(i)%str = str(i1:i2)
            else
                vals(i)%str = ''  !empty element (e.g., 'abc,,def')
            end if
        end do

        i1 = itokens(n_tokens) + len_token
        i2 = len_str
        if (itokens(n_tokens)+len_token<=len_str) then
            vals(n_tokens+1)%str = str(i1:i2)
        else
            vals(n_tokens+1)%str = ''  !the last character was a token
        end if

    else
        !no tokens present, so just return the original string:
        vals(1)%str = str
    end if

    end subroutine split
!*****************************************************************************************

!*****************************************************************************************
!>
!  Add elements to the integer vector in chunks.

    pure subroutine expand_vector(vec,n,val,finished)

    implicit none

    integer,dimension(:),allocatable,intent(inout) :: vec
    integer,intent(inout)       :: n           !! counter for last element added to `vec`.
                                               !! must be initialized to `size(vec)`
                                               !! (or 0 if not allocated) before first call
    integer,intent(in),optional :: val         !! the value to add to `vec`
    logical,intent(in),optional :: finished    !! set to true to return `vec`
                                               !! as its correct size (`n`)

    integer,dimension(:),allocatable :: tmp  !! temporary array

    if (present(val)) then
        if (allocated(vec)) then
            if (n==size(vec)) then
                ! have to add another chunk:
                allocate(tmp(size(vec)+chunk_size))
                tmp(1:size(vec)) = vec
                call move_alloc(tmp,vec)
            end if
            n = n + 1
        else
            ! the first element:
            allocate(vec(chunk_size))
            n = 1
        end if
        vec(n) = val
    end if

    if (present(finished)) then
        if (finished) then
            ! set vec to actual size (n):
            if (allocated(tmp)) deallocate(tmp)
            allocate(tmp(n))
            tmp = vec(1:n)
            call move_alloc(tmp,vec)
        end if
    end if

    end subroutine expand_vector
!*******************************************************************************

!*****************************************************************************************
!>
!  Reads the next line from a file.

    subroutine read_line_from_file(iunit,line,status_ok)

    implicit none

    integer,intent(in) :: iunit
    character(len=:),allocatable,intent(out) :: line
    logical,intent(out) :: status_ok !! true if no problems

    integer :: nread  !! character count specifier for read statement
    integer :: istat  !! file read io status flag
    character(len=chunk_size) :: buffer !! the file read buffer

    nread  = 0
    buffer = ''
    line   = ''
    status_ok = .true.

    do
        ! read in the next block of text from the line:
        read(iunit,fmt='(A)',advance='NO',size=nread,iostat=istat) buffer
        if (IS_IOSTAT_END(istat) .or. IS_IOSTAT_EOR(istat)) then
            ! add the last block of text before the end of record
            if (nread>0) line = line//buffer(1:nread)
            exit
        else if (istat==0) then ! all the characters were read
            line = line//buffer  ! add this block of text to the string
        else  ! some kind of error
            error stop 'Read error'
            status_ok = .false.
            exit
        end if
    end do

    end subroutine read_line_from_file
!*****************************************************************************************

!*****************************************************************************************
function unique(vec) result(vec_unique)
! Return only the unique values from vec.

implicit none

integer,dimension(:),intent(in) :: vec
integer,dimension(:),allocatable :: vec_unique

integer :: i,num
logical,dimension(size(vec)) :: mask

mask = .false.

do i=1,size(vec)

    !count the number of occurrences of this element:
    num = count( vec(i)==vec )

    if (num==1) then
        !there is only one, flag it:
        mask(i) = .true.
    else
        !flag this value only if it hasn't already been flagged:
        if (.not. any(vec(i)==vec .and. mask) ) mask(i) = .true.
    end if

end do

!return only flagged elements:
allocate( vec_unique(count(mask)) )
vec_unique = pack( vec, mask )

!if you also need it sorted, then do so.
! For example, with slatec routine:
!call ISORT (vec_unique, [0], size(vec_unique), 1)

end function unique
!*****************************************************************************************

end module aoc_utilities


!! R455 structure-constructor
!    is derived-type-spec ( [ component-spec-list ] )

TYPE point
  INTEGER :: i, j
END TYPE

TYPE(POINT) :: PV = POINT(1.0, 2.0)

end


module io
  ! Module containing procedures for I/O operations
  implicit none
contains

  subroutine read_input(filename)
    ! Reads a input file and assigns given variables
    use globdata
    character(len=*), intent(in) :: filename

    character(len=80) :: line, lhs, rhs
    logical :: in_ex
    integer :: n, ios, i_es

    ! Check wether input file exists
    inquire(file = filename, exist = in_ex)

    if ( in_ex .eqv. .false. ) then
      write(*,'(/3a/)') 'Input file "',filename,'" not found - terminating'
      stop
    endif

    write(*,'(a/)') 'READING INPUT FILE...'

    ! Open file for reading
    open(15, file=filename, form='formatted', status='old', action='read', &
      iostat=ios)

    ! Loop over each line in the input file
    n = 0
    do
      read (15, '(a)', iostat=ios, err=100, end=200) line
      n = n + 1

      ! Flush left
      line = adjustl(line)

      ! Ignore empty line or comments
      if ( line(1:1) .eq. ' ' .or. line(1:1) .eq. '#' ) cycle

      ! Find position of equal sign
      i_es = index(line, '=')

      ! Handle no, or multiple, equal sign(s) found
      if ( i_es .eq. 0 .or. index(line(i_es+1: len(line)), '=') .ne. 0 ) then
        write(*,'("ERROR pertaining to equal sign in input file (line ",&
          &i0.0,")")') n
        stop
      endif

      ! Store left- and right hand side (after sanitisation)
      lhs = to_lower( adjustl( line(1:i_es-1) ) )
      rhs = adjustl( line(i_es+1: len(line)) )

      ! Check if the key-value is a complete pair
      if ( lhs(1:1) .eq. ' ' .or. rhs(1:1) .eq. ' ' ) then
        write(*,'("ERROR incomplete key-value pair in input file (line ",&
          &i0.0,")")') n
        stop
      endif

      ! Assign variables
      select case (trim(lhs))
      case ("lx")
        read(rhs,*) lx
      case ("ly")
        read(rhs,*) ly
      case ("nx")
        read(rhs,*) nx
      case ("ny")
        read(rhs,*) ny
      case ("d")
        read(rhs,*) d
      case ("n_max")
        read(rhs,*) n_max
      case ("t_total")
        read(rhs,*) t_total
      case default
        write(*,'(3ai0.0a)') 'WARNING unknown variable "',trim(lhs),&
          &'" declared in input file (line ',n,') - skipping this'
      end select
    enddo

    ! Labels for read statement
    100 continue
    write(*,'("ERROR while reading the input file on line ", i0.0)') n

    200 continue
    ! Report assignments
    write(*,'(a)', advance='no') 'Read from input file: '
    write(*,'(tr2f5.3", "f5.3", "i0.0", "i0.0", "f5.3", "i0.0", "f5.3)', &
      advance='no') lx, ly, nx, ny, d, n_max, t_total
    write(*,'(a)') ' for (lx, ly, nx, ny, d, n_max, t_total)'

    ! Close file
    close(15)
  end subroutine read_input

  subroutine read_restart(filename)
    use globdata
    use alloc_mod

    character(len=*), intent(in) :: filename
    integer :: info
    integer :: n_stopped

    open(12, file=filename, form='unformatted')
    read(12) n_stopped, d, lx, ly, nx, ny, n_max, t_total
    n_start = n_stopped + 1

    ! Allocate
    call alloc_field(T, nx, ny, info)
    if ( info .ne. 0 ) then
      print *, 'ERROR allocation failed reading restart file'
      stop
    endif

    read(12) T
    close(12)
  end subroutine read_restart

  subroutine output(tstep)
    ! Writes the temperature field to disc
    use globdata

    integer, intent(in), optional :: tstep
    character(len=20) :: string
    integer :: i, j

    if ( present(tstep) ) then
      write(string, '(a,i6.6,a)') 'diff.',tstep,'.dat'
    else
      write(string, '(a)') 'diff_final.dat'
    end if

    open(10, file = string)
    do j = 1, ny
      do i = 1, nx
        write(10,'(3e12.4)') real(i-1)*dx, real(j-1)*dy, T(i,j)
      enddo
      write(10,'(a)') ! Produces a new empty line - make gnuplot lift the pen
    enddo
    close(10)
  end subroutine output

  subroutine output_restart(n)
    use globdata
    integer, intent(in) :: n
    open(12, file = 'restart.input', form='unformatted')
    write(12) n, d, lx, ly, nx, ny, n_max, t_total
    write(12) T
    close(12)
  end subroutine output_restart

  subroutine output_T
    use globdata
    character(len=20) :: filename
    write(filename, '(ai2.2a)') 'T_np',pnum,'.dat'
    open(12, file = filename, form='unformatted')
    write(12) nx, ny
    write(12) T
    close(12)
  end subroutine output_T

  subroutine read_T(m, filename)
    character(len=*), intent(in) :: filename
    real(8), dimension(:,:), intent(inout), allocatable :: m
    integer :: nx, ny

    open(12, file=filename, form='unformatted')
    read(12) nx, ny

    allocate(m(ny,nx))

    read(12) m
    close(12)
  end subroutine read_T

  subroutine diagnose(a, n, close_flag)
    use globdata, only: mkt
    implicit none

    real(mkt), dimension(:,:), intent(in) :: a
    integer, intent(in), optional :: n
    logical, intent(in), optional :: close_flag

    character(len=8) :: filename = 'diag.dat'
    logical :: first = .true.

    ! Open file for writing if called for the first time
    if ( first ) then
      open(20, file = filename)
      first = .false.
    endif

    ! Write to disc
    if ( present(n) ) then
      write(20,'(f11.9ai6.6a)') minval(a),' (Iteration: ',n,')'
    else
      write(20,'(f11.9)') minval(a)
    endif

    ! Close file
    if ( present(close_flag) .and. (close_flag .eqv. .true.)  ) then
      close(20)
      first = .true.
    endif
  end subroutine diagnose

  function to_lower(str_in) result(str_out)
    ! Takes a string, converts all characters to lower case and returns a new
    ! string
    character(len=*), intent(in) :: str_in
    character(len=len(str_in)) :: str_out
    integer :: i, j

    do i = 1, len(str_in)
      j = iachar( str_in(i:i) )
      if ( j >= iachar("A") .and. j <= iachar("Z") ) then
        str_out(i:i) = achar( j+32 )
      else
        str_out(i:i) = str_in(i:i)
      end if
    end do

  end function to_lower

  subroutine print_array(m)
    ! Debug routine for printing array of arbitrary size
    real(8), dimension(:,:), intent(in) :: m
    character(len=10) :: prt_format
    character(len=10) :: nr_cols
    integer :: i

    ! Define format
    write(nr_cols, "(i0.0)") int(size(m,2))
    prt_format = '('//trim(nr_cols)//'f6.3)'

    ! Print to console
    write(*, '(/"-----")')
    do i = 1, int(size(m,1))
      print trim(prt_format), m(i,:)
    end do
    write(*, '("-----"/)')
  end subroutine print_array

end module io


! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
subroutine s
  !ERROR: 'a' does not follow 'b' alphabetically
  implicit integer(b-a)
end


module constants_module

    implicit none
    save

    real(kind=4), parameter :: grav = 9.81
    real(kind=4), parameter :: TOLERANCE = 1e-8

end module constants_module


module dynamic_arrays_mod
    implicit none
    private
    integer, public :: delta_size = 1000
    public :: add_array_value, trim_array

contains

    subroutine add_array_value(array, new_value, has_succeeded)
        use, intrinsic :: ieee_arithmetic, only : ieee_is_finite, ieee_value, &
            ieee_positive_inf
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, dimension(:), allocatable, intent(inout) :: array
        real, value :: new_value
        logical, optional, intent(out) :: has_succeeded
        integer :: idx
        real, dimension(:), allocatable :: temp
        real :: infinity
        infinity = ieee_value(infinity, ieee_positive_inf)

        if (present(has_succeeded)) &
            has_succeeded = .true.

        ! initial array is not allocated, allocate and initialize all element to
        ! infinity
        if (.not. allocated(array)) &
            call allocate_array(array, delta_size, 'initial', init=infinity)

        ! array can not store an infinite values, check warn and return if necessary
        if (.not. ieee_is_finite(new_value)) then
            write (unit=error_unit, fmt='(A)') 'warning: can not store NaN value'
            if (present(has_succeeded)) &
                has_succeeded = .false.
            return
        end if

        ! find location of first empty element
        idx = findloc(array, infinity, dim=1)
        ! if the array is full, enlarge it by delta_size
        if (idx == 0) then
            call allocate_array(temp, size(array) + delta_size, 'extented')
            temp(1:size(array)) = array
            temp(size(array) + 1:size(temp)) = infinity
            idx = size(array) + 1
            call move_alloc(temp, array)
        end if
        ! store new element
        array(idx) = new_value
    end subroutine add_array_value

    subroutine trim_array(array)
        use, intrinsic :: ieee_arithmetic, only : ieee_is_finite, ieee_value, &
            ieee_positive_inf
        implicit none
        real, dimension(:), allocatable, intent(inout) :: array
        real, dimension(:), allocatable :: temp
        integer :: idx
        real :: infinity
        infinity = ieee_value(infinity, ieee_positive_inf)

        if (.not. allocated(array)) then
            allocate(array(0))
            return
        end if
        idx = findloc(array, infinity, dim=1)
        ! if the array is not full, create a new one of the required size
        if (idx > 0) then
            call allocate_array(temp, idx - 1, 'trimmed')
            if (idx > 1) temp = array(1:idx - 1)
            call move_alloc(temp, array)
        end if
    end subroutine trim_array

    subroutine allocate_array(array, array_size, msg, init)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, dimension(:), allocatable, intent(inout) :: array
        integer, value :: array_size
        character(len=*),intent(in) :: msg
        real, value, optional :: init
        integer :: status

        ! if the array is allocated, deallocate it first
        if (allocated(array)) &
            deallocate(array)

        ! allocate for specified size and check
        allocate(array(array_size), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(3A, I0)') &
                'error: can not allocate array ', trim(msg), &
                ' of size ', array_size
            stop 101
        end if

        ! if necessary, initialize array
        if (present(init)) &
            array = init
    end subroutine allocate_array

end module dynamic_arrays_mod


program dynamic_array_test
    use, intrinsic :: iso_fortran_env, only : error_unit
    use dynamic_arrays_mod, only : delta_size, trim_array, add_array_value
    implicit none
    integer :: i
    real :: x
    real, dimension(:), allocatable :: array

    ! for testing purposes, set delta_size to a low value
    delta_size = 10

    ! check for size zero array
    call trim_array(array)
    print '("size = ", I0)', size(array)

    ! add 15 values, check size
    x = 0.0
    do i = 1, 15
        x = x + 1.0
        call add_array_value(array, x)
    end do
    print '("size = ", I0)', size(array)

    ! trim, check size and show values
    call trim_array(array)
    print '("size = ", I0)', size(array)
    print *, array

    deallocate(array)
end program dynamic_array_test


! RUN: %S/test_symbols.sh %s %t %flang_fc1 -fopenmp

! 2.15.3 Data-Sharing Attribute Clauses
! Both PARALLEL and DO (worksharing) directives need to create new scope,
! so PRIVATE `a` will have new symbol in each region

  !DEF: /MainProgram1/a ObjectEntity REAL(8)
  real*8 a
  !REF: /MainProgram1/a
  a = 3.14
  !$omp parallel  private(a)
  !DEF: /MainProgram1/Block1/a (OmpPrivate) HostAssoc REAL(8)
  a = 2.
  !$omp do  private(a)
  !DEF: /MainProgram1/Block1/Block1/i (OmpPrivate, OmpPreDetermined) HostAssoc INTEGER(4)
  do i=1,10
     !DEF: /MainProgram1/Block1/Block1/a (OmpPrivate) HostAssoc REAL(8)
     a = 1.
  end do
  !$omp end parallel
  !REF: /MainProgram1/a
  print *, a
end program


program ringcart

  use mpi
  implicit none

  integer :: ifail
  integer :: rank, size
  integer :: sum

  call mpi_init(ifail)

  call mpi_comm_rank(MPI_COMM_WORLD, rank, ifail)
  call mpi_comm_size(MPI_COMM_WORLD, size, ifail)

  sum = 0

  ! ...

  ! Display the result on all ranks, along with the correct answer

  write (unit = *, fmt = '(a,i3,a,i4,a,i4)') &
       "Rank ", rank, " has sum of ranks ", sum, " Answer ", (size - 1)*size/2

  call mpi_finalize(ifail)

end program ringcart


! { dg-do compile }
! { dg-options -std=f2003 }
!
! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
module fcn_bar
contains
  function bar (arg, idx) result (res)
    integer, pointer :: res
    integer, target :: arg(:)
    integer :: idx
    res => arg (idx)
    res = 99
  end function
end module

module fcn_mydt
  type mydt
    integer, allocatable, dimension (:) :: i
  contains
    procedure, pass :: create
    procedure, pass :: delete
    procedure, pass :: fill
    procedure, pass :: elem_fill
  end type
contains
  subroutine create (this, sz)
    class(mydt) :: this
    integer :: sz
    if (allocated (this%i)) deallocate (this%i)
    allocate (this%i(sz))
    this%i = 0
  end subroutine
  subroutine delete (this)
    class(mydt) :: this
    if (allocated (this%i)) deallocate (this%i)
  end subroutine
  function fill (this, idx) result (res)
    integer, pointer :: res(:)
    integer :: lb, ub
    class(mydt), target :: this
    integer :: idx
    lb = idx
    ub = lb + size(this%i) - 1
    res => this%i(lb:ub)
  end function
  function elem_fill (this, idx) result (res)
    integer, pointer :: res
    class(mydt), target :: this
    integer :: idx
    res => this%i(idx)
  end function
end module

  use fcn_bar
  use fcn_mydt
  integer, target :: a(3) = [1,2,3]
  integer, pointer :: b
  integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
  type(mydt) :: dt
  foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
  if (any (a .ne. [1,2,3])) STOP 1

! Assignment to pointer result is after procedure call.
  foo (a) = 77 ! { dg-error "Pointer procedure assignment" }

! Assignment within procedure applies.
  b => foo (a)
  if (b .ne. 99) STOP 2

! Use of index for assignment.
  bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
  if (any (a .ne. [99,99,3])) STOP 3

! Make sure that statement function still works!
  if (foobar (10) .ne. 100) STOP 4

  bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" }
  if (any (a .ne. [99,99,81])) STOP 5

! Try typebound procedure
  call dt%create (6)
  dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" }
  if (dt%i(3) .ne. 42) STOP 6
  dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
  if (dt%i(3) .ne. 84) STOP 7
  dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
  if (dt%i(3) .ne. 0) STOP 8
! Array is now reset
  dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" }
  dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" }
  if (any (dt%i .ne. [2,1,ifill])) STOP 9
  dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" }
  if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10
  dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" }
  if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11
  call dt%delete

contains
  function foo (arg)
    integer, pointer :: foo
    integer, target :: arg(:)
    foo => arg (1)
    foo = 99
  end function
  function footoo (arg) result(res)
    integer :: arg
    integer :: res(arg)
    res = [(arg - i, i = 0, arg - 1)]
  end function
end


! Demonstration for message passing between MPI processes
program note_passing

    use mpi

    implicit none

    integer :: proc_id, num_procs, error, tag
    real(kind=8) :: important_note
    integer, dimension(MPI_STATUS_SIZE) :: status

    call mpi_init(error)
    call mpi_comm_size(MPI_COMM_WORLD, num_procs, error)
    call mpi_comm_rank(MPI_COMM_WORLD, proc_id, error)

    if (num_procs == 1) then
        print *, "Only one process, cannot do anything."
        call MPI_FINALIZE(error)
        stop
    endif

    ! Not really important in this case but important to sort through messages
    tag = 42

    ! If we are process 0 then set the value to be passed
    if (proc_id == 0) then
        important_note = 2.718281828d0
        print '("Process ",i3," note = ",e18.8)', proc_id, important_note

        call mpi_send(important_note, 1, MPI_DOUBLE_PRECISION, 1, tag, &
                      MPI_COMM_WORLD, error)

    ! If we are one of the processes in between pass it on to the next process
    else if (proc_id < num_procs - 1) then

        call MPI_RECV(important_note, 1, MPI_DOUBLE_PRECISION, proc_id-1, tag, &
                      MPI_COMM_WORLD, status, error)

        print '("Process ",i3," received note = ",e18.8)', proc_id, important_note

        call mpi_send(important_note, 1, MPI_DOUBLE_PRECISION, proc_id + 1, &
                      tag, MPI_COMM_WORLD, error)

        print '("Process ",i3,"    sent note = ",e18.8)', proc_id, important_note

    ! If we are the last process in the class to find out, well...
    else if (proc_id == num_procs - 1) then

        call mpi_recv(important_note, 1, MPI_DOUBLE_PRECISION, proc_id - 1, &
                      tag, MPI_COMM_WORLD, status, error)

        print '("Process ",i3," ends up with note = ",e18.8)', proc_id, important_note
      endif

    call MPI_FINALIZE(error)

end program note_passing


program hello_world

    ! Load the OpenMP functions library
    use omp_lib

    implicit none

    integer :: i, best_cost, tid, my_cost
    integer, parameter :: N = 20
    real    :: my_rand(N)

    ! Seed random number
    call random_seed(put=(/0/))
    best_cost=huge(best_cost)
    ! Note check thread-safety of random generator or avoid altogether
    ! using inside threads.
    call random_number(my_rand)

    !  Fork a team of threads, with private versions of the declared variables.
    !$OMP PARALLEL SHARED(best_cost) PRIVATE(tid, my_cost)

    !$OMP DO
    do i = 1, N
      my_cost = floor(my_rand(i)*100)
      print *, "tid ", tid, " - ", tid, my_cost
      !$OMP CRITICAL
      if (best_cost > my_cost) then
        print *, "tid ", tid, " says that ", my_cost, " is lower than ", best_cost
        best_cost = my_cost
      end if
      !$OMP END CRITICAL
    end do
    !$OMP END DO NOWAIT

    ! Disband all but the master thread
    !$OMP END PARALLEL

    print *, "Best cost ", best_cost

end program hello_world


! { dg-do compile }
! { dg-options "-fimplicit-none" }
!
! PR 41121: [4.5 Regression] compile-time error when building BLAS with -fimplicit-none
!
! Original test case: http://www.netlib.org/blas/dgbmv.f
! Reduced by Joost VandeVondele <jv244@cam.ac.uk>

  INTRINSIC MIN
  INTEGER :: I,J
  print *,MIN(I,J)
END


! { dg-do compile }
! PR fortran/69741 - improve error message for nonscalar FORALL index variables
!
subroutine check
  integer :: ii(2), i
  real :: a(3,2)

  forall (ii(1)=1:3, i=1:2) ! { dg-error "scalar variable of type integer" }
     a(ii(1),i) = ii(1) * i
  end forall

  forall (j=1:3, ii(2)=1:2) ! { dg-error "scalar variable of type integer" }
     a(j,ii(2)) = j * ii(2)
  end forall

end subroutine check


!> Tests the defined single- and double-precision kinds.
PROGRAM test_kinds
    USE kinds
    IMPLICIT NONE
    REAL(dp) :: testdp = 1.0_dp
    REAL(sp) :: testsp = 1.0_sp

    IF( KIND(testdp) /= 8 .OR. KIND(testsp) /= 4 ) THEN
        WRITE(*,*) 'The defined kinds are not working correctly!'
        STOP 1
    END IF

END PROGRAM test_kinds


! { dg-do run }
! PR 49755 - If allocating an already allocated array, and stat=
!            is given, set stat to non zero and do not touch the array.
program test
    integer, allocatable :: A(:, :)
    integer :: stat

    allocate(A(20,20))
    A = 42

    ! Allocate of already allocated variable
    allocate (A(5,5), stat=stat)

    ! Expected: Error stat and previous allocation status
    if (stat == 0) STOP 1
    if (any (shape (A) /= [20, 20])) STOP 2
    if (any (A /= 42)) STOP 3
end program


program triple_loop_1

    integer,parameter :: n=139

    real*8 A(n), B(n), C(n), D(n)

    !$xev loop_tag
    do i=1,n
        B(i) = A(i)
    end do
    do i=1,n
        D(i) = C(i)
    end do

end program  triple_loop_1


program print_characters
    implicit none
    character(len=6) :: c = 'abcdef'
    integer :: width
    character(len=10) :: fmt

    do width = 2, 8
        write (fmt, "('(A', I0, ')')") width
        print fmt, c
    end do
end program print_characters


program test
    use, intrinsic :: iso_fortran_env
    use :: test_mod
    implicit none
    type(my_t) :: var

    var = my_t(3.5, 5.7)
    print '(dt)', var
    print *, var
    print '(dt(5, 2))', var
end program test


!
! sum program_do
!
! Example of a parallel do directive
!
! 2008
! Creation: A. Muller, 2008

      program parallel_do
      implicit none
      integer N
      parameter (N=10)
      integer i,a(N)

!$omp PARALLEL DO
      do 10 i=1,N
         a(i)=i
 10   continue

      print *,a

      end


! { dg-do run }
! PR 80442
! This test case used to produce an bogus error
! about the variables being below the lower
! array bounds
program main
    implicit none
    integer:: i
    integer, dimension(3):: A
    data (A(i:i+2:i+1), i=1,2) /1, 2, 3/
    if(any(A .ne. [1,3,2])) STOP 1
end program


MODULE Precision
    USE ISO_FORTRAN_ENV, ONLY : i4k => INT32, i8k => INT64, r4k => REAL32, r8k =>REAL64
    IMPLICIT NONE
    !! author: Ian Porter
    !! date: 12/9/2017
    !!
    !! This module contains the Precision used for specifying the precision of variables
    !!
    PRIVATE
    PUBLIC :: i4k, r8k

END MODULE Precision


! { dg-do compile }
! { dg-options "-std=f95" }
!
! PR fortran/27997
!
! Array constructor with typespec
! should be rejected for Fortran 95.
!
real :: a(3)
integer :: j(3)
a = (/ integer :: 1.4, 2.2, 3.33  /) ! { dg-error "Fortran 2003" }
j = (/ 1.4, 2.2, 3.33  /)
if( any(a /= j )) STOP 1
end


PROGRAM loop_interchange

 CALL clawloop ( )
END PROGRAM loop_interchange

SUBROUTINE clawloop ( )

 INTEGER :: i
 INTEGER :: j

 DO j = 1 , 2 , 1
  DO i = 1 , 10 , 1
   PRINT * ,"Iteration " , i ,"," , j
  END DO
 END DO
END SUBROUTINE clawloop


module kinds_m
	implicit none
	integer, parameter :: MP = kind(0)
	integer, parameter :: SP = kind(0.0e0)
	integer, parameter :: DP = kind(0.0d0)

	integer, parameter :: I2 = 2
	integer, parameter :: I4 = 4
	integer, parameter :: I8 = 8
end module


module int64_m
  !!
  !! Provide functionality for comparing scalar integers of `kind=int64`
  !!
  use, intrinsic :: iso_fortran_env,  only : WP => int64
  use test_base_m,                    only : testline
  use test_base_m,                    only : tests
  implicit none
  private
  public :: is

  interface is
    module procedure is_int
  end interface

  ! integer, parameter :: WP = int64

contains

  include 'is_int.inc'

end module int64_m