! Test lowering of pointer assignments
! RUN: bbc -emit-fir %s -o - | FileCheck %s

! Note that p => NULL() are tested in pointer-disassociate.f90

! -----------------------------------------------------------------------------
!     Test simple pointer assignments to contiguous right-hand side
! -----------------------------------------------------------------------------

! CHECK-LABEL: func @_QPtest_scalar(
! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}}, %[[x:.*]]: !fir.ref<f32> {{{.*}}, fir.target})
subroutine test_scalar(p, x)
    real, target :: x
    real, pointer :: p
    ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
    p => x
  end subroutine

  ! CHECK-LABEL: func @_QPtest_scalar_char(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target})
  subroutine test_scalar_char(p, x)
    character(*), target :: x
    character(:), pointer :: p
    ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
    ! CHECK: %[[box:.*]] = fir.embox %[[c]]#0 typeparams %[[c]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
    p => x
  end subroutine

  ! CHECK-LABEL: func @_QPtest_array(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.ref<!fir.array<100xf32>> {{{.*}}, fir.target})
  subroutine test_array(p, x)
    real, target :: x(100)
    real, pointer :: p(:)
    ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}}
    ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p => x
  end subroutine

  ! CHECK-LABEL: func @_QPtest_array_char(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target}) {
  subroutine test_array_char(p, x)
    character(*), target :: x(100)
    character(:), pointer :: p(:)
    ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
    ! CHECK: %[[xaddr:.*]] = fir.convert %[[c]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<100x!fir.char<1,?>>>
    ! CHECK-DAG: %[[xaddr2:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<100x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x!fir.char<1,?>>>
    ! CHECK-DAG: %[[shape:.*]] = fir.shape %c100{{.*}}
    ! CHECK: %[[box:.*]] = fir.embox %[[xaddr2]](%[[shape]]) typeparams %[[c]]#1
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
    p => x
  end subroutine

  ! Test 10.2.2.3 point 10: lower bounds requirements:
  ! pointer takes lbounds from rhs if no bounds spec.
  ! CHECK-LABEL: func @_QPtest_array_with_lbs(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  subroutine test_array_with_lbs(p, x)
    real, target :: x(51:150)
    real, pointer :: p(:)
    ! CHECK: %[[shape:.*]] = fir.shape_shift %c51{{.*}}, %c100{{.*}}
    ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p => x
  end subroutine

  ! -----------------------------------------------------------------------------
  !    Test pointer assignments with bound specs to contiguous right-hand side
  ! -----------------------------------------------------------------------------

  ! Test 10.2.2.3 point 10: lower bounds requirements:
  ! pointer takes lbounds from bound spec if specified
  ! CHECK-LABEL: func @_QPtest_array_with_new_lbs(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  subroutine test_array_with_new_lbs(p, x)
    real, target :: x(51:150)
    real, pointer :: p(:)
    ! CHECK: %[[shape:.*]] = fir.shape_shift %c4{{.*}}, %c100{{.*}}
    ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p(4:) => x
  end subroutine

  ! Test F2018 10.2.2.3 point 9: bounds remapping
  ! CHECK-LABEL: func @_QPtest_array_remap(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[x:.*]]: !fir.ref<!fir.array<100xf32>> {{{.*}}, fir.target})
  subroutine test_array_remap(p, x)
    real, target :: x(100)
    real, pointer :: p(:, :)
    ! CHECK-DAG: %[[c2_idx:.*]] = fir.convert %c2{{.*}} : (i64) -> index
    ! CHECK-DAG: %[[c11_idx:.*]] = fir.convert %c11{{.*}} : (i64) -> index
    ! CHECK-DAG: %[[diff0:.*]] = arith.subi %[[c11_idx]], %[[c2_idx]] : index
    ! CHECK-DAG: %[[ext0:.*]] = arith.addi %[[diff0:.*]], %c1{{.*}} : index
    ! CHECK-DAG: %[[c3_idx:.*]] = fir.convert %c3{{.*}} : (i64) -> index
    ! CHECK-DAG: %[[c12_idx:.*]] = fir.convert %c12{{.*}} : (i64) -> index
    ! CHECK-DAG: %[[diff1:.*]] = arith.subi %[[c12_idx]], %[[c3_idx]] : index
    ! CHECK-DAG: %[[ext1:.*]] = arith.addi %[[diff1]], %c1{{.*}} : index
    ! CHECK-DAG: %[[addrCast:.*]] = fir.convert %[[x]] : (!fir.ref<!fir.array<100xf32>>) -> !fir.ref<!fir.array<?x?xf32>>
    ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]]
    ! CHECK: %[[box:.*]] = fir.embox %[[addrCast]](%[[shape]]) : (!fir.ref<!fir.array<?x?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
    ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
    p(2:11, 3:12) => x
  end subroutine

  ! CHECK-LABEL: func @_QPtest_array_char_remap(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?x!fir.char<1,?>>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target})
  subroutine test_array_char_remap(p, x)
    ! CHECK: %[[unbox:.*]]:2 = fir.unboxchar %[[x]]
    character(*), target :: x(100)
    character(:), pointer :: p(:, :)
    ! CHECK: subi
    ! CHECK: %[[ext0:.*]] = arith.addi
    ! CHECK: subi
    ! CHECK: %[[ext1:.*]] = arith.addi
    ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]]
    ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) typeparams %[[unbox]]#1 : (!fir.ref<!fir.array<?x?x!fir.char<1,?>>>, !fir.shapeshift<2>, index) -> !fir.box<!fir.ptr<!fir.array<?x?x!fir.char<1,?>>>>
    ! CHECK: fir.store %[[box]] to %[[p]]
    p(2:11, 3:12) => x
  end subroutine

  ! -----------------------------------------------------------------------------
  !  Test simple pointer assignments to non contiguous right-hand side
  ! -----------------------------------------------------------------------------

  ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
  subroutine test_array_non_contig_rhs(p, x)
    real, target :: x(:)
    real, pointer :: p(:)
    ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
    ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p => x
  end subroutine

  ! Test 10.2.2.3 point 10: lower bounds requirements:
  ! pointer takes lbounds from rhs if no bounds spec.
  ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_lbs(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
  subroutine test_array_non_contig_rhs_lbs(p, x)
    real, target :: x(7:)
    real, pointer :: p(:)
    ! CHECK: %[[c7_idx:.*]] = fir.convert %c7{{.*}} : (i64) -> index
    ! CHECK: %[[shift:.*]] = fir.shift %[[c7_idx]] : (index) -> !fir.shift<1>
    ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>

    ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p => x
  end subroutine

  ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs2(
  ! CHECK-SAME:                                      %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<!fir.array<200xf32>> {{{.*}}, fir.target}) {
  ! CHECK:         %[[VAL_2:.*]] = arith.constant 200 : index
  ! CHECK:         %[[VAL_3:.*]] = arith.constant 10 : i64
  ! CHECK:         %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
  ! CHECK:         %[[VAL_5:.*]] = arith.constant 3 : i64
  ! CHECK:         %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
  ! CHECK:         %[[VAL_7:.*]] = arith.constant 160 : i64
  ! CHECK:         %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
  ! CHECK:         %[[VAL_9:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
  ! CHECK:         %[[VAL_10:.*]] = fir.slice %[[VAL_4]], %[[VAL_8]], %[[VAL_6]] : (index, index, index) -> !fir.slice<1>
  ! CHECK:         %[[VAL_11:.*]] = fir.embox %[[VAL_1]](%[[VAL_9]]) {{\[}}%[[VAL_10]]] : (!fir.ref<!fir.array<200xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
  ! CHECK:         %[[VAL_12:.*]] = fir.rebox %[[VAL_11]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
  ! CHECK:         fir.store %[[VAL_12]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
  ! CHECK:         return
  ! CHECK:       }

  subroutine test_array_non_contig_rhs2(p, x)
    real, target :: x(200)
    real, pointer :: p(:)
    p => x(10:160:3)
  end subroutine

  ! -----------------------------------------------------------------------------
  !  Test pointer assignments with bound specs to non contiguous right-hand side
  ! -----------------------------------------------------------------------------

  ! Test 10.2.2.3 point 10: lower bounds requirements:
  ! pointer takes lbounds from bound spec if specified
  ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_new_lbs(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
  subroutine test_array_non_contig_rhs_new_lbs(p, x)
    real, target :: x(7:)
    real, pointer :: p(:)
    ! CHECK: %[[shift:.*]] = fir.shift %c4{{.*}}
    ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>

    ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
    p(4:) => x
  end subroutine

  ! Test F2018 10.2.2.3 point 9: bounds remapping
  ! CHECK-LABEL: func @_QPtest_array_non_contig_remap(
  ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
  subroutine test_array_non_contig_remap(p, x)
    real, target :: x(:)
    real, pointer :: p(:, :)
    ! CHECK: subi
    ! CHECK: %[[ext0:.*]] = arith.addi
    ! CHECK: subi
    ! CHECK: %[[ext1:.*]] = arith.addi
    ! CHECK: %[[shape:.*]] = fir.shape_shift %{{.*}}, %[[ext0]], %{{.*}}, %[[ext1]]
    ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shape]]) : (!fir.box<!fir.array<?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
    ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
    p(2:11, 3:12) => x
  end subroutine

  ! Test remapping a slice

  ! CHECK-LABEL: func @_QPtest_array_non_contig_remap_slice(
  ! CHECK-SAME:                                             %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<!fir.array<400xf32>> {{{.*}}, fir.target}) {
  ! CHECK:         %[[VAL_2:.*]] = arith.constant 400 : index
  ! CHECK:         %[[VAL_3:.*]] = arith.constant 2 : i64
  ! CHECK:         %[[VAL_4:.*]] = arith.constant 11 : i64
  ! CHECK:         %[[VAL_5:.*]] = arith.constant 3 : i64
  ! CHECK:         %[[VAL_6:.*]] = arith.constant 12 : i64
  ! CHECK:         %[[VAL_7:.*]] = arith.constant 51 : i64
  ! CHECK:         %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
  ! CHECK:         %[[VAL_9:.*]] = arith.constant 3 : i64
  ! CHECK:         %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index
  ! CHECK:         %[[VAL_11:.*]] = arith.constant 350 : i64
  ! CHECK:         %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
  ! CHECK:         %[[VAL_13:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
  ! CHECK:         %[[VAL_14:.*]] = fir.slice %[[VAL_8]], %[[VAL_12]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1>
  ! CHECK:         %[[VAL_15:.*]] = fir.embox %[[VAL_1]](%[[VAL_13]]) {{\[}}%[[VAL_14]]] : (!fir.ref<!fir.array<400xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
  ! CHECK:         %[[VAL_16:.*]] = arith.constant 1 : index
  ! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
  ! CHECK:         %[[VAL_18:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
  ! CHECK:         %[[VAL_19:.*]] = arith.subi %[[VAL_18]], %[[VAL_17]] : index
  ! CHECK:         %[[VAL_20:.*]] = arith.addi %[[VAL_19]], %[[VAL_16]] : index
  ! CHECK:         %[[VAL_21:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
  ! CHECK:         %[[VAL_22:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
  ! CHECK:         %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_21]] : index
  ! CHECK:         %[[VAL_24:.*]] = arith.addi %[[VAL_23]], %[[VAL_16]] : index
  ! CHECK:         %[[VAL_25:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
  ! CHECK:         %[[VAL_26:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
  ! CHECK:         %[[VAL_27:.*]] = fir.shape_shift %[[VAL_25]], %[[VAL_20]], %[[VAL_26]], %[[VAL_24]] : (index, index, index, index) -> !fir.shapeshift<2>
  ! CHECK:         %[[VAL_28:.*]] = fir.rebox %[[VAL_15]](%[[VAL_27]]) : (!fir.box<!fir.array<?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
  ! CHECK:         fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
  ! CHECK:         return
  ! CHECK:       }
  subroutine test_array_non_contig_remap_slice(p, x)
    real, target :: x(400)
    real, pointer :: p(:, :)
    p(2:11, 3:12) => x(51:350:3)
  end subroutine

  ! -----------------------------------------------------------------------------
  !  Test pointer assignments that involves LHS pointers lowered to local variables
  !  instead of a fir.ref<fir.box>, and RHS that are fir.box
  ! -----------------------------------------------------------------------------

  ! CHECK-LABEL: func @_QPissue857(
  ! CHECK-SAME: %[[rhs:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>>
  subroutine issue857(rhs)
    type t
      integer :: i
    end type
    type(t), pointer :: rhs, lhs
    ! CHECK: %[[lhs:.*]] = fir.alloca !fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>
    ! CHECK: %[[box_load:.*]] = fir.load %[[rhs]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>>
    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box_load]] : (!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>) -> !fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>
    ! CHECK: fir.store %[[addr]] to %[[lhs]] : !fir.ref<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>
    lhs => rhs
  end subroutine

  ! CHECK-LABEL: func @_QPissue857_array(
  ! CHECK-SAME: %[[rhs:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>>
  subroutine issue857_array(rhs)
    type t
      integer :: i
    end type
    type(t), contiguous,  pointer :: rhs(:), lhs(:)
    ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>> {uniq_name = "_QFissue857_arrayElhs.addr"}
    ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.lb0"}
    ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.ext0"}
    ! CHECK: %[[box:.*]] = fir.load %[[rhs]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>>
    ! CHECK: %[[lb:.*]]:3 = fir.box_dims %[[box]], %c{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>, index) -> (index, index, index)
    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>) -> !fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>
    ! CHECK: %[[ext:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>, index) -> (index, index, index)
    ! CHECK-DAG: fir.store %[[addr]] to %[[lhs_addr]] : !fir.ref<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>
    ! CHECK-DAG: fir.store %[[ext]]#1 to %[[lhs_ext]] : !fir.ref<index>
    ! CHECK-DAG: fir.store %[[lb]]#0 to %[[lhs_lb]] : !fir.ref<index>
    lhs => rhs
  end subroutine

  ! CHECK-LABEL: func @_QPissue857_array_shift(
  subroutine issue857_array_shift(rhs)
    ! Test lower bounds is the one from the shift
    type t
      integer :: i
    end type
    type(t), contiguous,  pointer :: rhs(:), lhs(:)
    ! CHECK: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_shiftElhs.lb0"}
    ! CHECK: %[[c42:.*]] = fir.convert %c42{{.*}} : (i64) -> index
    ! CHECK: fir.store %[[c42]] to %[[lhs_lb]] : !fir.ref<index>
    lhs(42:) => rhs
  end subroutine

  ! CHECK-LABEL: func @_QPissue857_array_remap
  subroutine issue857_array_remap(rhs)
    ! Test lower bounds is the one from the shift
    type t
      integer :: i
    end type
    type(t), contiguous,  pointer :: rhs(:, :), lhs(:)
    ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>> {uniq_name = "_QFissue857_array_remapElhs.addr"}
    ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.lb0"}
    ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.ext0"}

    ! CHECK: %[[c101:.*]] = fir.convert %c101_i64 : (i64) -> index
    ! CHECK: %[[c200:.*]] = fir.convert %c200_i64 : (i64) -> index
    ! CHECK: %[[sub:.*]] = arith.subi %[[c200]], %[[c101]] : index
    ! CHECK: %[[extent:.*]] = arith.addi %[[sub]], %c1{{.*}} : index
    ! CHECK: %[[addr:.*]] = fir.box_addr %{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>>) -> !fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>
    ! CHECK: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>) -> !fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>
    ! CHECK: fir.store %[[addr_cast]] to %[[lhs_addr]] : !fir.ref<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>>
    ! CHECK: fir.store %[[extent]] to %[[lhs_ext]] : !fir.ref<index>
    ! CHECK: %[[c101_2:.*]] = fir.convert %c101{{.*}} : (i64) -> index
    ! CHECK: fir.store %[[c101_2]] to %[[lhs_lb]] : !fir.ref<index>
    lhs(101:200) => rhs
  end subroutine

  ! CHECK-LABEL: func @_QPissue857_char
  subroutine issue857_char(rhs)
    ! Only check that the length is taken from the fir.box created for the slice.
    ! CHECK-DAG: %[[lhs1_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs1.len"}
    ! CHECK-DAG: %[[lhs2_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs2.len"}
    character(:), contiguous,  pointer ::  lhs1(:), lhs2(:, :)
    character(*), target ::  rhs(100)
    ! CHECK: %[[len:.*]] = fir.box_elesize %{{.*}} : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
    ! CHECK: fir.store %[[len]] to %[[lhs1_len]] : !fir.ref<index>
    lhs1 => rhs(1:50:1)
    ! CHECK: %[[len2:.*]] = fir.box_elesize %{{.*}} : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
    ! CHECK: fir.store %[[len2]] to %[[lhs2_len]] : !fir.ref<index>
    lhs2(1:2, 1:25) => rhs(1:50:1)
  end subroutine

  ! CHECK-LABEL: func @_QPissue1180(
  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {{{.*}}, fir.target}) {
  subroutine issue1180(x)
    integer, target :: x
    integer, pointer :: p
    common /some_common/ p
    ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBsome_common) : !fir.ref<!fir.array<24xi8>>
    ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<24xi8>>) -> !fir.ref<!fir.array<?xi8>>
    ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index
    ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
    ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<i8>) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
    ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_0]] : (!fir.ref<i32>) -> !fir.box<!fir.ptr<i32>>
    ! CHECK: fir.store %[[VAL_6]] to %[[VAL_5]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
    p => x
  end subroutine


      program t
      integer::k=-1
      call s(2,k)
      print '(i0)',k
      contains
      subroutine s(j,k)
      integer,intent(in)::j
      integer,intent(out)::k
      integer::i=1
      print '(i0)',i+j
      k=77
      end subroutine
      end program t


          program demo_block
          implicit none
          integer,parameter :: arr1(*)=[1,2,3,4,5,6,7]
          integer,parameter :: arr2(*)=[0,1,2,3,4,5,6,7]
            call showme(arr1)
            call showme(arr2)
            contains
          subroutine showme(a)
          integer,intent(in) :: a(:)
          integer :: i=-100
          integer :: tan
            tan=20 ! intentionally cause a conflict with intrinsic
            TESTFORZERO: block
               integer :: I  ! local block variable
               intrinsic :: tan  ! can use the TAN intrinsic in the block
               do i=1,size(a)
                  if(a(i).eq.0) then
                     write(*,*)'found zero at index',i
                     exit TESTFORZERO
                  endif
               enddo
               write(*,*)'Never found a zero, tried ',i-1,' times'
               return
             endblock TESTFORZERO
             ! note the variable I in the block is local to the block
             write(*,*)'this is the variable in the main scope of the program, I=',i
          end subroutine showme

          end program demo_block


subroutine a_proc
implicit none
integer :: i
parameter(i = 1)
print *, i
end subroutine a_proc

module a_mod
implicit none
integer :: i
parameter(i = 2)
end module a_mod

program parameter_02
use a_mod, only: i
implicit none
call a_proc()
print *, i
end program


!! R548 parameter-stmt
!   is PARAMETER ( named-constant-def-list )

10 parameter (i=0)
PARAMETER(j = kind(1))

end


program types_03
implicit none
real :: r
integer :: i
r = 1.5
print *, r
i = r
print *, i
end program


      program  main
      implicit none
      include 'omp_lib.h'
      call foo (9,0, -3)
      end

      subroutine foo (lower, upper, stride)
      integer lower, upper, stride
      integer i
!$omp parallel do
      do i = lower, upper, stride
        print *, "Iteration ", i
      enddo
      end


program t
! test for nested do-loops
  integer::i,j,k,l
  do 77 i=1,2
    do 88 j=1,2
      do 88 k=1,2
        do 88 l=1,2
          print *,1
88        continue
77        continue
        end program t


REAL :: A(10), B(10)
DO CONCURRENT(I=1:N)
  A(I) = B(I)
END DO
END PROGRAM


program assertion_examples
  !! Demonstrate the use of assetions
  use assert_m, only : assert
  implicit none
  integer, parameter :: i = 1
  real, parameter :: x = -1.

  call assert(i > 0, "i > 1") ! Passes
  call assert(x > 0, description="x > 0", diagnostic_data=x) ! Fails with output containing diagnostic data
end program


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

! Check OpenMP 2.13.6 atomic Construct

  a = 1.0
  !$omp parallel num_threads(4)
  !$omp atomic seq_cst, read
  b = a

  !$omp atomic seq_cst write
  a = b
  !$omp end atomic

  !$omp atomic capture seq_cst
  b = a
  a = a + 1
  !$omp end atomic

  !$omp atomic
  a = a + 1
  !$omp end parallel
end


! { dg-do run }
!
! PR fortran/51758
!
! Contributed by Mikael Morin
!
! Check whether passing NULL() to an elemental procedure works,
! where NULL() denotes an absent optional argument.
!
program p

  integer :: a(2)
  integer :: b

  a = 0
  a = foo((/ 1, 1 /), null())
!  print *, a
  if (any(a /= 2)) STOP 1

  a = 0
  a = bar((/ 1, 1 /), null())
!  print *, a
  if (any(a /= 2)) STOP 2

  b = 0
  b = bar(1, null())
!  print *, b
  if (b /= 2) STOP 3

contains

  function foo(a, b)
    integer           :: a(:)
    integer, optional :: b(:)
    integer           :: foo(size(a))

    if (present(b)) STOP 4

    foo = 2
  end function foo

  elemental function bar(a, b)
    integer, intent(in)           :: a
    integer, intent(in), optional :: b
    integer                       :: bar

    bar = 2

    if (present(b)) bar = 1

  end function bar

end program p


program print_test
    use, intrinsic :: iso_fortran_env, only : SP => REAL32, DP => REAL64
    implicit none
    integer, parameter :: n = 15
    real(kind=SP), parameter :: x = 3.14_SP
    real(kind=DP), parameter :: y = 2.69_DP
    character(len=10), parameter :: c = 'abc'
    logical, parameter :: l = .true.
    type udf
        real :: x
        integer :: n
    end type udf
    type(udf) :: u
    real, dimension(3) :: v = [ 3.5, 5.7, 7.3 ]
    integer, dimension(2, 3) :: A = reshape( [ 3, 7, 5, 9, 2, 4 ], [ 2, 3 ])
    u = udf(x = 3.5, n = 7)

    print *, '|', n, '|'
    print *, '|', x, '|'
    print *, '|', y, '|'
    print *, '|', c, '|'
    print *, '|', l, '|'
    print *, '|', u, '|'
    print *, '|', v, '|'
    print *, '|', A, '|'
end program print_test


C     Bug: the first loop is not parallelized because N is not privatized

      program loop
      real t(100)

      do i = 1, m
         n = i
         t(n) = 0.
      enddo

      do n = 1, m
         t(n) = 1.
      enddo

      end


! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! 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
! ------------------------------------------------------------------
! Program to test custom fnvector_fortran_mod implementation
! ------------------------------------------------------------------

! ------------------------------------------------------------------
! Utility module for error-checking
! ------------------------------------------------------------------
module fnvector_test_mod
  use, intrinsic :: iso_c_binding
  use fnvector_fortran_mod
  implicit none

contains
  integer(c_int) function check_ans(val, tol, Nvar, N, sunvec_x) result(failure)

    implicit none
    real(c_double), value :: val, tol
    integer(c_long), value :: Nvar, N
    Type(N_Vector) :: sunvec_x
    Type(FVec), pointer :: x
    integer(c_long) :: i, j

    x => FN_VGetFVec(sunvec_x)
    failure = 0
    do j = 1,N
       do i = 1,Nvar
          if (dabs(x%data(i,j) - val) > tol)  failure = 1
       end do
    end do

  end function check_ans
end module fnvector_test_mod

! ------------------------------------------------------------------
program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use fnvector_fortran_mod
  use fnvector_test_mod

  !======= Declarations =========
  implicit none

  ! local variables
  integer(c_int)             :: fails
  integer(c_long)            :: i, j, loc
  integer(c_long), parameter :: N = 1000
  integer(c_long), parameter :: Nvar = 10
  type(N_Vector), pointer    :: sU, sV, sW, sX, sY, sZ
  type(FVec), pointer        :: U, V, W, X, Y, Z
  real(c_double)             :: Udata(Nvar,N)
  real(c_double)             :: fac
  logical                    :: failure

  !======= Internals ============

  ! initialize failure total
  fails = 0

  ! create new vectors, using New, Make and Clone routines
  sU => FN_VMake_Fortran(Nvar, N, Udata)
  if (.not. associated(sU)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  U => FN_VGetFVec(sU)

  sV => FN_VNew_Fortran(Nvar, N)
  if (.not. associated(sV)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  V => FN_VGetFVec(sV)

  sW => FN_VNew_Fortran(Nvar, N)
  if (.not. associated(sW)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  W => FN_VGetFVec(sW)

  sX => FN_VNew_Fortran(Nvar, N)
  if (.not. associated(sX)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  X => FN_VGetFVec(sX)

  sY => FN_VNew_Fortran(Nvar, N)
  if (.not. associated(sY)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  Y => FN_VGetFVec(sY)

  call c_f_pointer(FN_VClone_Fortran(sU), sZ)
  if (.not. associated(sZ)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  Z => FN_VGetFVec(sZ)

  ! check vector ID
  if (FN_VGetVectorID(sU) /= SUNDIALS_NVEC_CUSTOM) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VGetVectorID'
     print *, '    Unrecognized vector type', FN_VGetVectorID(sU)
  else
     print *, 'PASSED test -- FN_VGetVectorID'
  end if

  ! check vector length
  if (FN_VGetLength(sV) /= (N*Nvar)) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VGetLength'
     print *, '    ', FN_VGetLength(sV), ' /= ', N*Nvar
  else
     print *, 'PASSED test -- FN_VGetLength'
  end if

  ! test FN_VConst
  Udata = 0.d0
  call FN_VConst(1.d0, sU)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sU) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VConst'
  else
     print *, 'PASSED test -- FN_VConst'
  end if

  ! test FN_VLinearSum
  call FN_VConst(1.d0, sX)
  call FN_VConst(-2.d0, sY)
  call FN_VLinearSum(1.d0, sX, 1.d0, sY, sY)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sY) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 1a'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 1a'
  end if

  call FN_VConst(1.d0, sX)
  call FN_VConst(2.d0, sY)
  call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sY)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sY) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 1b'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 1b'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(-2.d0, sY)
  call FN_VLinearSum(0.5d0, sX, 1.d0, sY, sY)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sY) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 1c'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 1c'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(-1.d0, sY)
  call FN_VLinearSum(1.d0, sX, 1.d0, sY, sX)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 2a'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 2a'
  end if

  call FN_VConst(1.d0, sX)
  call FN_VConst(2.d0, sY)
  call FN_VLinearSum(1.d0, sX, -1.d0, sY, sX)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sX) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 2b'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 2b'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(-0.5d0, sY)
  call FN_VLinearSum(1.d0, sX, 2.d0, sY, sX)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 2c'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 2c'
  end if

  call FN_VConst(-2.d0, sX)
  call FN_VConst(1.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(1.d0, sX, 1.d0, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 3'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 3'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(1.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(1.d0, sX, -1.d0, sY, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 4a'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 4a'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(1.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 4b'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 4b'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(-0.5d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(1.d0, sX, 2.d0, sY, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 5a'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 5a'
  end if

  call FN_VConst(0.5d0, sX)
  call FN_VConst(-2.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(2.d0, sX, 1.d0, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 5b'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 5b'
  end if

  call FN_VConst(-2.d0, sX)
  call FN_VConst(-0.5d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(-1.d0, sX, 2.d0, sY, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 6a'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 6a'
  end if

  call FN_VConst(0.5d0, sX)
  call FN_VConst(2.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(2.d0, sX, -1.d0, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 6b'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 6b'
  end if

  call FN_VConst(1.d0, sX)
  call FN_VConst(-0.5d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(2.d0, sX, 2.d0, sY, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 7'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 7'
  end if

  call FN_VConst(0.5d0, sX)
  call FN_VConst(1.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(2.d0, sX, -2.d0, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 8'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 8'
  end if

  call FN_VConst(1.d0, sX)
  call FN_VConst(-2.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VLinearSum(2.d0, sX, 0.5d0, sY, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VLinearSum Case 9'
  else
     print *, 'PASSED test -- FN_VLinearSum Case 9'
  end if

  ! test FN_VProd
  call FN_VConst(2.d0, sX)
  call FN_VConst(-0.5d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VProd(sX, sY, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VProd'
  else
     print *, 'PASSED test -- FN_VProd'
  end if

  ! test FN_VDiv
  call FN_VConst(1.d0, sX)
  call FN_VConst(2.d0, sY)
  call FN_VConst(0.d0, sZ)
  call FN_VDiv(sX, sY, sZ)
  if (check_ans(0.5d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VDiv'
  else
     print *, 'PASSED test -- FN_VDiv'
  end if

  ! test FN_VScale
  call FN_VConst(0.5d0, sX)
  call FN_VScale(2.d0, sX, sX)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VScale Case 1'
  else
     print *, 'PASSED test -- FN_VScale Case 1'
  end if

  call FN_VConst(-1.d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VScale(1.d0, sX, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VScale Case 2'
  else
     print *, 'PASSED test -- FN_VScale Case 2'
  end if

  call FN_VConst(-1.d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VScale(-1.d0, sX, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VScale Case 3'
  else
     print *, 'PASSED test -- FN_VScale Case 3'
  end if

  call FN_VConst(-0.5d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VScale(2.d0, sX, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VScale Case 4'
  else
     print *, 'PASSED test -- FN_VScale Case 4'
  end if

  ! test FN_VAbs
  call FN_VConst(-1.d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VAbs(sX, sZ)
  if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VAbs'
  else
     print *, 'PASSED test -- FN_VAbs'
  end if

  ! test FN_VInv
  call FN_VConst(2.d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VInv(sX, sZ)
  if (check_ans(0.5d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VInv'
  else
     print *, 'PASSED test -- FN_VInv'
  end if

  ! test FN_VAddConst
  call FN_VConst(1.d0, sX)
  call FN_VConst(0.d0, sZ)
  call FN_VAddConst(sX, -2.d0, sZ)
  if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VAddConst'
  else
     print *, 'PASSED test -- FN_VAddConst'
  end if

  ! test FN_VDotProd
  call FN_VConst(2.d0, sX)
  call FN_VConst(0.5d0, sY)
  if (dabs(FN_VDotProd(sX,sY) - (N*Nvar)) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VDotProd (',FN_VDotProd(sX,sY),' /= ',N*Nvar,')'
  else
     print *, 'PASSED test -- FN_VDotProd'
  end if

  ! test FN_VMaxNorm
  call FN_VConst(-0.5d0, sX)
  X%data(Nvar,N) = -2.d0
  if (dabs(FN_VMaxNorm(sX) - 2.d0) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VMaxNorm (',FN_VMaxNorm(sX),' /= 2.d0)'
  else
     print *, 'PASSED test -- FN_VMaxNorm'
  end if

  ! test FN_VWrmsNorm
  call FN_VConst(-0.5d0, sX)
  call FN_VConst(0.5d0, sY)
  if (dabs(FN_VWrmsNorm(sX,sY) - 0.25d0) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VWrmsNorm (',FN_VWrmsNorm(sX,sY),' /= 0.25d0)'
  else
     print *, 'PASSED test -- FN_VWrmsNorm'
  end if

  ! test FN_VWrmsNormMask
  call FN_VConst(-0.5d0, sX)
  call FN_VConst(0.5d0, sY)
  call FN_VConst(1.d0, sZ)
  Z%data(Nvar,N) = 0.d0
  fac = dsqrt(1.d0*(N*Nvar - 1)/(N*Nvar))*0.25d0
  if (dabs(FN_VWrmsNormMask(sX,sY,sZ) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VWrmsNormMask (',FN_VWrmsNormMask(sX,sY,sZ),' /= ',fac,')'
  else
     print *, 'PASSED test -- FN_VWrmsNormMask'
  end if

  ! test FN_VMin
  call FN_VConst(2.d0, sX)
  X%data(Nvar,N) = -2.d0
  if (dabs(FN_VMin(sX) + 2.d0) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VMin (',FN_VMin(sX),' /= -2.d0)'
  else
     print *, 'PASSED test -- FN_VMin'
  end if

  ! test FN_VWL2Norm
  call FN_VConst(-0.5d0, sX)
  call FN_VConst(0.5d0, sY)
  fac = dsqrt(1.d0*N*Nvar)*0.25d0
  if (dabs(FN_VWL2Norm(sX,sY) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VWL2Norm (',FN_VWL2Norm(sX,sY),' /= ',fac,')'
  else
     print *, 'PASSED test -- FN_VWL2Norm'
  end if

  ! test FN_VL1Norm
  call FN_VConst(-1.d0, sX)
  fac = 1.d0*N*Nvar
  if (dabs(FN_VL1Norm(sX) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VL1Norm (',FN_VL1Norm(sX),' /= ',fac,')'
  else
     print *, 'PASSED test -- FN_VL1Norm'
  end if

  ! test FN_VCompare
  call FN_VConst(-1.d0, sZ)
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 3)
        if (loc == 0)  X%data(i,j) = 0.d0
        if (loc == 1)  X%data(i,j) = -1.d0
        if (loc == 2)  X%data(i,j) = -2.d0
     end do
  end do
  call FN_VCompare(1.d0, sX, sZ)
  failure = .false.
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 3)
        if ((loc == 0) .and. (Z%data(i,j) /= 0.d0))  failure = .true.
        if ((loc == 1) .and. (Z%data(i,j) /= 1.d0))  failure = .true.
        if ((loc == 2) .and. (Z%data(i,j) /= 1.d0))  failure = .true.
     end do
  end do
  if (failure) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VCompare'
  else
     print *, 'PASSED test -- FN_VCompare'
  end if

  ! test FN_VInvTest
  call FN_VConst(0.5d0, sX)
  call FN_VConst(0.d0, sZ)
  failure = (FN_VInvTest(sX, sZ) == 0)
  if ((check_ans(2.d0, 1.d-14, Nvar, N, sZ) /= 0) .or. failure) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VInvTest Case 1'
  else
     print *, 'PASSED test -- FN_VInvTest Case 1'
  end if

  failure = .false.
  call FN_VConst(0.d0, sZ)
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 2)
        if (loc == 0)  X%data(i,j) = 0.d0
        if (loc == 1)  X%data(i,j) = 0.5d0
     end do
  end do
  if (FN_VInvTest(sX, sZ) == 1)  failure = .true.
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 2)
        if ((loc == 0) .and. (Z%data(i,j) /= 0.d0))  failure = .true.
        if ((loc == 1) .and. (Z%data(i,j) /= 2.d0))  failure = .true.
     end do
  end do
  if (failure) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VInvTest Case 2'
  else
     print *, 'PASSED test -- FN_VInvTest Case 2'
  end if

  ! test FN_VConstrMask
  call FN_VConst(-1.d0, sZ)
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 7)
        if (loc == 0) then  ! y = -2, test for < 0
           Y%data(i,j) = -2.d0
           X%data(i,j) = -2.d0
        end if
        if (loc == 1) then ! y = -1, test for <= 0
           Y%data(i,j) = -1.d0
           X%data(i,j) = -1.d0
        end if
        if (loc == 2) then ! y = -1, test for == 0
           Y%data(i,j) = -1.d0
           X%data(i,j) = 0.d0
        end if
        if (loc == 3) then ! y = 0, no test
           Y%data(i,j) = 0.d0
           X%data(i,j) = 0.5d0
        end if
        if (loc == 4) then ! y = 1, test for == 0
           Y%data(i,j) = 1.d0
           X%data(i,j) = 0.d0
        end if
        if (loc == 5) then ! y = 1, test for >= 0
           Y%data(i,j) = 1.d0
           X%data(i,j) = 1.d0
        end if
        if (loc == 6) then ! y = 2, test for > 0
           Y%data(i,j) = 2.d0
           X%data(i,j) = 2.d0
        end if
     end do
  end do
  failure = .false.
  if (FN_VConstrMask(sY, sX, sZ) /= 1) then
     failure = .true.
  end if
  if ((check_ans(0.d0, 1.d-14, Nvar, N, sZ) /= 0) .or. failure) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VConstrMask Case 1'
  else
     print *, 'PASSED test -- FN_VConstrMask Case 1'
  end if

  call FN_VConst(-1.d0, sZ)
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 5)
        if (loc == 0) then  ! y = -2, test for < 0
           Y%data(i,j) = -2.d0
           X%data(i,j) = 2.d0
        end if
        if (loc == 1) then ! y = -1, test for <= 0
           Y%data(i,j) = -1.d0
           X%data(i,j) = 1.d0
        end if
        if (loc == 2) then ! y = 0, no test
           Y%data(i,j) = 0.d0
           X%data(i,j) = 0.5d0
        end if
        if (loc == 3) then ! y = 1, test for >= 0
           Y%data(i,j) = 1.d0
           X%data(i,j) = -1.d0
        end if
        if (loc == 4) then ! y = 2, test for > 0
           Y%data(i,j) = 2.d0
           X%data(i,j) = -2.d0
        end if
     end do
  end do
  failure = .false.
  if (FN_VConstrMask(sY, sX, sZ) /= 0) then
     failure = .true.
  end if
  do j = 1,N
     do i = 1,Nvar
        loc = mod((j-1)*Nvar + i - 1, 5)
        if (loc == 2) then
           if (Z%data(i,j) /= 0.d0) failure = .true.
        else
           if (Z%data(i,j) /= 1.d0) failure = .true.
        end if
     end do
  end do
  if (failure) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VConstrMask Case 2'
  else
     print *, 'PASSED test -- FN_VConstrMask Case 2'
  end if

  ! test FN_VMinQuotient
  call FN_VConst(2.d0, sX)
  call FN_VConst(2.d0, sY)
  X%data(Nvar,N) = 0.5d0
  fac = 0.25d0
  if (dabs(FN_VMinQuotient(sX,sY) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VMinQuotient Case 1'
  else
     print *, 'PASSED test -- FN_VMinQuotient Case 1'
  end if

  call FN_VConst(2.d0, sX)
  call FN_VConst(0.d0, sY)
  fac = 1.d307
  if (dabs(FN_VMinQuotient(sX,sY) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VMinQuotient Case 2'
  else
     print *, 'PASSED test -- FN_VMinQuotient Case 2'
  end if

  ! test FN_VWSqrSumLocal
  call FN_VConst(-1.d0, sX)
  call FN_VConst(0.5d0, sY)
  fac = 0.25d0*N*Nvar
  if (dabs(FN_VWSqrSumLocal(sX,sY) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VWSqrSumLocal (',FN_VWSqrSumLocal(sX,sY),' /= ',fac,')'
  else
     print *, 'PASSED test -- FN_VWSqrSumLocal'
  end if

  ! test FN_VWSqrSumMaskLocal
  call FN_VConst(-1.d0, sX)
  call FN_VConst(0.5d0, sY)
  call FN_VConst(1.d0, sZ)
  Z%data(Nvar,N) = 0.d0
  fac = 0.25d0*(N*Nvar-1)
  if (dabs(FN_VWSqrSumMaskLocal(sX,sY,sZ) - fac) > 1.d-14) then
     fails = fails + 1
     print *, '>>> FAILED test -- FN_VWSqrSumMaskLocal (',FN_VWSqrSumMaskLocal(sX,sY,sZ),' /= ',fac,')'
  else
     print *, 'PASSED test -- FN_VWSqrSumMaskLocal'
  end if

  ! free vectors
  call FN_VDestroy(sU)
  call FN_VDestroy(sV)
  call FN_VDestroy(sW)
  call FN_VDestroy(sX)
  call FN_VDestroy(sY)
  call FN_VDestroy(sZ)

  ! print results
  if (fails > 0) then
     print '(a,i3,a)', 'FAIL: FNVector module failed ',fails,' tests'
     stop 1
  else
     print *, 'SUCCESS: FNVector module passed all tests'
  end if
  print *, '  '

end program main


! This appears to be a F2003 specific construct, so gfortran will
! not handle it properly UNLESS using F2003 mode (-std=f2003).
! and given the correct .f03 filename suffix.
PROGRAM ASSOCIATE_EXAMPLE
     REAL :: X,A
     A = 0.4

   ! The associate construct is F2003 specific
     ASSOCIATE ( Z => A )
          X = Z
     END ASSOCIATE

END PROGRAM ASSOCIATE_EXAMPLE


module prim
  use, intrinsic :: iso_c_binding
  integer :: nx = 10
  integer :: ny = 10
  integer :: nz = 10
  implicit none

  type prim_type
     real(c_double), allocatable, dimension(:,:,:) :: v1
     real(c_double), allocatable, dimension(:,:,:) :: v2
     real(c_double), allocatable, dimension(:,:,:) :: v3
   contains
     procedure :: setup => setup_prim
  end type prim_type

contains
  subroutine setup_prim(prim_data)
    class(prim_type), intent(OUT) :: prim_data

    allocate(prim_data%v1(nx,ny,nz))
    allocate(prim_data%v2(nx,ny,nz))
    allocate(prim_data%v3(nx,ny,nz))

  end subroutine setup_prim

end module prim


program if
!Una sentencia if..then
i = 2
if (i .eq. 2) then
print *, "i == 2"
end if

!i = 3
if (i .eq. 3) then
	print *, "i == 3"
else
	print *, "i /= 3"
end if

end program if


! should pass 'implicit-none' test with no cases detected.
program example2
  implicit none
  print *, f(1)
contains
  integer function f(x)
    ! IMPLICIT NONE is not necessary here as it inherits the previous
    ! one, however we do provide 'implicit-none-all' functionality
    ! just in case you want to check all program units regardless of
    ! the inheritance rule.
    integer :: x
    f = 1 + x
  end function f
end program example2


! I think this is using F03 syntax for procedure pointers.
! So this might really be a FFortran 2003 test code
! (syntax fails for gfortran, but is part of the gfortran test suite).

PROGRAM test_prog

  PROCEDURE(add), POINTER :: forig, fset

  forig => add

  CALL set_ptr(forig,fset)

  if (forig(1,2) /= fset(1,2)) call abort()

CONTAINS

 SUBROUTINE set_ptr(f1,f2)
   PROCEDURE(add), POINTER :: f1, f2
    f2 => f1
  END SUBROUTINE set_ptr

  FUNCTION add(a,b)
    INTEGER :: a,b,add
    add = a+b

  END FUNCTION add

END PROGRAM test_prog


! { dg-do compile }

! PR fortran/45776
! Variable definition context checks related to IO.

! Contributed by Daniel Kraft, d@domob.eu.

module m
  implicit none

  integer, protected :: a
  character(len=128), protected :: str
end module m

program main
  use :: m
  integer, parameter :: b = 42
  integer :: x
  character(len=128) :: myStr

  namelist /definable/ x, myStr
  namelist /undefinable/ x, a

  ! These are invalid.
  read (myStr, *) a ! { dg-error "variable definition context" }
  read (myStr, *) x, b ! { dg-error "variable definition context" }
  write (str, *) 5 ! { dg-error "variable definition context" }
  read (*, nml=undefinable) ! { dg-error "contains the symbol 'a' which may not" }

  ! These are ok.
  read (str, *) x
  write (myStr, *) a
  write (myStr, *) b
  print *, a, b
  write (*, nml=undefinable)
  read (*, nml=definable)
  write (*, nml=definable)
end program main


           program demo_spread
           implicit none
             integer :: a = 1, b(2) = [ 1, 2 ]
             write(*,*) spread(a, 1, 2)            ! "1 1"
             write(*,*) spread(b, 1, 2)            ! "1 1 2 2"
           end program demo_spread


module kind_values

use, intrinsic :: iso_fortran_env, only: real32, real64, real128
use, intrinsic :: iso_c_binding,   only: c_float, c_double

implicit none

! Written by Jens Bloch Helmers, 19. march 1995.

! This module defines some kind values.
!----------------------------------------------------------------------------

integer, private, parameter :: single = kind(0.0e0)
integer, private, parameter :: double = kind(0.0d0)

integer, public, parameter :: kind_swd_c = c_double        ! C interface
integer, public, parameter :: kind_swd_interface = real64  ! Fortran interface
integer, public, parameter :: kind_swd_internal = real64   ! Internal computations

end module kind_values


program loop
implicit none
integer :: i
	do i = 50,70,2
		print *,i
end do
end program loop


!==============================================================================!
  subroutine Template_Subroutine(<arguments>)
!------------------------------------------------------------------------------!
!   Template for a subroutine/function.                                        !
!                                                                              !
!   Keep all coding and commenting up to eighty columns wide.  If you go       !
!   beyond that, the code will look terrible when printed, and you do want     !
!   to analyze printed text for better concentration.                          !
!                                                                              !
!   Also note that indentation is by 2!  Subroutine name starts at column 2,   !
!   coding starts in the same column, and next levels of indentation at 4,     !
!   6, 8, etc.                                                                 !
!                                                                              !
!   Note that there is a separator before the function header (this section)   !
!   and line which introduces modules.  If not, the characters "[Modules]"     !
!   get cramped with text written here.                                        !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  ...
  ..
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  ...
  ..
!---------------------------------[Interfaces]---------------------------------!
  ...
  ..
!----------------------------------[Calling]-----------------------------------!
  ...
  ..
!-----------------------------------[Locals]-----------------------------------!
  integer              :: i, j, k
  character(len=80)    :: name_in
  real, dimension(5,5) :: small_matrix
!------------------------------[Local parameters]------------------------------!
  integer, parameter :: BIG = 1000
!==============================================================================!

  !----------------------------------------------!
  !                                              !
  !   First level comments are framed with one   !
  !   extra empty row above and below text       !
  !                                              !
  !----------------------------------------------!

  !------------------------------------------------------!
  !                                                      !
  !   First level comments are written like sentences,   !
  !   first word capital, and can spread over several    !
  !   lines like this very commet.                       !
  !                                                      !
  !------------------------------------------------------!

  !---------------------------!
  !   Second level comments   !
  !---------------------------!

  !-----------------------------------------------------!
  !     First and second level comments have frames     !
  !   three spaces thick to the left and to the right   !
  !-----------------------------------------------------!
                                                    !123! <- see thickness

  ! Third level comments follow sentence rules, starting with upper-case letter

  ! If a third level comment is too long ...
  ! ... it can spread over several lines ...
  ! ... with dots for continuation.

  do s = 1, grid % n_faces     ! fourth level comments start with small letters

    c1 = grid % faces_c(1, s)  ! they are too small to qualify as sentences
    c2 = grid % faces_c(1, s)  ! keep them two columns apart from the last ...
                               ! column with the code

  end do

  end subroutine


Module cte

  Implicit None

  Real, Parameter :: sigma = 1.0
  Real  :: Dens, BoxL, RCut, dRMax
  Integer :: N, NStep, ISave, IPrint, IRatio
  Real, Parameter :: Dim = 2.0         !Dimensiones (2D o 3D)
  Real, Allocatable, Dimension(:) :: X, Y

End Module cte


! { dg-do compile }
! { dg-options "-std=f2003 -Wall -Wno-conversion" }
! Support F2008's c_sizeof()
!
USE ISO_C_BINDING
integer(C_SIZE_T) :: i
i = c_sizeof(i)           ! { dg-warning "Fortran 2008" }
end


module star
  implicit none
contains
  subroutine printstar(n)
    integer, intent(in) :: n
    integer :: i

    print*, ('*', i = 1,n)
  end subroutine printstar
end module star


      MODULE LA_PRECISION
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  DEFINES SINGLE AND DOUBLE PRECISION PARAMETERS, SP AND DP.
!  THESE VALUES ARE COMPILER DEPENDENT.
!
      INTEGER, PARAMETER :: SP=KIND(1.0), DP=KIND(1.0D0)
!
      END MODULE LA_PRECISION

      MODULE LA_AUXMOD
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
      INTERFACE
         SUBROUTINE    ERINFO(LINFO, SRNAME, INFO, ISTAT)
            CHARACTER( LEN = * ), INTENT(IN)              :: SRNAME
            INTEGER             , INTENT(IN)              :: LINFO
            INTEGER             , INTENT(OUT), OPTIONAL   :: INFO
            INTEGER             , INTENT(IN), OPTIONAL    :: ISTAT
         END SUBROUTINE ERINFO
         INTEGER FUNCTION LA_WS_GELS( VER, M, N, NRHS, TRANS )
             CHARACTER( LEN=1 ), INTENT(IN) :: TRANS, VER
             INTEGER, INTENT(IN) :: M, N, NRHS
         END FUNCTION LA_WS_GELS
         INTEGER FUNCTION LA_WS_GELSS( VER, M, N, NRHS )
          CHARACTER(LEN=1), INTENT(IN) :: VER
          INTEGER, INTENT(IN) :: M, N, NRHS
         END FUNCTION LA_WS_GELSS
      END INTERFACE
!
      CONTAINS
!
      LOGICAL FUNCTION LSAME( CA, CB )
!
!  PURPOSE
!  =======
!
!  LSAME  TESTS IF CA IS THE SAME LETTER AS CB REGARDLESS OF CASE.
!
!  PARAMETERS
!  ==========
!
!  CA      (INPUT) CHARACTER*1
!  CB      (INPUT) CHARACTER*1
!          CHARACTERS TO BE COMPARED.
!
!  .. SCALAR ARGUMENTS ..
      CHARACTER*1, INTENT(IN) :: CA, CB
!  .. PARAMETERS ..
      INTEGER, PARAMETER      :: IOFF=32
!  .. LOCAL SCALARS ..
      INTEGER                 :: INTA, INTB, ZCODE
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC                  ICHAR
!
!  .. EXECUTABLE STATEMENTS ..
!
!  TEST IF THE CHARACTERS ARE EQUAL
!
      LSAME = CA == CB
!
!  NOW TEST FOR EQUIVALENCE
!
      IF( .NOT.LSAME )THEN
!
!     USE 'Z' RATHER THAN 'A' SO THAT ASCII CAN BE DETECTED ON PRIME
!     MACHINES, ON WHICH ICHAR RETURNS A VALUE WITH BIT 8 SET.
!     ICHAR('A') ON PRIME MACHINES RETURNS 193 WHICH IS THE SAME AS
!     ICHAR('A') ON AN EBCDIC MACHINE.
!
         ZCODE = ICHAR( 'Z' )
!
         INTA = ICHAR( CA )
         INTB = ICHAR( CB )
!
         IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 )THEN
!
!        ASCII IS ASSUMED - ZCODE IS THE ASCII CODE OF EITHER LOWER OR
!        UPPER CASE 'Z'.
!
            IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
            IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
!
         ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 )THEN
!
!        EBCDIC IS ASSUMED - ZCODE IS THE EBCDIC CODE OF EITHER LOWER OR
!        UPPER CASE 'Z'.
!
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.                         &
!    &       INTA.GE.145 .AND. INTA.LE.153 .OR.                         &
     &       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.                         &
     &       INTB.GE.145 .AND. INTB.LE.153 .OR.                         &
     &       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
!
         ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 )THEN
!
!        ASCII IS ASSUMED, ON PRIME MACHINES - ZCODE IS THE ASCII CODE
!        PLUS 128 OF EITHER LOWER OR UPPER CASE 'Z'.
!
            IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
         ENDIF
         LSAME = INTA == INTB
      ENDIF
      END FUNCTION LSAME

      END MODULE LA_AUXMOD


      subroutine mem_layout(arg)
        implicit none
        integer, dimension(:,:), intent(inout) :: arg

        integer i,j

        ! iterate through the array 2nd dimension first, in 'C' order
        do i = 1, size(arg, 1)
            do j = 1, size(arg, 2)
                print *, arg(i,j)
            enddo
        enddo

      end subroutine mem_layout


! { dg-do run }
! PR fortran/67885
! Original code contributed by Gerhard Steinmetz
! gerhard dot steinmetz dot fortran at t-online dot de
program p
   block
      integer, parameter :: a(2) = [1, 2]
      integer :: x(2)
      x = a
      if (x(1) /= 1) STOP 1
   end block
end


!
! program_do
!
! Example of a parallel do directive with private clause
!
! 2008
! Creation: A. Muller, 2008

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

!$omp PARALLEL DO private(i) private(b)
      do 10 i=1,N
         a(i)=i
         B(i)=i
         f=0
 10   continue

      print *,'A=',a
      print *,'B=',b

      end


program cond_01
implicit none
if (.false.) error stop
if (1 == 2) error stop
if (1 /= 1) error stop
if (1 > 2) error stop
if (1 >= 2) error stop
if (2 < 1) error stop
if (2 <= 1) error stop
end


      subroutine induc2(a,n)
      real a(2*n)

      j = 1

      do 100 i = 1, n
         a(j) = a(j)+a(j-1)
         j = j + 2
 100  continue

      end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!-----------------------------------------------------------------------
!
! The functions and subroutines below are based on GSLIB fortran 77 code,
! version 2.0
!-----------------------------------------------------------------------

!*********************************************************************************
!     Subroutines for GSLIB datafile
!*********************************************************************************
subroutine read_header(datafl, comment_line, varnames, nvar, error, maxnvar)
    ! read gslib data file header
    ! returns comment line, number of variables and variable names
    ! use this with the functions read_ndata (to get the number of lines in the file)
    ! and read_data to get an array with data
    ! warning: all values are converted to real and character variables are not admissible

    ! parameters:
    !--------------------------------
    ! input parameters:
    !    datafl :  file path
    !    maxnvar:  maximum number of variables (use a large number, ex. 500 or 500)
    !
    ! output:
    !    comment_line : string with comments in the datafile
    !    varnames     : string array with varnames
    !    nvar         : integer with number of variables in the file
    !    error        : integer with error code

    implicit none

    integer, intent(in) :: maxnvar
    character(len=500), intent(in)  :: datafl
    character(len=500), intent(out) :: comment_line
    character, intent(out) , dimension (maxnvar,80) ::  varnames

    integer,   intent(out)  ::  nvar

    character(len=80) str

    !error variable
    integer,   intent(out) ::   error

    integer i, j, lin

    error=0
    lin=1

    ! open the file and read in the header
    open(unit=lin,file=datafl(1:500), status='old')

    read(lin,'(a500)',err=99) comment_line(1:500)
    read(lin,*,err=99)       nvar

    if (nvar > maxnvar) then
        goto 97
    end if

    do i=1,nvar
        read(lin,'(a80)',err=99) str
        do j=1,80
            varnames(i,j)= str(j:j)
        end do
    end do

    close(lin)

    return

    97 error=97 !'nvar > maxnvar'
    close(lin)
    return

    99 error=99 !'error in data file!'
    close(lin)
    return

end subroutine read_header

subroutine read_ndata(datafl, nvar, maxdat, error)
    ! find out number of rows in a gslib file
    ! use this with the functions read_header (to get nvar and varnames)
    ! and read_data to get an array with data
    ! warning: all values are converted to real and character variables are not admissible

    ! parameters:
    !--------------------------------
    ! input parameters:
    !    datafl :  file path
    !    nvar   :  integer with number of variables in the file
    !
    ! output:
    !    maxdat : integer with number of rows in the datafile.
    !    error  : integer with error code

    implicit none

    character(len=250), intent(in)  :: datafl
    integer,  intent(in)  :: nvar
    integer, intent(out) ::  maxdat
    real*8, dimension (nvar) ::  var

    !error variable
    integer,   intent(out) ::   error

    integer i, j, lin

    error=0
    lin=1

    ! Open the file and read number of data points
    open(lin,file=datafl,status='OLD')
    read(lin,*,err=99) !comment line
    read(lin,*,err=99) !nvar
    do i=1,nvar        !varnames
        read(lin,*)
    end do

    !initialize number of data to zero
    maxdat = 0
    2 read(lin,*,end=4,err=99) (var(j),j=1,nvar)
        maxdat = maxdat + 1
        go to 2
    4 continue

    close(lin)

    return

    99 error=99 !'ERROR in data file!'
    close(lin)
    return

end subroutine read_ndata

subroutine read_data(datafl, nvar, maxdat, table, error)
    ! read data in gslib file
    ! returns array with data (REAL format)
    ! use this with the functions read_header (to get nvar and varnames)
    ! and read_ndata to get the number of rows
    ! warning: all values are converted to real and character variables are not admissible

    ! parameters:
    !--------------------------------
    ! input parameters:
    !    datafl :  file path
    !    nvar   :  integer with number of variables in the file
    !    maxdat :  integer with number of rows in the datafile.
    !
    ! output:
    !    table    :  real array (maxdat,nvar) with data
    !    varnames :  string array with varnames
    !    error        : integer with error code

    IMPLICIT NONE

    character(len=250), intent(in)  :: datafl
    integer,  intent(in)  :: nvar, maxdat
    real*8, intent(out), dimension (maxdat,nvar) ::  table
    real*8, dimension (nvar) ::  var

    !error variable
    integer,   intent(out) ::   error

    integer i, j, lin

    error=0
    lin=1

    ! Open the file and read number of data points
    open(lin,file=datafl,status='OLD')
    read(lin,*,err=99) !comment line
    read(lin,*,err=99) !nvar
    do i=1,nvar        !varnames
        read(lin,*)
    end do

    ! Now, read the data
    do i=1, maxdat
        read(lin,*,end=94,err=99) (var(j),j=1,nvar)
        table(i,:)=var
    end do

    close(lin)

    return

    94  error=94 !'unexpected end of line'
    close(lin)
    return

    99 error=99 !'ERROR in data file!'
    close(lin)
    return

end subroutine read_data


program ifProg
    implicit none

    integer :: ab = 100
    integer ::as=100
    integer::a=10
    integer :: marks = 78
    if(a<20) then
        print*,"a<20"
    end if
    print*,"Value of a = ",a

    !named if block
    marks=90.0
    gr:if(marks>90.0) then
        print *,"Grade A"
    end if gr

        ass:if(as<20) then
            print*,"as<20"
        else
            print*,"as>20"
        end if ass

   ! check the logical condition using if statement
   if( ab == 10 ) then

      ! if condition is true then print the following
      print*, "Value of a is 10"

   else if( ab == 20 ) then

      ! if else if condition is true
      print*, "Value of a is 20"

   else if( ab == 30 ) then

      ! if else if condition is true
      print*, "Value of a is 30"

   else

      ! if none of the conditions is true
      print*, "None of the values is matching"

   end if

   print*, "exact value of a is ", ab

   select case (marks)

      case (91:100)
         print*, "Excellent!"

      case (81:90)
         print*, "Very good!"

      case (71:80)
         print*, "Well done!"

      case (61:70)
         print*, "Not bad!"

      case (41:60)
         print*, "You passed!"

      case (:40)
         print*, "Better try again!"

      case default
         print*, "Invalid marks"

   end select
   print*, "Your marks is ", marks
end program


C     This program tests initialization of variables
      program main
      implicit none

      integer :: x = 12345
      real :: y = 3.1416

      write (*,10) x, y
 10   format (I6,X,f8.4)
      stop
      end program main


! { dg-do compile }
! { dg-options "-frange-check" }
! PR fortran/27997
!
! Range check on array-constructors with typespec.

PROGRAM test
  IMPLICIT NONE

  INTEGER(KIND=4) :: arr(1)
  arr = (/ INTEGER(KIND=4) :: HUGE(0_8) /) ! { dg-error "overflow converting" }
END PROGRAM test


!*****************************************************************************************
!> author: Jacob Williams
!
!  Kind definitions for the other modules.

module kind_module

    use iso_fortran_env

    implicit none

    ! default real precision:

    !integer, parameter, public :: wp = real32   !! single precision
    integer, parameter, public :: wp = real64    !! double precision [default]
    !integer, parameter, public :: wp = real128  !! quad precision

    ! Error Macros

    integer, parameter, public :: VALUE_ERROR = 100
    integer, parameter, public :: TIMEOUT_ERROR = 200
    integer, parameter, public :: FIT_ERROR = 300

    ! Value Macros

    real, parameter, public :: LARGE_VALUE = 1e+09

end module kind_module
!*****************************************************************************************


Program	Ejemplo06
!Aqui probaremos la definicion y uso de una Subroutine
! que se inlcuye en el mismo archivo, fuera del programa

Implicit None

	Call LeeX

End Program Ejemplo06

Subroutine LeeX()

  Real(8) :: X
	 Print *,'Por favor ingrese un Numero Real'
	 Read *, X
	 Print *, X

End Subroutine LeeX


program test
      logical :: flag1, flag2, flag3, flag4, flag5, flag6
      integer :: a = 5
      integer :: b = 5
      flag1 = (a .eq. b)
      flag2 = (a .ne. b)
      flag3 = a .lt. b
      flag4 = (a .le. b)
      flag5 = a .gt. b
      flag6 = a .ge. b

      end program test


module iso_fortran_env ! user-defined
implicit none
integer, parameter :: output_unit = -1
end module iso_fortran_env
!
module sin_mod
implicit none
contains
function sin(x) result(y)
! override sin() intrinsic
real, intent(in) :: x
real             :: y
y = 10.0
end function sin
end module sin_mod
!
module m
implicit none
contains
subroutine replacements()
use iso_fortran_env
use sin_mod
print*,"in replacements()"
print*,"output_unit =",output_unit
print*,"sin(0.0) =",sin(0.0)
print*
end subroutine replacements
!
subroutine normal()
use, intrinsic :: iso_fortran_env, only: output_unit
intrinsic :: sin ! optional since sin_mod not USEd
print*,"in normal()"
print*,"output_unit =",output_unit
print*,"sin(0.0) =",sin(0.0)
end subroutine normal
end module m
!
program test_intrinsic
use m, only: replacements, normal
implicit none
call replacements()
call normal()
end program test_intrinsic
!  in replacements()
!  output_unit =          -1
!  sin(0.0) =   10.0000000
!
!  in normal()
!  output_unit =           6
!  sin(0.0) =   0.00000000


  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: nthreads=4
  INTEGER :: id

  CALL OMP_SET_NUM_THREADS(nthreads)

!$OMP PARALLEL private(id)
  id = OMP_GET_THREAD_NUM()
  PRINT *, "Hello World from thread = ", id, &
     &         " with ", OMP_GET_NUM_THREADS(), " threads"
!$OMP END PARALLEL
  PRINT *, "all done, with hopefully ",nthreads," threads"

  END PROGRAM MAIN


module foo
  private
  integer :: a
  public :: setA
  integer :: b
contains
  subroutine setA(v)
    integer, intent(in) :: v
    a = v
  end subroutine setA
end module foo


program test_errors
use, intrinsic:: iso_fortran_env, only: int64, int32, real32, real64, stderr=>error_unit
use nc4fortran, only: netcdf_file

implicit none (type, external)

call test_wrong_type()
print *, "OK: wrong type read"

contains

subroutine test_wrong_type()
integer :: u
type(netcdf_file) :: h
character(*), parameter :: filename = 'bad.nc'

call h%open(filename, action='w')
call h%write('real32', 42.)
call h%close()

call h%open(filename, action='r')
call h%read('real32', u)
if (u /= 42) error stop 'test_wrong_type: did not coerce real to integer'
call h%close()

end subroutine test_wrong_type

end program


program files
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: nr_values = 10, io_error = 1
    character(len=50), parameter :: filename = 'data.txt'
    integer :: unit_nr, stat, i
    character(len=1024) :: msg
    real :: x = 5.1

    open (newunit=unit_nr, file=filename, access='sequential', &
          action='write', status='replace', form='formatted', &
          iostat=stat, iomsg=msg)
    if (stat /= 0) then
        write (unit=error_unit,fmt='(A)') msg
        stop io_error
    end if
    do i = 0, nr_values - 1
        write (unit=unit_nr, fmt='(F8.1)', iostat=stat, iomsg=msg) i*x
        if (stat /= 0) then
            write (unit=error_unit,fmt='(A)') msg
            stop io_error
        end if
    end do
    close (unit_nr, iostat=stat, iomsg=msg)
    if (stat /= 0) then
        write (unit=error_unit,fmt='(A)') msg
        stop io_error
    end if

end program files


MODULE complex_class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC :: complex_ob   ! This will be the name we instantiate
   PRIVATE
   REAL :: re               ! Real part
   REAL :: im               ! Imaginary part
END TYPE complex_ob

! Now add methods
CONTAINS

   !(Insert methods here)
   SUBROUTINE temp(x)
   REAL :: x
   x = 1.
   END SUBROUTINE temp

END MODULE complex_class


! { dg-do compile }
! PR19589
! Logical objects/values with differing type kinds were being rejected in
! data statements.
program logical_data_1
  logical(kind=4) :: a
  logical(kind=8) :: b
  data a, b /.true., .false./
end program


C File: test_module_10.f
C Purpose: This program shows how importing a module into a subprogram
C          (rather than the main program) limits visibility of the
C          imported variables to the subprogram and does not affect
C          variables in the main program.
C
C Compile and run this program as follows:
C
C    gfortran -c test_module_10.f     # << this will create a file "mymod10.mod"
C    gfortran test_module_10.f        # << this will create a file "a.out"
C
C The output generated by this program is (see test_module_10-OUT.txt):
C
C  123   234   345  1110  1110  1110
C  987   876   765  1110  1110  1110

!-------------------------------------------------------------------------------
      module mymod10
      implicit none
      integer :: x = 123, y = 234, z = 345
      end module mymod10

!-------------------------------------------------------------------------------
      subroutine f(u, v, w, a, b, c)
      use mymod10      ! << importing into a subprogram
      implicit none
      integer u, v, w, a, b, c

      a = u+x
      b = v+y
      c = w+z

 10   format(6(I5,X))
      write (*,10) x,y,z,a,b,c
      end subroutine f

!-------------------------------------------------------------------------------
      program main
      implicit none

      integer :: x, y, z, p, q, r  ! << Note that the variables x, y, z
                                   !    are not affected by those in mymod10
      x = 987
      y = 876
      z = 765

      call f(x, y, z, p, q, r)

 10   format(6(I5,X))
      write (*,10) x,y,z,p,q,r

      stop
      end program main
!-------------------------------------------------------------------------------


! RUN: %python %S/test_errors.py %s %flang_fc1
! Errors when comparing LOGICAL operands

program testCompare
  logical flag1, flag2
  if (flag1 .eqv. .false.) continue
  if (flag1 .neqv. flag2) continue
  !ERROR: LOGICAL operands must be compared using .EQV. or .NEQV.
  if (flag1 .eq. .false.) continue
  !ERROR: LOGICAL operands must be compared using .EQV. or .NEQV.
  if (flag1 .ne. flag2) continue
end program testCompare


      program em
      n1 = 10
      n2 = 30
      call add(n1, n2, n)
      print *,n
      do 100 i = n1,n
         u = 1.
 100  continue
      end
c
      subroutine add(m1, m2, m)
      m = m1 + m2
      return
      end


!************************************************************
!
!  This example shows how to read and write variable-length
!  datatypes to an attribute.  The program first writes two
!  variable-length integer arrays to the attribute then
!  closes the file.  Next, it reopens the file, reads back
!  the data, and outputs it to the screen.
!
!  This file is intended for use with HDF5 Library version 1.8
!  with --enable-fortran2003
!
! ************************************************************/

PROGRAM main

  USE HDF5
  USE ISO_C_BINDING

  IMPLICIT NONE

  CHARACTER(LEN=21), PARAMETER :: filename  = "h5ex_t_vlenatt_F03.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset   = "DS1"
  CHARACTER(LEN=2) , PARAMETER :: attribute = "A1"
  INTEGER, PARAMETER :: LEN0 = 3
  INTEGER, PARAMETER :: LEN1 = 12

  INTEGER(HID_T)  :: file, filetype, memtype, space, dset, attr ! Handles
  INTEGER :: hdferr
  INTEGER(HSIZE_T), DIMENSION(1:2)   :: maxdims
  INTEGER :: i, j

  ! vl data
  TYPE vl
     INTEGER, DIMENSION(:), POINTER :: data
  END TYPE vl
  TYPE(vl), DIMENSION(:), ALLOCATABLE :: ptr

  TYPE hvl_t
     INTEGER(size_t) :: len ! Length of VL data (in base type units)
     TYPE(C_PTR) :: p       ! Pointer to VL data
  END TYPE hvl_t
  TYPE(hvl_t), DIMENSION(1:2), TARGET :: wdata ! Array of vlen structures
  TYPE(hvl_t), DIMENSION(1:2), TARGET :: rdata ! Pointer to vlen structures

  INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/2/)
  INTEGER, DIMENSION(:), POINTER :: ptr_r
  TYPE(C_PTR) :: f_ptr

  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! Initialize variable-length data.  wdata(1) is a countdown of
  ! length LEN0, wdata(2) is a Fibonacci sequence of length LEN1.
  !
  wdata(1)%len = LEN0
  wdata(2)%len = LEN1

  ALLOCATE( ptr(1:2) )
  ALLOCATE( ptr(1)%data(1:wdata(1)%len) )
  ALLOCATE( ptr(2)%data(1:wdata(2)%len) )

  DO i=1, wdata(1)%len
     ptr(1)%data(i) = wdata(1)%len - i + 1 ! 3 2 1
  ENDDO
  wdata(1)%p = C_LOC(ptr(1)%data(1))

  ptr(2)%data(1:2) = 1
  DO i = 3, wdata(2)%len
     ptr(2)%data(i) = ptr(2)%data(i-1) + ptr(2)%data(i-2) ! (1 1 2 3 5 8 etc.)
  ENDDO
  wdata(2)%p = C_LOC(ptr(2)%data(1))

  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create variable-length datatype for file and memory.
  !
  CALL H5Tvlen_create_f(H5T_STD_I32LE, filetype, hdferr)
  CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, hdferr)
  !
  ! Create dataset with a null dataspace.
  !
  CALL H5Screate_f(H5S_NULL_F, space, hdferr)
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr)
  CALL H5Sclose_f(space, hdferr)  !
  ! Create dataspace.
  !
  CALL h5screate_simple_f(1, dims, space, hdferr)

  !
  ! Create the attribute and write the variable-length data to it
  !
  CALL H5Acreate_f(dset, attribute, filetype, space, attr, hdferr)

  f_ptr = C_LOC(wdata(1))
  CALL H5Awrite_f(attr, memtype, f_ptr, hdferr)

  !
  ! Close and release resources.  Note the use of H5Dvlen_reclaim
  ! removes the need to manually deallocate the previously allocated
  ! data.
  !
  CALL h5dvlen_reclaim_f(memtype, space, H5P_DEFAULT_F, f_ptr, hdferr)
  CALL h5aclose_f(attr , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL H5Tclose_f(filetype, hdferr)
  CALL H5Tclose_f(memtype, hdferr)
  CALL h5fclose_f(file , hdferr)

  DEALLOCATE(ptr)
  !
  ! Now we begin the read section of this example.

  !
  ! Open file and dataset, and attribute.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f(file, dataset, dset, hdferr)
  CALL h5aopen_f(dset, attribute, attr, hdferr)
  !
  ! Get dataspace and allocate memory for array of vlen structures.
  ! This does not actually allocate memory for the vlen data, that
  ! will be done by the library.
  !
  CALL H5Aget_space_f(attr, space, hdferr)
  CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, hdferr)
  !
  ! Create the memory datatype.
  !
  CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, hdferr)
  !
  ! Read the data.
  !
  f_ptr = C_LOC(rdata(1))
  CALL H5Aread_f(attr, memtype, f_ptr, hdferr)
  !
  ! Output the variable-length data to the screen.
  !
  DO i = 1, dims(1)
     WRITE(*,'(A,"(",I0,"):",/,"{")', ADVANCE="no") attribute,i
     CALL c_f_pointer(rdata(i)%p, ptr_r, [rdata(i)%len] )
     DO j = 1, rdata(i)%len
        WRITE(*,'(1X,I0)', ADVANCE='no') ptr_r(j)
        IF ( j .LT. rdata(i)%len) WRITE(*,'(",")', ADVANCE='no')
     ENDDO
     WRITE(*,'( " }")')
  ENDDO
  !
  ! Close and release resources.
  !
  CALL h5dvlen_reclaim_f(memtype, space, H5P_DEFAULT_F, f_ptr, hdferr)
  CALL h5aclose_f(attr , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL H5Tclose_f(memtype, hdferr)
  CALL h5fclose_f(file , hdferr)

END PROGRAM main


! RUN: %S/test_errors.sh %s %t %flang -fopenmp
! OpenMP Version 4.5
! 2.15.4.1 copyin Clause
! A list item that appears in a copyin clause must be threadprivate.
! Named variables appearing in a threadprivate common block may be specified
! It is not necessary to specify the whole common block.

program omp_copyin

  integer :: a(10), b(10)
  common /cmn/ j, k

  !$omp threadprivate(/cmn/)

  j = 20
  k = 10

  !$omp parallel copyin(/cmn/)
  a(:5) = k
  b(:5) = j
  !$omp end parallel

  j = j + k
  k = k * j

  !$omp parallel copyin(j, k)
  a(6:) = j
  b(6:) = k
  !$omp end parallel

  print *, a, b

end program omp_copyin


PROGRAM hello
  USE OMP_LIB
  IMPLICIT NONE
  PRINT *, "Hello in different sections"
!$OMP PARALLEL
!$OMP SECTIONS
    !$OMP SECTION
    PRINT *, "Hello ", omp_get_thread_num()
    !$OMP SECTION
    PRINT *, "Olá ", omp_get_thread_num()
    !$OMP SECTION
    PRINT *, "Hola", omp_get_thread_num()
    !$OMP SECTION
    PRINT *, "Heghlu'meH QaQ jajvam", omp_get_thread_num()
!$OMP END SECTIONS
!$OMP END PARALLEL
END PROGRAM hello


! simple_linkedlist.f90 --
!     Very basic implementation of linked lists
!     Main purpose: illustrate the use of templates
!
!     Real and real, dimension(:), allocatable
!
!     Pure module implementation
!
!!template linked_lists
!!    implicit none
!!
!!    private
!!    public :: linked_list_def
!!
!!    type linked_list_def
!!        type(linked_list_def), pointer :: next
!!        type(data_type)                :: data
!!    contains
!!        ! To do
!!        procedure :: print => print_list
!!    end type linked_list_def
!!contains
!!    ! To do
!!
!!    print_list uses print_item
!!end template
!!
module linked_list_reals
    use_template linked_lists, real => data_type, linked_list_real => linked_list_def
    implicit none

    private
    public :: linked_list_real

    type linked_list_real
        type(linked_list_real), pointer :: next => null()
        real                            :: data
    contains
        procedure :: add => add_to_list
        procedure :: print => print_list
    end type linked_list_real
contains
subroutine add_to_list( list, data )
    class(linked_list_real), intent(inout) :: list
    real, intent(in)                      :: data

    type(linked_list_real), pointer       :: item

    allocate( item )
    item%data = data

    item%next => list%next
    list%next => item
end subroutine add_to_list

subroutine print_list( list, lun )
    class(linked_list_real), intent(in), target :: list
    integer, intent(in)                        :: lun

    type(linked_list_real), pointer            :: item
    integer                                    :: i

    i = 1
    item => list
    do
        call print_item( lun, i, item%data )

        if ( associated( item%next ) ) then
            i = i + 1
            item => item%next
        else
            exit
        endif
    enddo
end subroutine print_list

subroutine print_item( lun, indx, data )
    integer, intent(in) :: lun
    integer, intent(in) :: indx
    real, intent(in)    :: data

    write( lun, '(i5,a,e14.5)' ) indx, ':', data
end subroutine print_item
end module linked_list_reals

module linked_list_multi_reals
    use_template linked_lists, real, dimension(:), allocatable => data_type, linked_list_multireal => linked_list_def
contains
subroutine print_item( lun, indx, data )
    integer, intent(in) :: lun
    integer, intent(in) :: indx
    real, intent(in)    :: data

    write( lun, '(i5,a,5e14.5,/,(6x,5e14.5))' ) indx, ':', data
end subroutine print_item
end module linked_list_multireals

program test_linked_list
    use linked_list_reals

    type(linked_list_real) :: mylist
    integer                :: i
    real                   :: value

    do i = 1,10
        value = 0.1 * i
        call mylist%add( value )
    enddo

    open( 20, file = 'test_linked_list.out' )
    call mylist%print(20)
end program test_linked_list


program main
    use MPIClass

    type(MPI_) :: mpiobj
    real(8),allocatable::glo(:),loc(:)
    integer :: From
    real(8)::val

    From=0
    call mpiobj%start()
    allocate(glo(mpiobj%petot),loc(1) )
    glo(:)=dble(mpiobj%MyRank)
    loc(:)=0.0d0

    call mpiobj%read(val,Msg="Input real value")
    call mpiobj%Bcast(From=From,val=val)
    print *, mpiobj%MyRank,"/",mpiobj%petot,val
    call mpiobj%barrier()
    call mpiobj%AlltoAll(sendobj=glo(:),sendcount=1,&
        recvobj=glo(:),recvcount=1)
    print *, glo(:)
    call mpiobj%end()

end program main


program test
  integer :: a(3), r(3)
  integer :: i, j

  do j = 1, 3
    !do i = 1, 3
      a(j) = j
    !end do
  end do

  print *, a
  r = reshape(a, (/3/))
  print *, r
end program test


! { dg-do run }

! PR fortran/43829
! Scalarization of reductions.
! Test that inlined sum is correct.

! We can't check for the absence of temporary arrays generated on the run-time
! testcase, as inlining is disabled at -Os, so it will fail in that case.
! Thus, the test is splitted into two independant files, one checking for
! the absence of temporaries, and one (this one) checking that the code
! generated remains valid at all optimization levels.
include 'inline_sum_1.f90'


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! PR 34145 - the length of the string should be simplified to one,
! no library call for string comparison is necessary.
program main
  character (len=5) :: c
  integer(kind=8) :: i
  i = 3
  c(i:i) = 'a'
  c(i+1:i+1) = 'b'
  if (c(i:i) /= 'a') call abort ()
  if (c(i+1:i+1) /= 'b') call abort ()
end program main
! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


! RUN: %python %S/test_errors.py %s %flang_fc1
subroutine s1
  implicit integer(a-c)
  !ERROR: More than one implicit type specified for 'c'
  implicit real(c-g)
end

subroutine s2
  implicit integer(a-c)
  implicit real(8)(d)
  !ERROR: More than one implicit type specified for 'a'
  implicit integer(f), real(a)
end


      PROGRAM main
      USE OMP_LIB
      IMPLICIT NONE

      INCLUDE 'mpif.h'

      INTEGER :: myPE, totPEs, ierr, tid, nthreads

      CALL MPI_INIT(ierr)

      CALL MPI_COMM_RANK(MPI_COMM_WORLD, myPE, ierr)
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD, totPEs, ierr)

!$OMP PARALLEL PRIVATE(tid, nthreads)
      tid = OMP_GET_THREAD_NUM()
      nthreads = OMP_GET_NUM_THREADS()

!      write(*,100) "Hello from thread ",tid," of ",         &
!     &            nthreads," in rank ",myPE," of ",totPEs
!$OMP END PARALLEL

  100 FORMAT(a,i3,a,i3,a,i3,a,i3)

      CALL MPI_FINALIZE(ierr)

      END


!--------------------------------------------------------------------------
!> @details Defines type/class for delayed neutron precursor data
!
!--------------------------------------------------------------------------
module Mod_DelayPrecursorData

    use global_parameters_M, only : sp, dp

    implicit none

    private

    public :: delayPrecData

    !---Define the type
    type :: delayPrecData

        character(len=10) :: isotopeName
        real(sp), allocatable, dimension(:) :: decayConst
        real(dp), allocatable, dimension(:) :: groupBeta

    contains
    !--- Define type bound subroutine
    procedure, pass(self) :: writeOutDelay

    end type delayPrecData

    contains

    !--------------------------------------------------------------------------
    !> @details Defines type/class for delayed neutron precursor data
    !> @param[in] unit_num: unit number to write data to
    !--------------------------------------------------------------------------

    subroutine writeOutDelay(self, unit_num)

        implicit none

        !---Dummy variables
        class(delayPrecData), intent(in) :: self
        integer, intent(in) :: unit_num

        !---Local variables
        integer :: i, j

        write(unit_num, *) "Fissile Isotope:", self % isotopeName
        do i = 1, size(self % decayConst)

            write(unit_num, '(a, i2)')  "Group ", i
            write(unit_num, '(a, f6.3)') "Decay constant [1/s]:      ", self % decayConst(i)
            write(unit_num, '(a, f7.5)') "Delayed fraction (Beta_i): ", self % groupBeta(i)

        end do
        write(unit_num, '(a)') '--------------------------------------------------------------------------------'

    end subroutine writeOutDelay

end module Mod_DelayPrecursorData


! RUN: %python %S/test_errors.py %s %flang_fc1
subroutine s
  !ERROR: 'a' does not follow 'b' alphabetically
  implicit integer(b-a)
end


module foo
  public
  integer, private :: a
  integer :: b
contains
  subroutine setA(v)
    integer, intent(in) :: v
    a = v
  end subroutine setA
end module foo


program test_update

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

  implicit none

  double precision, parameter :: expected_time = 0.333333d0

  type (bmi_heat) :: m
  double precision :: time

  status = m%initialize(config_file)
  status = m%update()
  status = m%get_current_time(time)
  status = m%finalize()

  print *, time
  print *, expected_time

  if (abs(time - expected_time) > tolerance) then
     stop BMI_FAILURE
  end if
end program test_update


module one_module
  implicit none
  interface
    module function one()
    end function
  end interface
end module

submodule(one_module) one_submodule
  implicit none
contains
  integer module function one()
    one = 1
  end function
end submodule

use one_module
print *,one()," is not ",1
end


!*****************************************************************************************
!> author: Jacob Williams
!  license: BSD
!
!  Test of reading and writing CSV files.

    program csv_test

    use csv_module
    use iso_fortran_env, only: wp => real64

    implicit none

    call csv_test_1()
    call csv_write_test()
    call csv_read_test()

    contains

        subroutine csv_test_1()

        implicit none

        type(csv_file) :: f
        type(csv_file) :: f2
        integer :: i !! counter
        integer :: k !! counter
        character(len=30),dimension(:),allocatable :: header  !! the header
        character(len=30),dimension(:,:),allocatable :: csv_data  !! the data from the file as strings
        real(wp),dimension(:),allocatable :: x  !! for getting a real vector from a csv file
        logical :: status_ok  !! error flag
        integer,dimension(:),allocatable :: itypes  !! array of variable types in the file
        integer :: ifile !! file counter
        character(len=30),dimension(:),allocatable :: names
        character(len=:),allocatable :: file

        character(len=*),dimension(2),parameter :: files_to_test = ['test.csv          ',&
                                                                    'test_2_columns.csv']
        character(len=*),dimension(4),parameter :: dirs_to_try = ['../files/', &
                                                                  './files/ ', &
                                                                  './       ', &
                                                                  '         ']

        write(*,*) ''
        write(*,*) '============================'
        write(*,*) ' csv_test_1 '
        write(*,*) '============================'
        write(*,*) ''

        do ifile = 1, size(files_to_test)

            ! a hack to get it to work with all the different build systems
            ! no matter the working directory
            do k = 1, size(dirs_to_try)
                file = trim(dirs_to_try(k))//trim(files_to_test(ifile))
                if (file_exists(file)) exit ! found it
            end do
            write(*,*) 'read file: '//trim(file)

            ! read the file:
            if (ifile==1) then
                call f%read(file,header_row=1,status_ok=status_ok)
            else
                ! also skip a row
                call f%read(file,header_row=1,skip_rows=[2],status_ok=status_ok)
            end if

            if (.not. status_ok) then
                error stop 'could not open file'
            end if

            write(*,*) ''
            write(*,*) 'File: '//trim(files_to_test(ifile))
            ! print the header and type info:
            call f%get_header(header,status_ok)
            call f%variable_types(itypes,status_ok)
            write(*,*) ''
            write(*,'(*(A30,1X,A4))') 'Header', 'Type'
            do i=1,size(header)
                write(*,'(*(A30,1X,I4))') header(i), itypes(i)
            end do

            write(*,*) ''
            write(*,*) 'print all the rows:'

            call f%get(csv_data,status_ok)
            do i=1,size(csv_data,1)
                write(*,'(*(A30,1X))') csv_data(i,:)
            end do

            write(*,*) ''
            write(*,*) 'get some vectors:'
            if (ifile==1) then
                write(*,*) ''
                write(*,*) 'age:'
                call f%get(3,x,status_ok)
                write(*,'(F6.3,1x)',advance='NO') x
                write(*,*) ''
            else
                write(*,*) ''
                write(*,*) 'name:'
                call f%get(2,names,status_ok)
                write(*,'(A10,1x)',advance='NO') names
                write(*,*) ''
            end if

        end do

        ! now test creating a CSV:
        call f2%initialize(enclose_strings_in_quotes=.false.,verbose=.true.)
        call f2%open('test2.csv',n_cols=4,status_ok=status_ok)
        if (status_ok) then
            call f2%add(['x','y','z','t'])    ! add header as vector
            call f2%next_row()
            call f2%add(1.0_wp)  ! add as scalars
            call f2%add(2.0_wp)
            call f2%add(3.0_wp)
            call f2%add(.true.)
            call f2%next_row()
            call f2%add([4.0_wp,5.0_wp,6.0_wp],real_fmt='(F5.3)') ! add as vectors
            call f2%add(.false.)
            call f2%next_row()
        end if
        call f2%close(status_ok)

        end subroutine csv_test_1

        subroutine csv_write_test()

        implicit none

        type(csv_file) :: f
        logical :: status_ok

        write(*,*) ''
        write(*,*) '============================'
        write(*,*) ' csv_write_test '
        write(*,*) '============================'
        write(*,*) ''

        ! open the file
        call f%open('test_write.csv',n_cols=4,status_ok=status_ok)
        if (status_ok) then

            ! add header
            call f%add(['x','y','z','t'])
            call f%next_row()

            ! add some data:
            call f%add([1.0_wp,2.0_wp,3.0_wp],real_fmt='(F5.3)')
            call f%add(.true.)
            call f%next_row()
            call f%add([4.0_wp,5.0_wp,6.0_wp],real_fmt='(F5.3)')
            call f%add(.false.)
            call f%next_row()

            ! finished
            call f%close(status_ok)

        else
            error stop 'could not open file'
        end if

        end subroutine csv_write_test

        subroutine csv_read_test()

        implicit none

        type(csv_file) :: f
        character(len=30),dimension(:),allocatable :: header
        real(wp),dimension(:),allocatable :: x,y,z
        logical,dimension(:),allocatable :: t
        logical :: status_ok
        integer,dimension(:),allocatable :: itypes

        write(*,*) ''
        write(*,*) '============================'
        write(*,*) ' csv_read_test '
        write(*,*) '============================'
        write(*,*) ''

        ! read the file
        call f%read('test_write.csv',header_row=1,status_ok=status_ok)

        if (status_ok) then

            ! get the header and type info
            call f%get_header(header,status_ok)
            call f%variable_types(itypes,status_ok)

            ! get some data
            call f%get(1,x,status_ok)
            call f%get(2,y,status_ok)
            call f%get(3,z,status_ok)
            call f%get(4,t,status_ok)

            write(*,*) 'x=',x
            write(*,*) 'y=',y
            write(*,*) 'z=',z
            write(*,*) 't=',t

            ! destroy the file
            call f%destroy()

        else
            error stop 'could not open file'
        end if

        end subroutine csv_read_test

        function file_exists(file) result(exists)

        !! returns True if the file exists

        implicit none
        character(len=*),intent(in) :: file
        logical :: exists

        integer :: istat

        inquire(file=file,exist=exists,iostat=istat)

        exists = exists .and. istat==0 ! just in case?

        end function file_exists

    end program csv_test
!*****************************************************************************************


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
subroutine foo(a)
  integer, dimension (4) :: a
  integer :: n

  n = 3
  where (a(:n-1) .ne. 0)
    a(:n-1) = 1
  endwhere
end subroutine
! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }


! { dg-do compile }

! PR fortran/35723
! Check that a dummy-argument array with non-restricted subscript is
! rejected and some more reference-checks.

PROGRAM main
  IMPLICIT NONE
  CALL test (5, (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), "0123456789" )

CONTAINS

  SUBROUTINE test (n, arr, str)
    IMPLICIT NONE
    INTEGER :: n, arr(:)
    CHARACTER(len=10) :: str

    INTEGER :: i = 5
    INTEGER :: ok1(arr(n)), ok2(LEN_TRIM (str(3:n)))
    INTEGER :: ok3(LEN_TRIM("hello, world!"(2:n)))
    INTEGER :: wrong1(arr(i)) ! { dg-error "'i' cannot appear" }
    INTEGER :: wrong2(LEN_TRIM (str(i:n))) ! { dg-error "'i' cannot appear" }
    INTEGER :: wrong3(LEN_TRIM ("hello, world!"(i:n))) ! { dg-error "'i' cannot appear" }
  END SUBROUTINE test

END PROGRAM main


program test
  integer ::  a(4)
  integer:: c,d,e,f
  c = 4
  d = 5
  e = 6
  f = 7
  a = (/ c,d,e,f /)
  print *,a
end program test


! { dg-do compile }
! { dg-options "-Warray-temporaries" }

subroutine t1(n1,n2, gfft, ufft)
  implicit none
  integer :: n1, n2, i
  real :: gfft(n1,n2), ufft(n2)
  DO i=1, n1
     gfft(i,:)=gfft(i,:)*ufft(i)
  END DO
end subroutine t1


      program llamar_modulo
        use mi_primer_modulo
        implicit none

        real :: matriz(10,10)
        matriz(:,:)=variable_publica
        call imprimir_matriz_A(matriz)
      end program llamar_modulo


subroutine hello_fortran() bind(C, name="hello_fortran")
	integer, dimension(3) :: current
	call idate(current)
	if (current(2) == 12) then
		write(*, '(a)') "Merry Christmas from Fortran!"
	else
		write(*, '(a)') "Hello from Fortran!"
	end if
end subroutine