    program demo_iostat
    implicit none
    real               :: value
    integer            :: ios
    character(len=256) :: message
       write(*,*)'Begin entering numeric values, one per line'
       do
          read(*,*,iostat=ios,iomsg=message)value
          if(ios.eq.0)then
             write(*,*)'VALUE=',value
          elseif( is_iostat_end(ios) ) then
             stop 'end of file. Goodbye!'
          else
             write(*,*)'ERROR:',ios,trim(message)
          endif
          !
       enddo
    end program demo_iostat


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

!*****************************************************************
!*****************************************************************

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


program allocation_test

 implicit none

 real,dimension(:),allocatable :: vector
 real,dimension(:,:),allocatable :: matrix

 integer,parameter :: n = 100 !size to allocate

 allocate(vector(n))   !allocate a vector
 allocate(matrix(n,n)) !allocate a matrix
 deallocate(vector)    !deallocate a vector
 deallocate(matrix)    !deallocate a matrix

end program allocation_test


!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s

!CHECK-LABEL: define internal void @main_callee
!CHECK: call void @llvm.dbg.declare(metadata i64* %callee_ptr, metadata [[CALLEE_PTR:![0-9]+]]
!CHECK: [[CALLEE_PTR]] = !DILocalVariable(name: "callee_ptr"
!CHECK-SAME: arg: 1

program main
  pointer (ptr, b)
  integer :: a(10), b(10)
  a = (/1,2,3,4,5,6,7,8,9,10/)
  call callee(ptr)
  print *, b
  print *, a
  print *, ptr
contains
  subroutine callee(callee_ptr)
    pointer(callee_ptr, callee_pte)
    integer, allocatable :: callee_pte(:)
    allocate (callee_pte(10))
    callee_pte = (/5,4,5,4,5,4,5,4,5,4/)
    print *,callee_ptr
    print *,callee_pte
  end subroutine
end


program clauses

   implicit none
   integer, parameter :: n=10
   integer :: i, a, b, c, d
   character(len=*), parameter :: layout_1 = "(a, 4(a, i12))"
   character(len=*), parameter :: layout_2 = "(a, i4, 4(a, i12))"

   a = 1
   b = 1
   c = 1
   d = 1

   print layout_1, "BEFORE", " SHARED:", a, " PRIVATE:", b, " FIRSTPRIVATE:", c, " LASTPRIVATE:", d

!$OMP PARALLEL DO SHARED(a) PRIVATE(b) FIRSTPRIVATE(c) LASTPRIVATE(d)
   do i = 1, n

      if (n<11) print layout_2, "I=", i, " SHARED:", a, " PRIVATE:", b, " FIRSTPRIVATE:", c, " LASTPRIVATE:", d
      a = a + i
      b = b + i
      c = c + i
      d = d + i
   end do
!$OMP END PARALLEL DO

   print layout_1, "AFTER ", " SHARED:", a, " PRIVATE:", b, " FIRSTPRIVATE:", c, " LASTPRIVATE:", d

end program clauses


PROGRAM main

  USE MPI
  IMPLICIT NONE
  INTEGER :: rank, nproc, rank_right, rank_left, rank_recv, errcode
  INTEGER, DIMENSION(2) :: requests

  CALL MPI_INIT(errcode)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, errcode)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, errcode)

  rank_left = rank -1
  !Ranks run from 0 to nproc-1, so wrap the ends around to make a loop
  IF(rank_left == -1) rank_left = nproc-1
  rank_right = rank + 1
  IF(rank_right == nproc) rank_right = 0

  CALL MPI_Isend(rank, 1, MPI_INTEGER, rank_right, 100, MPI_COMM_WORLD, &
      requests(1), errcode)
  CALL MPI_Irecv(rank_recv, 1, MPI_INTEGER, rank_left, 100, MPI_COMM_WORLD, &
      requests(2), errcode)

  !We don't actually care about sending being finished here, but may as well
  !wait for both
  CALL MPI_Waitall(2, requests, MPI_STATUSES_IGNORE, errcode)

  PRINT ('("Rank ",I3," has received value ", I3, " from rank ", I3)'), &
      rank, rank_recv, rank_left

  CALL MPI_FINALIZE(errcode)
END PROGRAM main


! chk_format_static --
!     Check: does the compiler check formats statically or dynamically?
!
program chk_format_static
    implicit none

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

    errors = .false.

    write( *, '(a)' ) 'Checking what happens with incorrect formats ...'

    write( *, '(a,f12.4)', iostat = ierr ) 'Integer as real:', x
    if ( ierr /= 0 ) then
        errors = .true.
        write( *, '(a)' ) 'Wrong format (F12.4 for integer) causes a run-time error'
    endif

    write( *, '(a,i12)', iostat = ierr ) 'Real as integer:', y
    if ( ierr /= 0 ) then
        errors = .true.
        write( *, '(a)' ) 'Wrong format (I12 for real) causes a run-time error'
    endif

    if ( .not. errors ) then
        write( *, '(a)' ) 'Selecting a wrong format doesn''t cause a detectable run-time error'
    endif
end program chk_format_static


program types_10
implicit none

integer :: i, j

save i
save :: j

contains

    subroutine f(i)
    integer, intent(in) :: i
    integer, save :: j
    j = i
    end subroutine

    subroutine g(i)
    integer, intent(in) :: i
    integer :: j
    save j
    j = i
    end subroutine

    subroutine h(i)
    integer, intent(in) :: i
    integer :: j
    save
    j = i
    end subroutine

end program


! Módulo com algumas utilidades para matrizes/vetores
module utils
    implicit none

    type Results
        sequence
        double precision :: erro
        double precision :: tdecomp, tforw, tback
    end type Results

contains
    ! Imprime um vetor em formato de coluna
    subroutine pvec(v)
        double precision, intent(in) :: v(:)

        integer :: n, i

        n = size(v)

        do i = 1, n
            print *, v(i)
        end do
    end subroutine pvec

    ! Imprime uma matriz
    subroutine pmatriz(A)
        double precision, intent(in) :: A(:, :)

        integer :: s(2), i

        s = shape(A)

        do i = 1, s(1)
            print *, A(i, :)
        end do
    end subroutine pmatriz

    subroutine swap(a, b)
        double precision, intent(inout) :: a, b

        double precision :: tmp

        tmp = a
        a = b
        b = tmp
    end subroutine swap

end module utils


program intrinsic_string_functions
implicit none
character (len=*), parameter :: num = "0123456789"
! SCAN, VERIFY, INDEX, and LEN_TRIM are elemental
! scan(x,y) returns first position of x found in y
print*,scan(["2022-Jan","abcdefgh"],num) ! 1 0
print*,scan("2022-Jan",num,back=.true.) ! 4 -- counting from the back
! verify(x,y) returns first position in x NOT found in y
print*,verify(string=["13579","18Dec"],set=num) ! 0 3
! index(x,y) returns first position of substring y in x
print*,index(num,substring=["34","35"]) ! 4 0
! adjustl/adjustr remove leading/trailing spaces and pad to preserve LEN
! in format string, note that '''' prints single apostrophe
print "(*(:,'''',a,''' '))", adjustl(" abc"),adjustr("abc ")
! 'abc ' ' abc'
print*,len_trim(["abc "," abc"]) ! 3 4
! LEN function is not elemental, and elements of character
! array have the same len
print*,len(["abc "," abc"]) ! 4
end program intrinsic_string_functions


!---------------------------------------------------------------------
!
!  Example of syntax errors
!
!---------------------------------------------------------------------

program syntaxErrors

    IMPLICIT NONE

    INTEGER :: myInput

    ! Ask for a input value
    write(*, '(A)', ADVANCE = "NO") "Enter a integer value:  "
    read(*,*) myInput  ! This variable name is not the correct one!

    IF myInput < 0 THEN   ! "IF (myInput < 0 ) THEN" is the correct syntax!
        write(*, *) "The input value negative"
    ELSE
        write(*, *) "The input value positive"
    END IF

end program syntaxErrors


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

! CHECK-LABEL: func @_QPsub() {
subroutine sub()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QPasubroutine() {
subroutine AsUbRoUtInE()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QPfoo() -> f32 {
function foo()
  real(4) :: foo
  real :: pi = 3.14159
! CHECK: }
end function

! CHECK-LABEL: func @_QPfunctn() -> f32 {
function functn
  real, parameter :: pi = 3.14
! CHECK: }
end function

module testMod
contains
  ! CHECK-LABEL: func @_QMtestmodPsub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QMtestmodPfoo() -> f32 {
  function foo()
    real(4) :: foo
  ! CHECK: }
  end function
end module

! CHECK-LABEL: func @_QPfoo2()
function foo2()
  real(4) :: foo2
contains
  ! CHECK-LABEL: func @_QFfoo2Psub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QFfoo2Pfoo() {
  subroutine foo()
  ! CHECK: }
  end subroutine
end function

! CHECK-LABEL: func @_QPsub2()
subroutine sUb2()
contains
  ! CHECK-LABEL: func @_QFsub2Psub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QFsub2Pfoo() {
  subroutine Foo()
  ! CHECK: }
  end subroutine
end subroutine

module testMod2
contains
  ! CHECK-LABEL: func @_QMtestmod2Psub()
  subroutine sub()
  contains
    ! CHECK-LABEL: func @_QMtestmod2FsubPsubsub() {
    subroutine subSub()
    ! CHECK: }
    end subroutine
  end subroutine
end module

module color_points
  interface
    module subroutine draw()
    end subroutine
    module function erase()
      integer(4) :: erase
    end function
  end interface
end module color_points

! We don't handle lowering of submodules yet.  The following tests are
! commented out and "CHECK" is changed to "xHECK" to not trigger FileCheck.
!submodule (color_points) color_points_a
!contains
!  ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aPsub() {
!  subroutine sub
!  end subroutine
!  ! xHECK: }
!end submodule
!
!submodule (color_points:color_points_a) impl
!contains
!  ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplPfoo()
!  subroutine foo
!    contains
!    ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplFfooPbar() {
!    subroutine bar
!    ! xHECK: }
!    end subroutine
!  end subroutine
!  ! xHECK-LABEL: func @_QMcolor_pointsPdraw() {
!  module subroutine draw()
!  end subroutine
!  !FIXME func @_QMcolor_pointsPerase() -> i32 {
!  module procedure erase
!  ! xHECK: }
!  end procedure
!end submodule

! CHECK-LABEL: func @_QPshould_not_collide() {
subroutine should_not_collide()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QQmain() {
program test
! CHECK: }
contains
! CHECK-LABEL: func @_QFPshould_not_collide() {
subroutine should_not_collide()
! CHECK: }
end subroutine
end program

! CHECK-LABEL: func @omp_get_num_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads"} {
function omp_get_num_threads() bind(c)
! CHECK: }
end function

! CHECK-LABEL: func @get_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads_1"} {
function omp_get_num_threads_1() bind(c, name ="get_threads")
! CHECK: }
end function

! CHECK-LABEL: func @bEtA() -> f32 attributes {fir.sym_name = "_QPalpha"} {
function alpha() bind(c, name =" bEtA ")
! CHECK: }
end function

! CHECK-LABEL: func @bc1() attributes {fir.sym_name = "_QPbind_c_s"} {
subroutine bind_c_s() Bind(C,Name='bc1')
  ! CHECK: return
end subroutine bind_c_s

! CHECK-LABEL: func @_QPbind_c_s() {
subroutine bind_c_s()
  ! CHECK: fir.call @_QPbind_c_q() : () -> ()
  ! CHECK: return
  call bind_c_q
end

! CHECK-LABEL: func @_QPbind_c_q() {
subroutine bind_c_q()
  interface
    subroutine bind_c_s() Bind(C, name='bc1')
    end
  end interface
  ! CHECK: fir.call @bc1() : () -> ()
  ! CHECK: return
  call bind_c_s
end

! Test that BIND(C) label is taken into account for ENTRY symbols.
! CHECK-LABEL: func @_QPsub_with_entries() {
subroutine sub_with_entries
! CHECK-LABEL: func @bar() attributes {fir.sym_name = "_QPsome_entry"} {
 entry some_entry() bind(c, name="bar")
! CHECK-LABEL: func @_QPnormal_entry() {
 entry normal_entry()
! CHECK-LABEL: func @some_other_entry() attributes {fir.sym_name = "_QPsome_other_entry"} {
 entry some_other_entry() bind(c)
end subroutine

! CHECK-LABEL: fir.global internal @_QFfooEpi : f32 {


! Rice test
! kind type is lost in translation
program lost_kind_type_1
implicit none
  integer, parameter :: i8  = selected_int_kind(16)

  call g(1_i8)  ! translated as call g(1), causing a compile error due to type mismatch.

contains

  subroutine g(r)
  implicit none
    integer(kind = i8) :: r
  end subroutine

end program


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

! cette fonction appelle une fonction python

subroutine sommef(f, n, s)
    ! Calcule la somme (f(i), i=1,n)
    external f
    integer, intent(in) :: n
    real, intent(out) :: s
    s = 0.0
    do i = 1, n
        s = s + f(i)
    end do
end subroutine sommef


program main

  integer :: i, j
  real :: a, b

  do concurrent(i=1:10:2, j=3:13)
     a = 1
     b = a
  end do

end program


program main
   use iso_c_binding

   integer(c_int8_t)    :: i8t
   integer(c_int16_t)   :: i16t
   integer(c_int32_t)   :: i32t
   integer(c_int64_t)   :: i64t

   integer(c_int)       :: ii
   integer(c_short)     :: is
   integer(c_long)      :: il
   integer(c_long_long) :: ill

   integer(c_size_t)    :: isizet
   integer(c_intmax_t)  :: imax
   integer(c_intptr_t)  :: iptrt
   integer(c_ptrdiff_t) :: iptrdifft

   real(c_float)        :: rf
   real(c_double)       :: rd
   real(c_long_double)  :: rld

end program


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

module mem
    implicit none
    real(8), dimension(:), allocatable :: farray

contains

    subroutine init( n ) !Allocation du tableau farray
        integer, intent(in) :: n
        allocate(farray(n))
    end subroutine init

    subroutine test_array()
        print*, allocated(farray), size(farray)
    end subroutine test_array

    subroutine give_array(a) !!!!!!!!!!!!!!!!!!!!!!!!!MARCHE PO
        real(8), dimension(:), allocatable :: a
        allocate(a(100))
    end subroutine give_array

end module mem


! { dg-do compile }
! Test the fix for PR40158, where the errro message was not clear about scalars.
!
! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
!
  implicit none
  integer :: i(4,5),j
  i = 0
  call sub1(i)
  call sub1(j)  ! { dg-error "rank-1 and scalar" }
  call sub2(i)  ! { dg-error "scalar and rank-2" }
  call sub2(j)
  print '(5i0)', i
contains
  subroutine sub1(i1)
    integer :: i1(*)
    i1(1) = 2
  end subroutine sub1
  subroutine sub2(i2)
    integer :: i2
    i2 = 2
  end subroutine sub2
end


MODULE timer_class1
!
!  This module implements a timer class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/27/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare constants
INTEGER,PARAMETER :: DBL = SELECTED_REAL_KIND(p=14)

! Type definition
TYPE,PUBLIC :: timer   ! This will be the name we instantiate

   ! Instance variables
   PRIVATE
   REAL(KIND=DBL) :: saved_time  ! Saved time in ms

!CONTAINS

   ! Bound procedures
!   PROCEDURE :: start_timer ==> start_timer_sub
!   PROCEDURE :: elapsed_time ==> elapsed_time_fn

END TYPE timer

! Restrict access to actual procedure names
!PRIVATE :: start_timer_sub, elapsed_time_fn

! Now add methods
CONTAINS

   SUBROUTINE start_timer_sub(this)
   !
   ! Subroutine to get and save the initial time
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(timer) :: this              ! Timer object

   ! Declare local variables
   INTEGER,DIMENSION(8) :: value     ! Time value array

   ! Get time
   CALL date_and_time ( VALUES=value )
   this%saved_time = 86400.D0 * value(3) + 3600.D0 * value(5) &
                   + 60.D0 * value(6) + value(7) + 0.001D0 * value(8)

   END SUBROUTINE start_timer_sub

   REAL FUNCTION elapsed_time_fn(this)
   !
   ! Function to calculate elapsed time
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(timer) :: this              ! Timer object

   ! Declare local variables
   INTEGER,DIMENSION(8) :: value     ! Time value array
   REAL(KIND=DBL) :: current_time    ! Current time (ms)

   ! Get time
   CALL date_and_time ( VALUES=value )
   current_time = 86400.D0 * value(3) + 3600.D0 * value(5) &
                + 60.D0 * value(6) + value(7) + 0.001D0 * value(8)

   ! Get elapsed time in seconds
   elapsed_time_fn = current_time - this%saved_time

   END FUNCTION elapsed_time_fn

END MODULE timer_class1


module m_Parameters
  use m_TypeDef
  use m_LogInfo
  implicit none
  private

  ! file units for different routines
  integer,parameter,public:: d_read_Param_unit= 1001
  integer,parameter,public:: d_LogInfo_unit   = 1002
  integer,parameter,public:: d_readyMesh_unit = 1003

  integer,parameter,public:: xm_dir=1  ! x- direction
  integer,parameter,public:: xp_dir=2  ! x+ direction
  integer,parameter,public:: ym_dir=3  ! y- direction
  integer,parameter,public:: yp_dir=4  ! y+ direction
  integer,parameter,public:: zm_dir=5  ! z- direction
  integer,parameter,public:: zp_dir=6  ! z+ direction

  logical, public,save:: IsUxConst
  real(RK),public,save:: ubulk

  ! mesh options
  real(RK),public,save::yly
  integer,public,save::nxpOld,nypOld,nzpOld     ! Old grid point number in three directions
  integer,public,save::nxcOld,nycOld,nzcOld     ! Old grid center number in three directions. nxc = nxp-1
  integer,public,save::nxpNew,nypNew,nzpNew     ! New grid point number in three directions
  integer,public,save::nxcNew,nycNew,nzcNew     ! New grid center number in three directions. nxc = nxp-1
  integer,public,save::StretTypeOld,istretOld,nyUniformOld
  integer,public,save::StretTypeNew,istretNew,nyUniformNew
  real(RK),public,save::cStretOld,yUniformOld,cStretNew,yUniformNew

  ! Boundary conditions
  !  0 : periodic conditions for all variables
  ! -1: no slip for three velocity components and ZERO GRADIENT for pressure field
  ! -2: free slip for three velocity components and ZERO GRADIENT for pressure field
  integer,parameter,public::BC_PERIOD =  0
  integer,parameter,public::BC_NSLIP  = -1
  integer,parameter,public::BC_FSLIP  = -2
  integer, public,dimension(6):: BcOption
  real(RK),public,dimension(6):: uxBcValue
  real(RK),public,dimension(6):: uyBcValue
  real(RK),public,dimension(6):: uzBcValue

  character(64),public,save:: RunName      ! Run name
  character(64),public,save:: Res_Dir      ! Result directory
  character(64),public,save:: OldRestartName
  character(64),public,save:: NewRestartName
  integer,public,save:: Cmd_LFile_Freq= 1  ! report frequency in the terminal
  integer,public,save:: LF_file_lvl   = 5  ! logfile report level
  integer,public,save:: LF_cmdw_lvl   = 3  ! terminal report level

  ! Decomp2d options
  integer,public,save:: p_row,p_col

  public:: ReadAndInitParameters,DumpReadedParam
contains

  !******************************************************************
  ! InitParameters
  !******************************************************************
  subroutine ReadAndInitParameters(chFile)
    implicit none
    character(*),intent(in)::chFile

    ! locals
    integer:: nUnitFile,myistat
    NAMELIST/BasicParam/nxpOld,nypOld,nzpOld,nxpNew,nypNew,nzpNew,BcOption,uxBcValue,uyBcValue,uzBcValue,  &
                        RunName,Res_Dir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col,yly,IsUxConst,  &
                        ubulk,OldRestartName,NewRestartName,StretTypeOld,istretOld,cStretOld,nyUniformOld, &
                        yUniformOld,StretTypeNew,istretNew,cStretNew,nyUniformNew,yUniformNew

    nUnitFile = d_read_Param_unit
    open(unit=nUnitFile, file=chFile, status='old',form='formatted',IOSTAT=myistat )
    if(myistat/=0) call MainLog%CheckForError(ErrT_Abort,"ReadAndInitParameters","Open file wrong: "//trim(chFile))
    read(nUnitFile,nml=BasicParam)
    close(nUnitFile)

    nxcOld =nxpOld-1; nycOld=nypOld-1; nzcOld=nzpOld-1
    nxcNew =nxpNew-1; nycNew=nypNew-1; nzcNew=nzpNew-1
    if(p_row*p_col /= nproc) call MainLog%CheckForError(ErrT_Abort,"ReadAndInitParameters","p_row*p_col /= nproc")
  end subroutine ReadAndInitParameters

  !******************************************************************
  ! DumpReadedParam
  !******************************************************************
  subroutine DumpReadedParam()
    implicit none

    ! locals
    NAMELIST/BasicParam/nxpOld,nypOld,nzpOld,nxpNew,nypNew,nzpNew,BcOption,uxBcValue,uyBcValue,uzBcValue,  &
                        RunName,Res_Dir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col,yly,IsUxConst,  &
                        ubulk,OldRestartName,NewRestartName,StretTypeOld,istretOld,cStretOld,nyUniformOld, &
                        yUniformOld,StretTypeNew,istretNew,cStretNew,nyUniformNew,yUniformNew

    write(d_LogInfo_unit, nml=BasicParam)
  end subroutine DumpReadedParam

end module m_Parameters


program print_asterisks
    implicit none
    integer :: i = 123456
    character(len=6) :: c = 'abcdef'

    print '(I8)', i
    print '(I4)', i

    print '(A8)', c
    print '(A4)', c

end program print_asterisks


! { dg-do compile }

subroutine foo (x)
  integer :: x(5, *)
!$omp parallel
!$omp single
!$omp task depend(in:x(:,5))
!$omp end task
!$omp task depend(in:x(5,:))	! { dg-error "Rightmost upper bound of assumed size array section|proper array section" }
!$omp end task
!$omp end single
!$omp end parallel
end


! { dg-do compile }
! { dg-options "-std=f2008" }
!
! PR fortran/33197
!
! Check implementation of PARITY
!
implicit none
print *, parity([real ::]) ! { dg-error "must be LOGICAL" })
print *, parity([integer ::]) ! { dg-error "must be LOGICAL" }
print *, parity([logical ::])
print *, parity(.true.) ! { dg-error "must be an array" }
end


! { dg-do compile }
! PR37446 Diagnostic of edit descriptors, esp. EN
      character(40) :: fmt_string
      write(*, '(1P,2E12.4)') 1.0
      write(*,'(EN)') 5.0 ! { dg-error "Positive width required" }
      write(*,'("abcdefg",EN6,"hjjklmnop")') 5.0 ! { dg-error "Period required" }
      end


 program reverse_string
  implicit none
  character (80) :: cadena
  integer :: k, n
  !
  cadena = "abcdefgh"
  n = len_trim (cadena)
  !
  write (*,*) cadena
  forall (k=1:n) cadena (k:k) = cadena (n-k+1:n-k+1)
  write (*,*) cadena
  !
end program reverse_string


program convert
    use, intrinsic :: iso_fortran_env, only : error_unit, iostat_end, &
        DP => REAL64
    implicit none
    integer :: unit_nr, istat
    character(len=1024) :: file_name, msg
    real(kind=DP) :: r, theta

    call get_arguments(file_name)
    open (newunit=unit_nr, file=file_name, form='unformatted', &
          access='sequential', action='read', status='old', iostat=istat, &
          iomsg=msg)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
        stop 3
    end if
    do
        read (unit=unit_nr, iostat=istat, iomsg=msg) r, theta
        if (istat == iostat_end) exit
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
        end if
        print '(2E27.15)', r, theta
    end do
    close(unit=unit_nr)

contains

    subroutine get_arguments(file_name)
        implicit none
        character(len=*), intent(out) :: file_name

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting file name as argument'
            stop 1
        end if

        call get_command_argument(1, file_name)
    end subroutine get_arguments

end program convert


PROGRAM parsing_03
    INTEGER :: tes
    INTEGER :: res
    tes = 1
    res = tes * 2
    print *, res, tes
END PROGRAM


c Fortran example
      program hello
      include 'mpif.h'
      integer rank, num_ranks, err_flag

      call MPI_INIT(err_flag)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_ranks, err_flag)
      call MPI_COMM_RANK(MPI_COMM_WORLD, rank, err_flag)
      print*, 'Hello world! From rank', rank, 'of ', num_ranks
      call MPI_FINALIZE(err_flag)
      end


program test

  integer, dimension(:, :), allocatable :: array

  allocate(array(10, 10))
  print *, size(array)
  print *, size(array, 1)
  print *, size(array, 2)
  deallocate(array)

end program test


! chk_automatic_array --
!     Check the behaviour of a program that uses increasingly large automatic arrays
!
!     Background:
!     Managing the memory associated with arrays that do not have the SAVE attribute differs
!     between compilers. Some use the stack (fast), some use the heap (slow), some will
!     use a combination. Notably on Windows, the stack is rather small, so that large automatic
!     arrays give problems at run-time.
!     This behaviour can often be influenced by compiler options.
!
module handle_array
    implicit none
contains
subroutine fill_array( n, sumofvalues )
    integer, intent(in) :: n
    real, intent(out)   :: sumofvalues

    real, dimension(n) :: array

    array = 1.0

    sumofvalues = sum(array)
end subroutine fill_array
end module handle_array

program chk_automatic_array
    use handle_array

    implicit none

    integer :: i, sz
    real    :: result

    sz = 1

    write( *, '(a)' ) 'Use successively larger automatic arrays:'
    write( *, '(a)' ) 'NOTE: it may crash before the end of the run'

    !
    ! Let the array increase to 100 million elements, that ought to be well
    ! within the limits of a 32-bits program
    !
    do i = 1,8
        sz = 10 * sz

        call fill_array( sz, result )

        write( *, '(a,i10,a)' ) 'Size: ', sz, ' - succeeded'
    enddo

    write( *, '(a)' ) 'Apparently you can use very large automatic arrays'
end program chk_automatic_array


      program main
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c                          Plot Variograms
c                          ***************
c
c New version requires a parameter file (created if none given the first
c time the program is run)
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter (MAXLAG=5001,BIGNUM=1.0e21,EPSLON=1.0e-5,MAXCAT=24,
     +           VERSION=2.905)

      integer    redint(MAXCAT),grnint(MAXCAT),bluint(MAXCAT),test
      character  outfl*512,title*40,str*512
      real       xx(MAXLAG),yy(MAXLAG)
      logical    testfl
c
c Declare dynamic arrays:
c
      character*512,allocatable :: datafl(:)
      real,allocatable         :: ar1(:,:),ar2(:,:)
      integer,allocatable      :: ivar(:),idash(:),ipts(:),iline(:),
     +                            nlag(:),iclr(:)
c
c Common variables for Postscript Plotting:
c
      common /psdata/ lpsout,pscl,pxmin,pxmax,pymin,pymax,xmin,
     +                xmax,ymin,ymax
      common /olddat/ xvmn,xvmx,yvmn,yvmx
c
c Hardcoded categorical colors:
c
      data       redint/255,255,255,127,  0,  0,  0,255,255,0,127,170,
     +                  255,  0,200,9*255/,
     +           grnint/  0,127,255,255,255,255,  0,  0,255,0,  0, 85,
     +                   85,255,200,9*  0/,
     +           bluint/  0,  0,  0,  0,  0,255,255,255,255,0,255,  0,
     +                  170,127,200,9*255/
c
c Hardwire many of the plot parameters:
c
      data lin/1/,lpsout/2/,pscl/0.24/,pxmin/0.0/,pxmax/288.0/
     +     pymin/0.0/,pymax/216.0/,xmin/-10.0/,xmax/60.0/,
     +     ymin/-10.0/,ymax/60.0/,vpxmin/1.0/,vpxmax/59.5/,
     +     vpymin/0.0/,vpymax/58.0/
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' VARGPLT Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      do i=1,512
            str(i:i) = ' '
      end do
      call getarg(1,str)
      if(str(1:1).eq.' ')then
            write(*,*) 'Which parameter file do you want to use?'
            read (*,'(a)') str
      end if
      if(str(1:1).eq.' ') str(1:20) = 'vargplt.par         '
      inquire(file=str,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'vargplt.par         ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str,status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a4)',end=98) str(1:4)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      read(lin,'(a512)',err=98) outfl
      call chknam(outfl,512)
      write(*,*) ' output file = ',outfl(1:40)

      read(lin,*,err=98) nvar
      write(*,*) ' number of variograms = ',nvar
c
c Read needed parameters:
c
      MAXVAR = nvar
c
c Allocate the needed memory:
c1
      allocate(datafl(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c2
      allocate(ar1(MAXVAR,MAXLAG),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c3
      allocate(ar2(MAXVAR,MAXLAG),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c4
      allocate(ivar(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c5
      allocate(idash(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c6
      allocate(ipts(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c7
      allocate(iline(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c8
      allocate(nlag(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c9
      allocate(iclr(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c

      read(lin,*,err=98) dmin,dmax
      write(*,*) ' distance limits = ',dmin,dmax

      read(lin,*,err=98) gmin,gmax
      write(*,*) ' variogram limits = ',gmin,gmax

      read(lin,*,err=98) isill,sillval
      write(*,*) ' plot sill, sill value = ',isill,sillval

      read(lin,'(a40)') title
      call chktitle(title,40)
      write(*,*) ' title = ',title

      do i=1,nvar
            read(lin,'(a512)') datafl(i)
            call chknam(datafl(i),512)
            write(*,*) ' data file ',i,' = ',datafl(i)
            read(lin,*) ivar(i),idash(i),ipts(i),iline(i),iclr(i)
            write(*,*) ' parameters ',
     +                  ivar(i),idash(i),ipts(i),iline(i),iclr(i)
      end do
      close(lin)
c
c Read the variograms:
c
      do iii=1,nvar
c
c Find the right variogram:
c
      write(*,*) ' working on variogram ',iii
      write(*,*) ' trying to open       ',datafl(iii)
      open(lin,file=datafl(iii))
      write(*,*) ' opened               ',datafl(iii)
      read(lin,'(a80)') str
      do jjj=1,ivar(iii)-1
            do jj3=1,1000
                  read(lin,'(a80)') str
                  if(str(1:1).ne.' ') go to 333
            end do
 333        continue
      end do
c
c Read the variogram:
c
      np = 0
      do jjj=1,MAXLAG
            read(lin,'(a80)',end=334) str
            if(str(1:1).ne.' ') go to 334
            backspace lin
            np = np + 1
            read(lin,*,err=334,end=334) iiii,ar1(iii,np),ar2(iii,np)
            if(ar1(iii,np).lt.0.0001) np = np - 1
      end do
 334  continue
      nlag(iii) = np
      close(lin)
c
c Finish reading all variograms:
c
      end do
c
c Establish data-based limits to distance and variogram:
c
      dbdmin =  1.0e21
      dbdmax = -1.0e21
      dbvmin =  1.0e21
      dbvmax = -1.0e21
      do i=1,nvar
            do j=1,nlag(i)
                  if(ar1(i,j).lt.dbdmin) dbdmin = ar1(i,j)
                  if(ar1(i,j).gt.dbdmax) dbdmax = ar1(i,j)
                  if(ar2(i,j).lt.dbvmin) dbvmin = ar2(i,j)
                  if(ar2(i,j).gt.dbvmax) dbvmax = ar2(i,j)
            end do
      end do
      if(dmax.le.dmin) then
            dmin = 0.0
            dmax = dbdmax
      end if
      if(gmax.le.gmin) then
            gmin = dbvmin
            gmax = dbvmax
      end if
      xvmin = dmin
      xvmax = dmax
      yvmin = gmin
      yvmax = gmax
c
c Write the variograms:
c
      open(lpsout,file=outfl,status='UNKNOWN')
      write(lpsout,998)
 998  format('%!PS                                 %    Remove     ',
     +    /, '90 234 translate 1.5 1.5 scale       %  these lines  ',
     +    /, '                                     % for EPSF file ',
     +    /, '%!PS-Adobe-3.0 EPSF-3.0',
     +    /, '%%BoundingBox: 0 0 288 216',
     +    /, '%%Creator: GSLIB',
     +    /, '%%Title:   ',
     +    /, '%%CreationDate: ',
     +    /, '%%EndComments',/,/,/,'%',/,'%',/,'%',/,
     +    /, '/m {moveto} def /l {lineto} def /r {rlineto} def',
     +    /, '/s {stroke} def /n {newpath} def /c {closepath} def',
     +    /, '/rtext{ dup stringwidth pop -1 div 0 rmoveto show } def',
     +    /, '/ctext{ dup stringwidth pop -2 div 0 rmoveto show } def',
     +    /, '/ltext{show} def /gr{grestore} def /gs{gsave} def',
     +    /, '/tr{translate} def /setc{setrgbcolor} def',
     +    /, '/bullet{ 8 0 360 arc c fill } def',/,/,
     +    /, '%72 72 translate',/,/,
     +    /, '0.240000 0.240000 scale')
c
c Draw and scale axes:
c
      ts   = 7.5
      xvmn = xvmin
      xvmx = xvmax
      yvmn = yvmin
      yvmx = yvmax
      write(lpsout,100)
 100  format('gsave /Symbol findfont 100 scalefont setfont ',
     +       '0 501 m (g) rtext grestore')
      xrange = vpxmax - vpxmin
      yrange = vpymax - vpymin
      xloc = vpxmin + 0.50*xrange
      yloc = vpymin - 0.15*yrange
      call pstext(xloc,yloc,8,'Distance',ts,1,0.0,1)
      xloc = vpxmin
      yloc = vpymax + 0.01*(vpxmax-vpxmin)
      call pstext(xloc,yloc,40,title,9.0,3,0.0,0)
      idsh = -1
      ilog = 0
      i45  = 0
      call scal(xvmin,xvmax,yvmin,yvmax,vpxmin,vpxmax,vpymin,vpymax,
     +          ilog,i45)
c
c Write variogram bullets and lines:
c
      do iii=1,nvar
c
c Color?
c
      if(iclr(iii).gt.0) then
            jclr = iclr(iii)
            irr  = redint(jclr)
            igg  = grnint(jclr)
            ibb  = bluint(jclr)
            write(lpsout,301) irr,igg,ibb
 301        format(3i4,' setrgbcolor')
      end if
c
c Mark bullets:
c
      if(ipts(iii).eq.1) then
            do i=1,nlag(iii)
                  xloc = resc(xvmn,xvmx,vpxmin,vpxmax,ar1(iii,i))
                  yloc = resc(yvmn,yvmx,vpymin,vpymax,ar2(iii,i))
                  if(ar1(iii,i).ge.dmin.and.ar1(iii,i).le.dmax.and.
     +               ar2(iii,i).ge.gmin.and.ar2(iii,i).le.gmax) then
                  ix = int((resc(xmin,xmax,pxmin,pxmax,xloc))/pscl)
                  iy = int((resc(ymin,ymax,pymin,pymax,yloc))/pscl)
                  write(lpsout,32) ix,iy
                  end if
            end do
 32         format('n ',i4.4,1x,i4.4,' bullet')
      end if
c
c Draw a line:
c
      if(iline(iii).eq.1) then
            np = 0
            do i=1,nlag(iii)
                  xx(i) = resc(xvmn,xvmx,vpxmin,vpxmax,ar1(iii,i))
                  yy(i) = resc(yvmn,yvmx,vpymin,vpymax,ar2(iii,i))
                  if(ar1(iii,i).lt.dmin.or.ar1(iii,i).gt.dmax.or.
     +               ar2(iii,i).lt.gmin.or.ar2(iii,i).gt.gmax) then
                        if(np.eq.0) np = i-1
                  end if
            end do
            idsh = idash(iii)
            np   = nlag(iii)
            call psline(np,xx,yy,0.5,idsh)
      end if
      write(lpsout,302)
 302  format('0 0 0 setrgbcolor')
c
c Finish loop over all annotation:
c
      end do
c
c Draw sill line?
c
      if(isill.eq.1) then
            np = 2
            xx(1) = resc(xvmn,xvmx,vpxmin,vpxmax,dmin)
            yy(1) = resc(yvmn,yvmx,vpymin,vpymax,sillval)
            xx(2) = resc(xvmn,xvmx,vpxmin,vpxmax,dmax)
            yy(2) = resc(yvmn,yvmx,vpymin,vpymax,sillval)
            call psline(np,xx,yy,0.5,0)
      end if
c
c Close data file:
c
      write(lpsout,999)
 999  format('%END OF POSTSCRIPT FILE',/,'4.166667 4.166667 scale',/,/,
     +       '%%EOF',/,'showpage')
      close(lpsout)
c
c Finished:
c
 9997 write(*,9998) VERSION
 9998 format(/' VARGPLT Version: ',f5.3, ' Finished'/)
      stop
 98   stop 'Error in parameter file'
      end

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

      write(lun,11)
 11   format('vargplt.ps                   ',
     +       '-file for PostScript output')
      write(lun,12)
 12   format('2                            ',
     +       '-number of variograms to plot')
      write(lun,13)
 13   format('0.0   20.0                   ',
     +       '-distance  limits (from data if max<min)')
      write(lun,14)
 14   format('0.0    1.2                   ',
     +       '-variogram limits (from data if max<min)')
      write(lun,24)
 24   format('1      1.0                   ',
     +       '-plot sill (0=no,1=yes), sill value)')
      write(lun,15)
 15   format('Normal Scores Semivariogram  ',
     +       '-Title for variogram')
      write(lun,16)
 16   format('gamv.out                     ',
     +       '-1 file with variogram data')
      write(lun,17)
 17   format('1    1   1   1    1          ',
     +       '-  variogram #, dash #, pts?, line?, color')
      write(lun,18)
 18   format('vmodel.var                   ',
     +       '-2 file with variogram data')
      write(lun,19)
 19   format('1    3   0   1   10          ',
     +       '-  variogram #, dash #, pts?, line?, color')
      write(lun,20)
 20   format(//,'Color Codes for Variogram Lines/Points:')
      write(lun,21)
 21   format('      1=red, 2=orange, 3=yellow, 4=light green,',
     +       ' 5=green, 6=light blue,',/,
     +       '      7=dark blue, 8=violet, 9=white,',
     +       ' 10=black, 11=purple, 12=brown,',/,
     +       '      13=pink, 14=intermediate green, 15=gray')

      close(lun)
      return
      end


! RUN: %flang -fsyntax-only 2>&1 %s | FileCheck %s

! Test that a warning is emitted when a named common block appears in
! several scopes with a different storage size.

subroutine size_1
  common x, y
  common /c/ xc, yc
end subroutine

subroutine size_2
  ! OK, blank common size may always differ.
  common x, y, z
  !CHECK: portability: A named COMMON block should have the same size everywhere it appears (12 bytes here)
  common /c/ xc, yc, zc
end subroutine


PROGRAM hello_f

  USE omp_lib

  IMPLICIT NONE

  INTEGER :: th_id
  INTEGER :: nthreads
  !$OMP PARALLEL private(th_id)
  th_id = omp_get_thread_num()
  WRITE (*,'(A,I0)') "Hello, World from thread ", th_id
  !$OMP BARRIER

  IF (th_id == 0) THEN
     nthreads = omp_get_num_threads()
     WRITE (*,'(A,I0,A)') "There are ", nthreads, " threads"
     WRITE (*,'(A,I6)') 'OpenMP Specification: ',openmp_version
  END IF
  !$OMP END PARALLEL

END PROGRAM hello_f


program compare_character_variables
implicit none
character (len=4), allocatable :: w(:)
w = ["John","Joan","girl","boy "]
print*,findloc(w,"girl"),findloc(w,"abcd") ! 3 0
write (*,"(*(g0,:,1x))") minval(w),minval(w(3:)) ! Joan boy
write (*,"(*(g0,:,1x))") minloc(w),minloc(w,mask=[0,0,1,1] == 1)
print*," " < "*", "*" < "0", "0" < "1", "9" < "A", &
       "Z" < "a", "a" < "b"
! replacing < with .lt. in the line above gives same result
print*,llt(" ","*"),llt("*","0"),llt("0","1"),llt("9","A"), &
       llt("Z","a"),llt("a","b") ! same result
! ASCII collating sequence is blanks, special characters,
! numerals, upper case letters, lower case letters
end program compare_character_variables
! output:
! 3 0
! Joan boy
! 2 4
!  T T T T T T
!  T T T T T T


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

! 2.15.2 threadprivate Directive
! The threadprivate directive specifies that variables are replicated,
! with each thread having its own copy. When threadprivate variables are
! referenced in the OpenMP region, we know they are already private to
! their threads, so no new symbol needs to be created.

!DEF: /mm Module
module mm
  !$omp threadprivate (i)
contains
  !DEF: /mm/foo PUBLIC (Subroutine) Subprogram
  subroutine foo
    !DEF: /mm/foo/a ObjectEntity INTEGER(4)
    integer :: a = 3
    !$omp parallel
    !REF: /mm/foo/a
    a = 1
    !DEF: /mm/i PUBLIC (Implicit, OmpThreadprivate) ObjectEntity INTEGER(4)
    !REF: /mm/foo/a
    i = a
    !$omp end parallel
    !REF: /mm/foo/a
    print *, a
    block
      !DEF: /mm/foo/Block2/i ObjectEntity REAL(4)
      real i
      !REF: /mm/foo/Block2/i
      i = 3.14
    end block
  end subroutine foo
end module mm
!DEF: /tt MainProgram
program tt
  !REF: /mm
  use :: mm
  !DEF: /tt/foo (Subroutine) Use
  call foo
end program tt


! chk_internal_routine_arg.f90 --
!     Check: does the compiler support passing internal routines as arguments?
!
module pass_routines
    implicit none
contains
subroutine run_func( func )
    integer :: x

    interface
        integer function func( y )
            implicit none
            integer, intent(in) :: y
        end function func
    end interface

    x = func(1)
    write( *, '(a,i0)' ) 'Value: ', x
    if ( x == 1 ) then
        write( *, '(a)' ) '    Value is as expected'
    else
        write( *, '(a)' ) '    Unexpected value - please check!'
    endif
end subroutine run_func
end module pass_routines

program chk_internal_routine_arg
    use pass_routines

    implicit none

    integer, dimension(4) :: array

    array = (/ 1, 2, 3, 4 /)

    call run_func( f )

    write( *, '(a)' ) 'Passing internal routines as argument is supported'
contains
integer function f( y )
    integer, intent(in) :: y

    f = array(y)
end function f
end program chk_internal_routine_arg


program test

      implicit none

      logical :: a, b
      character :: grade = 'B'
      integer :: mark = 89
      integer :: i
      a = .true.;
      b = .false.;

      ! =====================
      ! if then else if then end if
      if (.not. a) then
          print *, "test 1"
      else if (b) then
          print *, "test 2"
      else if (.not. b) then
          print *, "test 3"
      end if

      ! ====================
      ! select case

      select case (grade)
        case('A')
            print *, "well done"
        case('B')
            print *, "good enough"
        case('C')
            print *, "not good"
        case('D')
            print *, "invalid"
      end select

      select case (mark)
      case(91:)
          print *, "well done"
      case(81:90)
          print *, "good enough"
      case(61:80)
          print *, "not good"
      case(:60)
          print *, "invalid"
      end select

      ! stop

      ! ====================
      ! do / do... while
      do i = 1, 100, 5
            if (i .eq. 6) then
                cycle
            end if
            if (i > 80) then
                stop
            end if
            print *, i
      end do

      i = 4
      do while(i < 10)
            print *, i
            i = i + 1
      end do

end program test


program file_or_console
use, intrinsic:: iso_fortran_env, only: stdout=>output_unit

implicit none (type, external)

character(:), allocatable :: filename
character(256) :: buf
integer :: i, u

call get_command_argument(1,buf,status=i)
if (i==0) then
  filename = trim(buf)  ! Fortran 2003 auto-allocate
  print *, 'writing to ',filename
  open(newunit=u, file=filename, form='formatted')
else
  u = stdout
endif

i = 3 ! test data

write(u,*) i, i**2, i**3

if (u /= stdout) close(u)   ! closing stdout can disable text console output

print *,'goodbye'

! end program implies closing all file units, but here we close in case you'd use in subprogram (procedure), where the file reference would persist.
end program


! RUN: %S/test_errors.sh %s %t %flang_fc1
! Test ASSIGN statement, assigned GOTO, and assigned format labels
! (see subclause 8.2.4 in Fortran 90 (*not* 2018!)

program main
  call test(0)
2 format('no')
 contains
  subroutine test(n)
    !ERROR: Label '4' is not a branch target or FORMAT
4   integer, intent(in) :: n
    integer :: lab
    assign 1 to lab ! ok
    assign 1 to implicitlab1 ! ok
    !ERROR: Label '666' was not found
    assign 666 to lab
    !ERROR: Label '2' was not found
    assign 2 to lab
    assign 4 to lab
    if (n==1) goto lab ! ok
    if (n==1) goto implicitlab2 ! ok
    if (n==1) goto lab(1) ! ok
    if (n==1) goto lab,(1) ! ok
    if (n==1) goto lab(1,1) ! ok
    !ERROR: Label '666' was not found
    if (n==1) goto lab(1,666)
    !ERROR: Label '2' was not found
    if (n==1) goto lab(1,2)
    assign 3 to lab
    write(*,fmt=lab) ! ok
    write(*,fmt=implicitlab3) ! ok
1   continue
3   format('yes')
  end subroutine test
end program


module stdlib_experimental_error
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit
implicit none
private

interface ! f{08,18}estop.f90
module subroutine error_stop(msg, code)
character(*), intent(in) :: msg
integer, intent(in), optional :: code
end subroutine error_stop
end interface

public :: assert, error_stop

contains

subroutine assert(condition, code)
! If condition == .false., it aborts the program.
!
! Arguments
! ---------
!
logical, intent(in) :: condition
integer, intent(in), optional :: code
!
! Example
! -------
!
! call assert(a == 5)

if (.not. condition) call error_stop("Assert failed.", code)
end subroutine

end module


program ch1804
    ! Pointer Allocation and Assignment
    implicit none

    integer, pointer :: a=>null(), b=>null()
    integer, target :: c
    integer :: d

    allocate(a)
    a = 1
    c = 2
    b => c
    d = a+b
    print *, a, b, c, d
    deallocate(a)
end program


module mod_latlon

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_latlon'
 !
 !          Purpose:
 !                    Latitude-longtitude geographical coordinates.
 !                    This class is simple wrapper which conveniently
 !                    handles creation of geographiv coordinates(lat-lon).
 !
 !
 !          History:
 !                        Date: 15-09-2017
 !                        Time: 09:36 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

    implicit none
    private ! everything is private beside variables and procedures deemed public
    use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT , &
                                stdout=>OUTPUT_UNIT
    use IFPORT, only : TRACEBACKQQ
    use module_class_error_check, only : array2D_not_alloc

    use module_kinds
    use mod_constants
    use module_logger
    use mod_code_timing

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Version major
    integer(I32P), parameter, public :: MOD_LATLON_MAJOR = 1

    ! Version minor
    integer(I32P), parameter, public :: MOD_LATLON_MINOR = 0

    ! Version micro
    integer(I32P), parameter, public :: MOD_LATLON_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_LATLON_FULLVER = 1000*MOD_LATLON_MAJOR+100*MOD_LATLON_MINOR+ &
                                                             10*MOD_LATLON_MICRO

    ! Module creation date
    character(*),  parameter, public :: MOD_LATLON_CREATE_DATE = "15-09-2017 14:09 +00200 (FRI 15 SEP 2017 GMT+2)"

    ! Module build date (should be set after successful build date/time)
    character(*),  parameter, public :: MOD_LATLON_BUILD_DATE = " "

    ! Module author info.
    character(*),  parameter, public :: MOD_LATLON_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description.
    character(*),  parameter, public :: MOD_LATLON_DESCRIPT = "Latitude-longtitude geographical coordinates."

    !======================================================60
    !  Type: LatLon
    !======================================================60

    type, public :: LatLon

         ! public by default.
         ! indices
         integer(I64P) :: m_ims,m_ime,m_jms,m_jme, &
                          m_ids,m_ide,m_jds,m_jde, &
                          m_its,m_ite,m_jts,m_jte

        ! Lat-lon coordinates
        ! m_lat --  latitude, south is negative (degree)
        ! m_long -- longitude, west is negative (degree)
        real(R64P), allocatable, dimension(:,:) :: m_lat,m_long

!DIR$   ATTRIBUTES ALIGN : 32 :: m_lat
!DIR$   ATTRIBUTES ALIGN : 32 :: m_long

        ! built indicator (logical)
        logical(I32P) :: m_isbuilt

        contains

        !===========================================55
        ! Constructors and Destructor procedures.
        !===========================================55

        procedure, pass(this), public :: init

        procedure, pass(this), public :: copy

        procedure, pass(this), public :: destroy

        !============================================55
        ! Read/Write procedures
        !============================================55

        procedure, nopass, public :: read_latlon

        procedure, nopass, public :: write_latlon

    end type LatLon

       !=================================================60
       !  Module operators
       !=================================================60

       interface assignment (=)
            module procedure assign_latlon
       end interface

       interface operator (/=)
            module procedure latlon_neq_latlon
       end interface

       interface operator (==)
            module procedure latlon_eq_latlon
       end interface

       interface operator (>)
            module procedure latlon_gt_latlon
       end interface

       interface operator (<)
             module procedure latlon_lt_latlon
       end interface

    contains

    !=================================================60
    !              Implementation
    !=================================================60

    !======================================================60
    ! subroutine: init
    ! Initialziation by user(caller) passed array which
    ! usually contain specific random scalar distribution.
    !   @Warning:
    !            Upon non-fatal early exit parameter
    !            'err' will be set to -1
    !======================================================60
    subroutine init(this,indices,lat,long,logging,    &
                    profiling,filename,append,dbg,err,qpctimer)
          implicit none
          class(LatLon),                intent(inout) :: this
          integer(I64P), dimension(12), intent(in)    :: indices
          real(R64P), dimension(:,:),   intent(in)    :: lat,long
!DIR$     ASSUME_ALIGNED lat:32,long:32
          logical(I32P),                intent(in)    :: logging,profiling
          character(len=*),             intent(in)    :: filename
          logical(I32P),                intent(in)    :: append,dbg
          integer(I32P),                intent(inout) :: err
          type(QPCTimer_t),             intent(inout) :: qpctimer
          ! Locals
          character(len=40)  :: dstr,tstr
          character(len=256) :: emsg
          integer(I64P)      :: j,i
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail
!DIR$  IF (USE_LOOP_BLOCKING .EQ. 1)
          integer(I64P)      :: jj,ii
!DIR$  ENDIF
          integer(I32P)      :: aerr
          ! Start of executable statements
          if(err.LT.0) err = 0
          if(array2D_not_alloc(lat) .OR. &
             array2D_not_alloc(long)) then
              err = -1
              return
          end if
          if(this%m_isbuilt .EQ. .true.) then
              if(logging) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:182, In->mod_latlon/init: LatLon already initialized!!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=dstr,time=tstr)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_latlon/init:182, LatLon already initialized!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          ! Begin construction
          this%m_ims=indices(1)
          this%m_ime=indices(2)
          this%m_jms=indices(3)
          this%m_jme=indices(4)
          this%m_ids=indices(5)
          this%m_ide=indices(6)
          this%m_jds=indices(7)
          this%m_jde=indices(8)
          this%m_its=indices(9)
          this%m_ite=indices(10)
          this%m_jts=indices(11)
          this%m_jte=indices(12)
          ! Array alocation
          associate(d1s=>this%m_ims, &
                    d1e=>this%m_ime, &
                    d2s=>this%m_jms, &
                    d2e=>this%m_jme )
              allocate(this%m_lat(d1s:d1e,d2s:d2e),   &
                       this%m_long(d1s:d1e,d2s:d2e),  &
                       STAT=aerr,                     &
                       ERRMSG=emsg )
          end associate
          if(aerr.NE.0) then
              if(logging) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:221, In->mod_latlon/init: Failed to allocate: [m_coord] ")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=dstr,time=tstr)
                  write(ERROR_UNIT,*) "===========================FATAL========================="
                  write(ERROR_UNIT,*) "   (mod_latlon/init:221, Failed to allocate: [m_coord)"
                  write(ERROR_UNIT,*) "   (System message:)", emsg
                  write(ERROR_UNIT,*) "   ( Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(ERROR_UNIT,*) "===========================FATAL=========================="
              end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_latlon/init:221 -> [FATAL-ERROR]: Terminating execution!!"
          end if
          !Array initilaization
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail.EQ.0) then
                  write(stderr,*) "mod_latlon/init: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
!DIR$  IF (USE_LOOP_BLOCKING .EQ. 1)
          do j = this%m_jms, this%m_jme, DEFAULT_BLOCK_SIZE
              do i = this%m_ims, this%m_kme, DEFAULT_BLOCK_SIZE
                  do jj = j, DEFAULT_BLOCK_SIZE
!DIR$                 SIMD VECTORLENGTHFOR(REAL(KIND=8))
                      do ii = i, DEFAULT_BLOCK_SIZE
!DIR$           IF (USE_SOFT_PREFETCH .EQ. 1)
                          call MM_PREFETCH(lat(ii+1,jj),1)
                          call MM_PREFETCH(long(ii+1,jj),1)
!DIR$           ENDIF
                          this%m_lat(ii,jj) = lat(ii,jj)
                          this%m_long(ii,jj) = long(ii,jj)
                      end do
                  end do
              end do
          end do
!DIR$ ELSE
          do j = this%m_jms, this%m_jme
!DIR$         SIMD VECTORLENGTHFOR(REAL(KIND=8))
              do i = this%m_ims, this%m_ime
!DIR$         IF (USE_SOFT_PREFETCH .EQ. 1)
                  call MM_PREFETCH(lat(i+1,j),1)
                  call MM_PREFETCH(long(i+1,j),1)
!DIR$         ENDIF
                  this%m_lat(i,j) = lat(i,j)
                  this%m_long(i,j) = long(i,j)
              end do
          end do
!DIR$     ENDIF
          if(profiling) then
                if(ifail.EQ.0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail .EQ. .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_latlon/init: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_latlon/init: Unable to read performance counter -- fatal!!"
                end if
          end if
          this%m_isbuilt = .true.
          if(dbg) then
              print*, " Latitude:  ", this%m_lat
              print*, " Longtitude:", this%m_long
          end if
    end subroutine

    !======================================================60
    ! subroutine: copy
    ! Remark:
    !           Upon detecting non-fatal error inout
    !           integer indicator 'err' will be set to -1.
    !======================================================60
    subroutine copy(this,other,logging,filename,append,err)
          implicit none
          class(LatLon),    intent(inout) :: this
          class(LatLon),    intent(in)    :: other
          logical(I32P),    intent(in)    :: logging
          character(len=*), intent(in)    :: filename
          logical(I32P),    intent(in)    :: append
          integer(I32P),    intent(inout) :: err
          ! Locals
          character(len=40) :: dstr,tstr
          ! Start of executable statements
          if(err.LT.0) err = 0
          if(this%m_isbuilt .EQ. .true.) then
              if(logging) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:330, In->mod_latlon/copy: LatLon already initilaized!!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=dstr,time=tstr)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_latlon/copy:330, LatLon already initialized!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          ! Begin construction
          this%m_ims=other%m_ims
          this%m_ime=other%m_ime
          this%m_jms=other%m_jms
          this%m_jme=other%m_jme
          this%m_ids=other%m_ids
          this%m_ide=other%m_ide
          this%m_jds=other%m_jds
          this%m_jde=other%m_jde
          this%m_its=other%m_its
          this%m_ite=other%m_ite
          this%m_jts=other%m_jts
          this%m_jte=other%m_jte
          this%m_lat=other%m_lat
          this%m_long=other%m_long
          this%m_isbuilt = .true.
    end subroutine

    !======================================================60
    !  subroutine: destroy
    !  Remark:
    !           Upon detecting non-fatal error inout
    !           integer indicator 'err' will be set to -1.
    !======================================================60
    subroutine destroy(this,logging,filename,append,err)
          implicit none
          class(LatLon),    intent(inout) :: this
          logical(I32P),    intent(in)    :: logging
          character(len=*), intent(in)    :: filename
          logical(I32P),    intent(in)    :: append
          integer(I32P),    intent(inout) :: err
          ! Locals
          character(len=40)  :: dstr,tstr
          character(len=256) :: emsg
          integer(I32P)      :: derr
          ! Start of executable statemetns
          if(err.LT.0) err = 0
          if(this%m_isbuilt .EQ. .false.) then
              if(logging) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:384, In->mod_latlon/destroy: LatLon already destroyed!!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=dstr,time=tstr)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_latlon/destroy:330, LatLon already destroyed!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          this%m_ims=0
          this%m_ime=0
          this%m_jms=0
          this%m_jme=0
          this%m_ids=0
          this%m_ide=0
          this%m_jds=0
          this%m_jde=0
          this%m_its=0
          this%m_ite=0
          this%m_jts=0
          this%m_jte=0
          ! Arrays deallocation
          if(ALLOCATED(this%m_lat)) then
              deallocate(this%m_lat, &
                         STAT=derr,  &
                         ERRMSG=emsg)
               if(derr.NE.0) then
                   if(logging) then
                       call log_startup(filename,append)
                       call log_UsrMsg("logger:418, In->mod_latlon/destroy: Failed to deallocate: [m_lat] !!")
                       call log_shutdown()
                   else
                       call DATE_AND_TIME(date=dstr,time=tstr)
                       write(ERROR_UNIT,*) "===========================FATAL========================="
                       write(ERROR_UNIT,*) "   (mod_latlon/destroy:418, Failed deallocate: [m_lat]!!)"
                       write(ERROR_UNIT,*) "   (System message:)", emsg
                       write(ERROR_UNIT,*) "   ( Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                       write(ERROR_UNIT,*) "===========================FATAL=========================="
                end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_latlon/destroy:418 -> [FATAL-ERROR]: Terminating execution!!"
              end if
          end if
          if(ALLOCATED(this%m_long)) then
              deallocate(this%m_long, &
                         STAT=derr,   &
                         ERRMSG=emsg)
              if(derr.NE.0) then
                  if(logging) then
                      call log_startup(filename,append)
                      call log_UsrMsg("logger:443, In->mod_latlon/destroy: Failed to deallocate: [m_long] !!")
                      call log_shutdown()
                  else
                       call DATE_AND_TIME(date=dstr,time=tstr)
                       write(ERROR_UNIT,*) "===========================FATAL========================="
                       write(ERROR_UNIT,*) "   (mod_latlon/destroy:443, Failed deallocate: [m_long]!!)"
                       write(ERROR_UNIT,*) "   (System message:)", emsg
                       write(ERROR_UNIT,*) "   ( Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                       write(ERROR_UNIT,*) "===========================FATAL=========================="
                end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_latlon/destroy:443 -> [FATAL-ERROR]: Terminating execution!!"
              end if
          end if
          this%m_isbuilt = .false.
    end subroutine

    !======================================================60
    !  subroutine: read_latlon
    !  Remark:
    !           Upon detecting non-fatal error inout
    !           integer indicator 'err' will be set to -1.
    !======================================================60
    subroutine read_latlon(this,unit,ioerr,err)
          implicit none
          class(LatLon), intent(in)    :: this
          integer,       intent(in)    :: unit
          integer(I32P), intent(inout) :: ioerr,err
          ! Strat of executable statements
          if(err.LT.0) err = 0
          if(this%m_isbuilt .EQ. .false.) then
              err = -1
              return
          end if
          READ(unit,iostat=ioerr) this
    end subroutine

    !======================================================60
    !  subroutine: write_latlon
    !  Remark:
    !           Upon detecting non-fatal error inout
    !           integer indicator 'err' will be set to -1.
    !======================================================60
    subroutine write_latlon(this,unit,ioerr,err)
          implicit none
          class(LatLon), intent(in)    :: this
          integer,       intent(in)    :: unit
          integer(I32P), intent(inout) :: ioerr,err
          ! Start of executable statements
          if(err.LT.0) err = 0
          if(this%m_isbuilt .EQ. .false.) then
              err = -1
              return
          end if
          WRITE(unit,iostat=ioerr) this
    end subroutine

    !======================================================60
    !                   Module operators
    !======================================================60

    !=======================================================60
    !  subroutine: overloaded assignment (=)
    !=======================================================60
    subroutine assign_latlon(this,other)
          implicit none
          type(LatLon), intent(inout) :: this
          type(LatLon), intent(in)    :: other
          ! Start of executable statements
          if(LOC(this).EQ.LOC(other)) then
               call DATE_AND_TIME(date=dstr,time=tstr)
               write(stderr,*) "===========================NON-FATAL=========================="
               write(sdterr,*) " ( mod_latlon/assignment(=):519, Attempted self_assignment!)"
               write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
               write(stderr,*) "===========================NON-FATAL=========================="
               return
          end if
          this%m_ims=other%m_ims
          this%m_ime=other%m_ime
          this%m_jms=other%m_jms
          this%m_jme=other%m_jme
          this%m_ids=other%m_ids
          this%m_ide=other%m_ide
          this%m_jds=other%m_jds
          this%m_jde=other%m_jde
          this%m_its=other%m_its
          this%m_ite=other%m_ite
          this%m_jts=other%m_jts
          this%m_jte=other%m_jte
          this%m_lat=other%m_lat
          this%m_long=other%m_long
          this%m_isbuilt = .true.
    end subroutine

    !======================================================60
    ! function: latlon_neq_latlon i.e. overloaded
    !           operator (/=)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function latlon_neq_latlon(c1,c2) result(neq)
         use module_helper_fields_equality
         implicit none
         type(LatLon), intent(in) :: c1,c2
         type(BoolCompField2D)    :: neq
         ! Start of executable statemetns
         neq%e1   = c1%m_lat  /= c2%m_lat
         neq%e2 = c1%m_long /= c2%m_long
    end function

    !======================================================60
    ! function: latlon_eq_latlon i.e. overloaded
    !           operator (==)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function latlon_eq_latlon(c1,c2) result(eq)
         use module_helper_fields_equality
         implicit none
         type(LatLon), intent(in) :: c1,c2
         type(BoolCompField2D)    :: eq
         ! Start of executable statements
         eq%e1 = c1%m_lat  == c2%m_lat
         eq%e2 = c1%m_long == c2%m_long
    end function

    !======================================================60
    ! function: latlon_gt_latlon i.e. overloaded
    !           operator (>)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function latlon_gt_latlon(c1,c2) result(gt)
          use module_helper_fields_equality
          implicit none
          type(LatLon), intent(in) :: c1,c2
          type(BoolCompField2D)    :: eq
          ! Start of executable stateemtns
          gt%e1 = c1%m_lat  > c2%m_lat
          gt%e2 = c1%m_long > c2%m_long
    end function

    !======================================================60
    ! function: latlon_lt_latlon i.e. overloaded
    !           operator (<)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function latlon_gt_latlon(c1,c2) result(lt)
          use module_helper_fields_equality
          implicit none
          type(LatLon), intent(in) :: c1,c2
          type(BoolCompField2D)    :: eq
          ! Start of executable statements
          lt%eq1 = c1%m_lat  < c2%m_lat
          lt%eq2 = c1%m_long < c2%m_long
    end function
end module mod_latlon


*DECK FUNDOC
      SUBROUTINE FUNDOC
C***BEGIN PROLOGUE  FUNDOC
C***PURPOSE  Documentation for FNLIB, a collection of routines for
C            evaluating elementary and special functions.
C***LIBRARY   SLATEC
C***CATEGORY  C, Z
C***TYPE      ALL (FUNDOC-A)
C***KEYWORDS  DOCUMENTATION, ELEMENTARY FUNCTIONS, SPECIAL FUNCTIONS
C***AUTHOR  Kahaner, D. K., (NBS)
C***DESCRIPTION
C
C The SLATEC Library --  Elementary And Special Functions
C
C This describes the elementary and special function routines available
C in the SLATEC library.  Most of the these routines were written by
C Wayne Fullerton while at LANL.  Some were written by Don Amos of SNLA.
C There are approximately 63 single precision, 63 double precision and
C 25 complex user callable elementary and special function routines.
C
C The table below gives a breakdown of routines according to their
C function.  Unless otherwise indicated all routines are function
C subprograms.
C                                             Sngl.      Dble.
C Description              Notation           Prec.      Prec.   Complex
C
C         ***Intrinsic Functions and Fundamental Functions***
C Unpack floating point              Call R9UPAK(X,Y,N)  D9UPAK    --
C  number
C Pack floating point                        R9PAK(Y,N)  D9PAK     --
C  number
C Initialize orthogonal               INITS(OS,NOS,ETA)  INITDS    --
C  polynomial series
C Evaluate Chebyshev       summation for  CSEVL(X,CS,N)  DCSEVL    --
C series                  i = 1 to n of
C                          cs(i)*(2*x)**(i-1)
C
C                  ***Elementary Functions***
C Argument = theta in      z = \ z \ *          --         --    CARG(Z)
C  radians                 e**(i * theta)
C Cube root                                   CBRT(X)    DCBRT   CCBRT
C Relative error exponen-  ((e**x) -1) / x    EXPREL(X)  DEXPRL  CEXPRL
C  tial from first order
C Common logarithm         log to the base 10   --         --  CLOG10(Z)
C                          of z
C Relative error logarithm ln(1 + x)          ALNREL(X)  DLNREL  CLNREL
C Relative error logarithm (ln(1 + x) - x     R9LN2R(X)  D9LN2R  C9LN2R
C from second order        + x**2/2) / x**3
C               ***Trigonometric and Hyperbolic Functions***
C Tangent                  tan z                --         --    CTAN(Z)
C Cotangent                cot x              COT(X)     DCOT    CCOT
C Sine x in degrees        sin((2*pi*x)/360)  SINDG(X)   DSINDG    --
C Cosine x in degrees      cos((2*pi*x)/360)  COSDG(X)   DCOSDG    --
C Arc sine                 arcsin (z)           --         --   CASIN(Z)
C Arc cosine               arccos (z)           --         --   CACOS(Z)
C Arc tangent              arctan (z)           --         --   CATAN(Z)
C Quadrant correct         arctan (z1/z2)       --         -- CATAN2(Z1,
C  arc tangent                                                       Z2)
C Hyperbolic sine          sinh z               --         --   CSINH(Z)
C Hyperbolic cosine        cosh z               --         --   CCOSH(Z)
C Hyperbolic tangent       tanh z               --         --   CTANH(Z)
C Arc hyperbolic sine      arcsinh (x)        ASINH(X)   DASINH  CASINH
C Arc hyperbolic cosine    arccosh (x)        ACOSH(X)   DACOSH  CACOSH
C Arc hyperbolic tangent   arctanh (x)        ATANH(X)   DATANH  CATANH
C Relative error arc       (arctan (x) - x)   R9ATN1(X)  D9ATN1    --
C  tangent from first order   / x**3
C              ***Exponential Integrals and Related Functions***
C Exponential integral     Ei(x) = (minus)    EI(X)      DEI       --
C                          the integral from
C                          -x to infinity of
C                            (e**-t / t)dt
C Exponential integral     E sub 1 (x) =      E1(X)      DE1       --
C                          the integral from x
C                            to infinity of
C                          (e**-t / t) dt
C Logarithmic integral     li(x) = the        ALI(X)     DLI       --
C                          integral from 0 to
C                          x of (1 / ln t) dt
C   Sequences of exponential integrals.
C   M values are computed where
C   k=0,1,...M-1 and n>=1
C Exponential integral     E sub n+k (x) Call EXINT(X,   DEXINT    --
C                        =the integral from   N,KODE,M,TOL,
C                         1 to infinity of    EN,IERR)
C                       (e**(-x*t)/t**(n+k))dt
C                 ***Gamma Functions and Related Functions***
C Factorial                n!                 FAC(N)     DFAC      --
C Binomial                 n!/(m!*(n-m)!)     BINOM(N,M) DBINOM    --
C Gamma                    gamma(x)           GAMMA(X)   DGAMMA  CGAMMA
C Gamma(x) under and                     Call GAMLIM(    DGAMLM    --
C  overflow limits                           XMIN,XMAX)
C Reciprocal gamma         1 / gamma(x)       GAMR(X)    DGAMR   CGAMR
C Log abs gamma            ln \gamma(x)\      ALNGAM(X)  DLNGAM    --
C Log gamma                ln gamma(z)          --         --    CLNGAM
C Log abs gamma       g = ln \gamma(x)\  Call ALGAMS(X,  DLGAMS    --
C with sign           s = sign gamma(x)      G,S)
C Incomplete gamma         gamma(a,x) =       GAMI(A,X)  DGAMI     --
C                          the integral from
C                          0 to x of
C                         (t**(a-1) * e**-t)dt
C Complementary            gamma(a,x) =       GAMIC(A,X) DGAMIC    --
C  incomplete gamma        the integral from
C                          x to infinity of
C                         (t**(a-1) * e**-t)dt
C Tricomi's             gamma super star(a,x) GAMIT(A,X) DGAMIT    --
C  incomplete gamma        = x**-a *
C                         incomplete gamma(a,x)
C                          / gamma(a)
C Psi (Digamma)            psi(x) = gamma'(x) PSI(X)     DPSI    CPSI
C                          / gamma(x)
C Pochhammer's         (a) sub x = gamma(a+x) POCH(A,X)  DPOCH     --
C  generalized symbol      / gamma(a)
C Pochhammer's symbol    ((a) sub x -1) / x   POCH1(A,X) DPOCH1    --
C  from first order
C Beta                     b(a,b) = (gamma(a) BETA(A,B)  DBETA   CBETA
C                          * gamma(b))
C                          / gamma(a+b)
C                           = the integral
C                           from 0 to 1 of
C                           (t**(a-1) *
C                           (1-t)**(b-1))dt
C Log beta                 ln b(a,b)         ALBETA(A,B) DLBETA  CLBETA
C Incomplete beta          i sub x (a,b) =  BETAI(X,A,B) DBETAI    __
C                          b sub x (a,b) / b(a,b)
C                           = 1 / b(a,b) *
C                          the integral
C                          from 0 to x of
C                          (t**(a-1) *
C                          (1-t)**(b-1))dt
C Log gamma correction     ln gamma(x) -      R9LGMC(X)  D9LGMC  C9LGMC
C  term when Stirling's    (ln(2 * pi))/2 -
C  approximation is valid  (x - 1/2) * ln(x) + x
C                ***Error Functions and Fresnel Integrals***
C Error function           erf x = (2 /       ERF(X)     DERF      --
C                          square root of pi) *
C                          the integral from
C                          0 to x of
C                          e**(-t**2)dt
C Complementary            erfc x = (2 /      ERFC(X)    DERFC     --
C  error function          square root of pi) *
C                          the integral from
C                          x to infinity of
C                          e**(-t**2)dt
C Dawson's function        F(x) = e**(-x**2)  DAWS(X)    DDAWS     --
C                          * the integral from
C                          from 0 to x of
C                          e**(t**2)dt
C                         ***Bessel Functions***
C   Bessel functions of special integer order
C First kind, order zero   J sub 0 (x)        BESJ0(X)   DBESJ0    --
C First kind, order one    J sub 1 (x)        BESJ1(X)   DBESJ1    --
C Second kind, order zero  Y sub 0 (x)        BESY0(X)   DBESY0    --
C Second kind, order one   Y sub 1 (x)        BESY1(X)   DBESY1    --
C   Modified (hyperbolic) Bessel functions of special integer order
C First kind, order zero   I sub 0 (x)        BESI0(X)   DBESI0    --
C First kind, order one    I sub 1 (x)        BESI1(X)   DBESI1    --
C Third kind, order zero   K sub 0 (x)        BESK0(X)   DBESK0    --
C Third kind, order one    K sub 1 (x)        BESK1(X)   DBESK1    --
C   Modified (hyperbolic) Bessel functions of special integer order
C   scaled by an exponential
C First kind, order zero   e**-\x\ * I sub 0(x) BESI0E(X) DBSI0E   --
C First kind, order one    e**-\x\ * I sub 1(x) BESI1E(X) DBSI1E   --
C Third kind, order zero   e**x * K sub 0 (x)   BESK0E(X) DBSK0E   --
C Third kind, order one    e**x * K sub 1 (x)   BESK1E(X) DBSK1E   --
C   Sequences of Bessel functions of general order.
C   N values are computed where  k = 1,2,...N and v .ge. 0.
C Modified first kind      I sub v+k-1 (x) Call BESI(X,   DBESI    --
C                          optional scaling  ALPHA,KODE,N,
C                          by e**(-x)        Y,NZ)
C First kind               J sub v+k-1 (x) Call BESJ(X,   DBESJ    --
C                                            ALPHA,N,Y,NZ)
C Second kind              Y sub v+k-1 (x) Call BESY(X,   DBESY    --
C                                            FNU,N,Y)
C Modified third kind      K sub v+k-1 (x) Call BESK(X,   DBESK    --
C                          optional scaling  FNU,KODE,N,Y,
C                          by e**(x)         NZ)
C   Sequences of Bessel functions.  \N\ values are computed where
C   I = 0, 1, 2, ..., N-1  for N > 0  or I = 0, -1, -2, ..., N+1
C   for N < 0.
C Modified third kind      K sub v+i (x)   Call BESKS(    DBESKS   --
C                                           XNU,X,N,BK)
C   Sequences of Bessel functions scaled by an exponential.
C   \N\ values are computed where  I = 0, 1, 2, ..., N-1
C   for N > 0  or  I = 0, -1, -2, ..., N+1  for N < 0.
C Modified third kind      e**x *         Call BESKES(    DBSKES   --
C                          K sub v+i (x)     XNU,X,N,BK)
C                ***Bessel Functions of Fractional Order***
C   Airy functions
C Airy                     Ai(x)              AI(X)      DAI       --
C Bairy                    Bi(x)              BI(X)      DBI       --
C   Exponentially scaled Airy functions
C Airy                     Ai(x), x <= 0      AIE(X)     DAIE      --
C                          exp(2/3 * x**(3/2))
C                          * Ai(x), x >= 0
C Bairy                    Bi(x), x <= 0      BIE(X)     DBIE      --
C                          exp(-2/3 * x**(3/2))
C                          * Bi(x), x >= 0
C                 ***Confluent Hypergeometric Functions***
C Confluent                U(a,b,x)           CHU(A,B,X) DCHU      --
C  hypergeometric
C                     ***Miscellaneous Functions***
C Spence                   s(x) = - the       SPENC(X)   DSPENC    --
C  dilogarithm             integral from
C                          0 to x of
C                          ((ln \1-y\) / y)dy
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801015  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Routine name changed from FNLIBD to FUNDOC.  (WRB)
C   900723  PURPOSE section revised.  (WRB)
C***END PROLOGUE  FUNDOC
C***FIRST EXECUTABLE STATEMENT  FUNDOC
      RETURN
      END


module clock_mod
    implicit none

    type :: a_clock
        real :: current ! current time
        real :: total   ! total integration time
        real :: step    ! integration step
        real :: timer   ! cyclic time count for printing out
        real :: lap     ! cyclic period for printing out
    end type a_clock

    type(a_clock) :: clock

contains
    !---------------------------------------------------------------------------
    ! - read-in the integration step, the cyclic lap period, and the total time;
    ! - set the current time to zero;
    ! - set the cyclic time count to the cyclic lap period.
    subroutine clock_init()
        read *, clock%step
        read *, clock%lap
        read *, clock%total
        clock%current = 0.0
        clock%timer   = clock%lap
        return
    end subroutine clock_init
    !---------------------------------------------------------------------------
    ! - increment the current time by one step;
    ! - decremet the cyclic timer by one step.
    subroutine clock_next_step()
        clock%current = clock%current + clock%step
        clock%timer   = clock%timer   - clock%step
        return
    end subroutine clock_next_step
    !---------------------------------------------------------------------------
    logical function clock_timer_has_elapsed() result(has_elapsed)
        has_elapsed = ( clock%timer <= 0.0 )
        if (has_elapsed) clock%timer = clock%timer + clock%lap
        return
    end function clock_timer_has_elapsed
    !---------------------------------------------------------------------------
    logical function clock_time_is_not_over()
        clock_time_is_not_over = ( clock%current <= clock%total )
        return
    end function clock_time_is_not_over
    !---------------------------------------------------------------------------
end module clock_mod


c { dg-do run }
      program pr6177
C
C Test case for PR optimization/6177.
C This bug (an ICE) originally showed up in file cblat2.f from LAPACK.
C
      complex x
      complex w(1)
      intrinsic conjg
      x = (2.0d0, 1.0d0)
      w(1) = x
      x = conjg(x)
      w(1) = conjg(w(1))
      if (abs(x-w(1)) .gt. 1.0e-5) STOP 1
      end


!************************************************************
!
!  This example shows how to read and write data to an
!  external dataset.  The program first writes integers to an
!  external dataset with dataspace dimensions of DIM0xDIM1,
!  then closes the file.  Next, it reopens the file, reads
!  back the data, and outputs the name of the external data
!  file and the data to the screen.
!
!  This file is intended for use with HDF5 Library verion 1.8
!
! ************************************************************/

PROGRAM main

  USE HDF5

  IMPLICIT NONE

  CHARACTER(LEN=16), PARAMETER :: filename     = "h5ex_d_extern.h5"
  CHARACTER(LEN=18), PARAMETER :: externalname = "h5ex_d_extern.data"
  CHARACTER(LEN=3) , PARAMETER :: dataset  = "DS1"
  INTEGER          , PARAMETER :: dim0     = 4
  INTEGER          , PARAMETER :: dim1     = 7
  INTEGER(SIZE_T)  , PARAMETER :: name_buf_size = 32

  INTEGER :: hdferr
  INTEGER :: layout
  INTEGER(HID_T)  :: file, space, dset, dcpl ! Handles
  INTEGER(HSIZE_T), DIMENSION(1:2)   :: dims = (/dim0, dim1/)
  INTEGER(HSIZE_T), DIMENSION(1:2)   :: start, stride, count, block

  INTEGER, DIMENSION(1:dim0, 1:dim1) :: wdata, & ! Write buffer
                                        rdata    ! Read buffer
  CHARACTER(LEN=name_buf_size) :: name
  INTEGER :: i, j
  INTEGER(OFF_T) :: offset ! Offset, in bytes, from thebeginning of the file to the
                           ! location in the file where the data starts.
  INTEGER(HSIZE_T) :: bytes ! Number of bytes reserved in the file for the data
  INTEGER(SIZE_T) :: int_size ! size of integer
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! Initialize data.
  !
  DO i = 1, dim0
     DO j = 1, dim1
        wdata(i,j) = (i-1)*(j-1)-(j-1)
     ENDDO
  ENDDO
  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create dataspace.  Setting maximum size to NULL sets the maximum
  ! size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the dataset creation property list, set the external
  ! file.
  !
  CALL h5pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr)
  ! for HDF5 versions <= 1.8.2 use:
  CALL h5tget_size_f(H5T_NATIVE_INTEGER, int_size, hdferr)
  bytes = int_size*dim0*dim1
  ! else use:
  !   bytes = INT(H5F_UNLIMITED_F,HSIZE_T)
  CALL h5pset_external_f(dcpl, externalname, INT(0,OFF_T), bytes, hdferr)
  !
  ! Create the external dataset.
  !
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr, dcpl)
  !
  ! Write the data to the dataset.
  !
  CALL h5dwrite_f(dset, H5T_NATIVE_INTEGER, wdata, dims, hdferr)
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
  !
  ! Now we begin the read section of this example.
  !
  !
  ! Open file and dataset using the default properties.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f(file, dataset, dset, hdferr)
  !
  ! Retrieve dataset creation property list.
  !
  CALL H5Dget_create_plist_f(dset, dcpl, hdferr)
  !
  ! Retrieve and print the name of the external file.  Here we
  ! manually set the last field in name to null, in case the name of
  ! the file is longer than the buffer.
  !
  CALL H5Pget_external_f (dcpl, 0, name_buf_size, name, offset, bytes, hdferr)
  WRITE(*,'(A," is stored in file: ",A)')  dataset, TRIM(name)
  !
  ! Read the data using the default properties.
  !
  CALL h5dread_f(dset, H5T_NATIVE_INTEGER, rdata, dims, hdferr)
  !
  ! Output the data to the screen.
  !
  WRITE(*, '(A,":")') dataset
  DO i=1, dim0
     WRITE(*,'(" [")', ADVANCE='NO')
     WRITE(*,'(80i3)', ADVANCE='NO') rdata(i,:)
     WRITE(*,'(" ]")')
  ENDDO
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5fclose_f(file , hdferr)

END PROGRAM main


! { dg-do compile }
!
! PR fortran/44346
! Original test sumbitted by Vittorio Zecca, zeccav at gmail dot com.
! Modified by Steven G. Kargl for dejagnu testsuite.
!
program a
   integer :: j, i = 42
   j = ibits(i, -1, 1)    ! { dg-error "must be nonnegative" }
   j = ibits(i, 1, -1)    ! { dg-error "must be nonnegative" }
   j = ibits(i, 100, 100) ! { dg-error "must be less than" }
end program a


! chk_implied_shape --
!     Check: does the compiler support "implied shape" arrays?
!
program chk_implied_shape
    implicit none

    integer, parameter, dimension(*) :: values = (/ 1, 2, 3, 4 /)

    write( *, '(a)' )      'Parameter array:'
    write( *, '(a,i5)' )   '    Size:   ', size(values)
    write( *, '(a,10i5)' ) '    Values: ', values

end program chk_implied_shape


program messing_up
    implicit none
    integer :: i, n, step

    n = 10
    step = 1
    do i = 1, n, step
        print *, i
        if (i == 2) n = 10
        step = 2
    end do
end program messing_up


      subroutine foo(a)
      integer a
cf2py intent(in,out) :: a
      a = a + 5
      end


module mod_one
    implicit none
contains
    subroutine one(a,b,c,d)
        use mod_two
        implicit none
		REAL,INTENT(IN) :: a,b,c
		REAL,INTENT(OUT) :: d

        call two(a,b,c,d)

    end subroutine one
end module mod_one


module mumps_mod

   save
  ! integer,parameter:: ui_out = 10  ! unit for mumps log file
   !integer,parameter:: st_unit=11  ! unit for output statistics file

   INCLUDE 'dmumps_struc.h'

   !logical,private:: mumps_initialized = .false.

contains

!---------------------------------------------------------------

subroutine init( mumps_par, sym )

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: sym  ! =0 unsymmetric, =1 symm. pos def, =2 general symm.

   !mumps_par%COMM = MPI_COMM_WORLD
   mumps_par%SYM = sym  ! =0 unsymmetric, =1 symm. pos def, =2 general symm.
   mumps_par%PAR = 1

   mumps_par%JOB = -1  ! initialize
   CALL DMUMPS(mumps_par)

   !if (mumps_par%MYID == 0) then
    !  open(unit=ui_out, file='mumps.log', action='write')
   !end if

   !mumps_initialized = .true.

return
end subroutine init

!---------------------------------------------------------------

subroutine convert_to_mumps_format( mumps_par, n, A,jA,iA, ierr )
! A is actually a transpose.
implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: n  ! # of rows in A
real(kind=8),intent(in):: A(*)
integer(kind=8),intent(in):: jA(*), iA(n+1)
integer(kind=8),intent(out):: ierr

integer nonz, i,j, j1,j2, ind, jcol, istat

nonz = iA(n+1) - 1
!n = size(iA) - 1

mumps_par%N = n

if (mumps_par%SYM == 0) then  ! not symmetric matrix
   mumps_par%NZ = nonz
   allocate( mumps_par%IRN(nonz), mumps_par%JCN(nonz), mumps_par%A(nonz), stat=istat)
   if ( istat /= 0 ) then
      ierr = -13  ! allocation error
      return
   end if

   do i = 1, n
      mumps_par%JCN( iA(i) : iA(i+1)-1 )  =  i
   end do  ! i

   mumps_par%IRN = jA(1:nonz)
   mumps_par%A    = A(1:nonz)

else  ! symmetric matrix
   ! Keep only the lower half of the matrix (row >= column).

   nonz = nonz/2 + n  ! should be +n/2, but I'm using n just in case.
   allocate( mumps_par%IRN(nonz), mumps_par%JCN(nonz), mumps_par%A(nonz), stat=istat)
   if ( istat /= 0 ) then
      ierr = -13  ! allocation error
      return
   end if

   ind = 0
   do i = 1, n

      j1 = iA(i)
      j2 = iA(i+1) - 1
      do j = j1, j2
         jcol = jA(j)

         if (i >= jcol) then
            ind = ind + 1
            mumps_par%A(ind) = A(j)
            mumps_par%JCN(ind) = jcol
            mumps_par%IRN(ind) = i
         end if

      end do  ! j
   end do  ! i

   mumps_par%NZ = ind
   !if (nonz < ind) call errorstop('nonz < ind')  ! debug
end if

ierr = 0
return
end subroutine convert_to_mumps_format

!---------------------------------------------------------------

subroutine factor_matrix( mumps_par, ierr )

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(out):: ierr

!mumps_par%icntl(2) = 6  ! output stream for diagnostics
mumps_par%icntl(4) = 0 ! 1  ! amount of output

mumps_par%icntl(2) = 0 ! ui_out  ! output stream for diagnostic printing
mumps_par%icntl(3) = 0 ! ui_out  ! output stream for global information

!mumps_par%icntl(14) = 40 ! % increase in working space

!mumps_par%icntl(11) = 0 ! return statistics
! mumps_par%icntl(7) = 5  ! ordering type
!mumps_par%cntl(1) = 0.d0  ! rel. threshold for numerical pivoting

mumps_factorization: do

   mumps_par%JOB = 1  !  analysis
   CALL DMUMPS(mumps_par)

   mumps_par%JOB = 2  !  factorization
   CALL DMUMPS(mumps_par)

   ierr = mumps_par%INFOG(1)

   if ( mumps_par%INFOG(1) == -9 .or. mumps_par%INFOG(1) == -8 ) then
      ! Main internal real/complex workarray S too small.
      mumps_par%icntl(14) = mumps_par%icntl(14) + 10
      if ( mumps_par%MYID == 0 ) then
         write(*,30) mumps_par%icntl(14)
         30 format(/'MUMPS percentage increase in the estimated working space',  &
                   /'increased to',i4)
      end if

   !else if (mumps_par%INFOG(1) == -13) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,40)
   !      40 format(/'MUMPS memory allocation error.'/)
   !   end if
   !   stop

   !else if (mumps_par%INFOG(1) == -10) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,45)
   !      45 format(/'MUMPS ERROR: Numerically singular matrix.'/)
   !   end if
   !   stop

   !else if (mumps_par%INFOG(1) == -40) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,46)
   !      46 format(/'MUMPS ERROR: matrix is not positive definite.'/)
   !   end if
   !   stop

   !else if ( mumps_par%INFOG(1) < 0 ) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,20) mumps_par%INFOG(1), mumps_par%INFOG(2)
   !      20 format(/'ERROR occured in MUMPS!',/,'INFOG(1), INFOG(2) ', 2i6,/)
   !   end if
   !   stop

   else
      exit mumps_factorization ! factorization successful
   end if

end do mumps_factorization

if ( mumps_par%MYID == 0 ) then
   !flush(ui_out)
   ! Turn off mumps output.
   mumps_par%icntl(2) = 0  ! output stream for diagnostic printing
   mumps_par%icntl(3) = 0  ! output stream for global information
end if

return
end subroutine factor_matrix

!--------------------------------------------------------------

subroutine solve( mumps_par, nrhs, rhs, x, transpose )
! Solve A*x = rhs

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: nrhs   ! # of right-hand-sides
real(kind=8),intent(in):: rhs(nrhs * mumps_par%N)
real(kind=8),intent(out),target:: x(nrhs * mumps_par%N)  ! solution
logical,intent(in):: transpose  ! if .true. take the transpose

   x = rhs

   mumps_par%RHS => x

   ! The following is significant only on the host cpu.
   mumps_par%NRHS = nrhs  ! # of right-hand-sides
   mumps_par%LRHS = mumps_par%N  ! size of system

   if (transpose) then
      mumps_par%icntl(9) = 0  ! for solving A'x = b
   else
      mumps_par%icntl(9) = 1  ! for solving Ax = b
   end if

   mumps_par%JOB = 3  ! Solve the system.
   CALL DMUMPS(mumps_par)
   ! At this point mumps_par%RHS (rhs) contains the solution.

return
end subroutine solve

!--------------------------------------------------------------

subroutine destroy(mumps_par)

implicit none
TYPE (DMUMPS_STRUC),intent(inout):: mumps_par

!if (.not. mumps_initialized)  return

!  Destroy the instance (deallocate internal data structures)
mumps_par%JOB = -2
CALL DMUMPS(mumps_par)

if (associated(mumps_par%A)) then
   deallocate(mumps_par%IRN, mumps_par%JCN, mumps_par%A)
end if

!if (mumps_par%MYID == 0) then
!   close(ui_out)
!end if

return
end subroutine destroy

end module mumps_mod


program decl_double
double precision :: i
end program decl_double


subroutine simple(a,b,c)

	real, intent(in) :: a, b
	real, intent(out) :: c

	c = a + b

end subroutine simple


! { dg-do compile }
! PR 34549 - a real value was accepted for shift.
program main
  implicit none
  real, dimension(2,2) :: r
  data r /1.0, 2.0, 3.0, 4.0/
  print *,cshift(r,shift=2.3,dim=1) ! { dg-error "must be INTEGER" }
end program main


! ****************************************************************************
! ... Module for variable types
! ... COSMO Project
! ... Quim Ballabrera, March 2017
! ****************************************************************************

MODULE types

IMPLICIT NONE

PRIVATE
PUBLIC sp,dp

INTEGER, PARAMETER                 :: sp = KIND(0.0)    ! Single precision
INTEGER, PARAMETER                 :: dp = KIND(0.0D0)  ! Double precision

END MODULE types


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


program Nested_If
    implicit none
    integer :: x

    x = 8

    if (x >= 10) then
        if (x >= 15) then
            print *, "X is greater than or equal to 15"
        else
            print *, "X is less than 15 and greater than ten"
        end if
    else
        print *, "X is less than 10"
    end if

end program Nested_If