!===================================================================================================================================
! This module and the example function squarei() that uses it shows how you
! can use polymorphism to allow arguments of different types generically by casting
!===================================================================================================================================
!>
!!##NAME
!!    M_anything(3fm) - [M_anything::INTRO] procedures that use polymorphism to allow arguments of different types generically
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!   use M_anything,only : anyinteger_to_string
!!   use M_anything,only : anyscalar_to_int64
!!   use M_anything,only : anyscalar_to_real
!!   use M_anything,only : anyscalar_to_real128
!!   use M_anything,only : anyscalar_to_double
!!   use M_anything,only : anything_to_bytes
!!   use M_anything,only : bytes_to_anything
!!   use M_anything,only : empty, assignment(=)
!!
!!##DESCRIPTION
!!    anyinteger_to_string    convert integer parameter of any kind to string
!!    anyscalar_to_int64      convert integer parameter of any kind to 64-bit integer
!!    anyscalar_to_real       convert integer or real parameter of any kind to real
!!    anyscalar_to_real128    convert integer or real parameter of any kind to real128
!!    anyscalar_to_double     convert integer or real parameter of any kind to doubleprecision
!!    anything_to_bytes       convert anything to bytes
!!    empty                   create an empty array
!!
!!##EXAMPLE
!!
!!
!! At the cost of casting to a different type these functions can
!! (among other uses such as in linked lists) allow for an alternative
!! to duplicating code using generic procedure methods. For example,
!! the following SQUAREALL function can take many input types and return a
!! DOUBLEPRECISION value (it is a trivial example for demonstration purposes,
!! and does not check for overflow, etc.).:
!!
!!   Sample program
!!
!!     program demo_anyscalar_to_double
!!     use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!     use, intrinsic :: iso_fortran_env, only : real32, real64, real128
!!     implicit none
!!        ! call same function with many scalar input types
!!        write(*,*)squareall(2_int8)
!!        write(*,*)squareall(2_int16)
!!        write(*,*)squareall(2_int32)
!!        write(*,*)squareall(2_int64)
!!        write(*,*)squareall(2.0_real32)
!!        write(*,*)squareall(2.0_real64)
!!        write(*,*)squareall(2.0_real128)
!!     contains
!!
!!     function squareall(invalue) result (dvalue)
!!     use M_anything, only : anyscalar_to_double
!!     class(*),intent(in)  :: invalue
!!     doubleprecision      :: invalue_local
!!     doubleprecision      :: dvalue
!!        invalue_local=anyscalar_to_double(invalue)
!!        dvalue=invalue_local*invalue_local
!!     end function squareall
!!
!!     end program demo_anyscalar_to_double
!!
!!   Results:
!!
!!       4.00000000000000
!!       4.00000000000000
!!       4.00000000000000
!!       4.00000000000000
!!       4.00000000000000
!!       4.00000000000000
!!       4.00000000000000
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
module M_anything
use, intrinsic :: ISO_FORTRAN_ENV, only : INT8, INT16, INT32, INT64       !  1           2           4           8
use, intrinsic :: ISO_FORTRAN_ENV, only : REAL32, REAL64, REAL128         !  4           8          10
implicit none
private
integer,parameter        :: dp=kind(0.0d0)
public anyinteger_to_string  ! convert integer parameter of any kind to string
public anyscalar_to_int64    ! convert integer parameter of any kind to 64-bit integer
public anyscalar_to_real     ! convert integer or real parameter of any kind to real
public anyscalar_to_real128  ! convert integer or real parameter of any kind to real128
public anyscalar_to_double   ! convert integer or real parameter of any kind to doubleprecision
public anything_to_bytes
public bytes_to_anything
!!public setany

interface anything_to_bytes
   module procedure anything_to_bytes_arr
   module procedure anything_to_bytes_scalar
end interface anything_to_bytes
!===================================================================================================================================
!   Because there is no builtin "empty array" object, I've tried to mimic
!   it with some user-defined type (just for fun).  -- spectrum
!
! So, if there is a language support, it might be not too difficult
! to think of a common "empty array" thing (though not sure if it is
! sufficiently useful).
!
public empty, assignment(=)

   type Empty_t
   endtype
   type(Empty_t) empty   !! singleton

   interface assignment(=)
       module procedure  &
       & ints_empty_,    &
       & reals_empty_,   &
       & doubles_empty_, &
       & strings_empty_
   endinterface

contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    empty(3f) - [M_anything] set an allocatable array to zero
!!    (LICENSE:MIT)
!!##SYNOPSIS
!!
!!    use M_anything, only : empty, assignment(=)
!!##DESCRIPTION
!!    A convenience routine that sets an array to an empty set.
!!##EXAMPLE
!!
!!
!!   Sample program:
!!
!!    program demo_empty_
!!    use M_anything, only : empty, assignment(=)
!!    integer, allocatable      :: ints(:)
!!    character(:), allocatable :: strs(:)
!!    real, allocatable      :: reals(:)
!!       ints=empty
!!       write(*,*)size(ints)
!!
!!       write(*,*)'give them some size ...'
!!       reals = [1.0,2.0,3.0]
!!       ints = [1,2,3]
!!       strs = [character(len=10) :: "one","two","three","four"]
!!       write(*,*)size(ints)
!!       write(*,*)size(reals)
!!       write(*,*)size(strs)
!!
!!       ints=empty
!!       reals=empty
!!       strs=empty
!!       write(*,*)'back to empty ...'
!!       write(*,*)size(ints)
!!       write(*,*)size(reals)
!!       write(*,*)size(strs)
!!
!!    end program demo_empty_
!!
!!   Expected output:
!!
!!    >             0
!!    >   give them some size ...
!!    >             3
!!    >             3
!!    >             4
!!    >   back to empty ...
!!    >             0
!!    >             0
!!    >             0
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
   subroutine ints_empty_( x, emp )
       integer, allocatable, intent(inout) :: x(:)
       type(Empty_t), intent(in) :: emp
       if ( allocated( x ) ) deallocate( x )
       allocate( x( 0 ) )
   end subroutine ints_empty_

   subroutine doubles_empty_( x, emp )
       doubleprecision, allocatable, intent(inout) :: x(:)
       type(Empty_t), intent(in) :: emp
       if ( allocated( x ) ) deallocate( x )
       allocate( x( 0 ) )
   end subroutine doubles_empty_

   subroutine reals_empty_( x, emp )
       real, allocatable, intent(inout) :: x(:)
       type(Empty_t), intent(in) :: emp
       if ( allocated( x ) ) deallocate( x )
       allocate( x( 0 ) )
   end subroutine reals_empty_

   subroutine strings_empty_( x, emp )
       character(:), allocatable, intent(inout) :: x(:)
       type(Empty_t), intent(in) :: emp
       if ( allocated( x ) ) deallocate( x )
       allocate( character(0) :: x( 0 ) )
   end subroutine strings_empty_
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    bytes_to_anything(3f) - [M_anything] convert bytes(character)len=1):: array(:)) to standard types
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!   subroutine bytes_to_anything(chars,anything)
!!
!!    character(len=1),allocatable :: chars(:)
!!    class(*) :: anything
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow input arguments of different
!!    types. It is used to create other procedures that can take many
!!    argument types as input options and convert them to a single type
!!    to simplify storing arbitrary data, to simplify generating data
!!    hashes, ...
!!
!!##OPTIONS
!!    CHARS     The input value is an array of bytes (character(len=1)).
!!
!!##RETURN
!!    ANYTHING  May be of KIND INTEGER(kind=int8), INTEGER(kind=int16),
!!              INTEGER(kind=int32), INTEGER(kind=int64),
!!              REAL(kind=real32, REAL(kind=real64),
!!              REAL(kind=real128), complex, or CHARACTER(len=*)
!!
!!##EXAMPLE
!!
!!
!!   Sample program
!!
!!   Expected output
!!
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT
subroutine bytes_to_anything(chars,anything)
   character(len=1),allocatable :: chars(:)
   class(*) :: anything
   select type(anything)
    type is (character(len=*));     anything=transfer(chars,anything)
    type is (complex);              anything=transfer(chars,anything)
    type is (complex(kind=dp));     anything=transfer(chars,anything)
    type is (integer(kind=int8));   anything=transfer(chars,anything)
    type is (integer(kind=int16));  anything=transfer(chars,anything)
    type is (integer(kind=int32));  anything=transfer(chars,anything)
    type is (integer(kind=int64));  anything=transfer(chars,anything)
    type is (real(kind=real32));    anything=transfer(chars,anything)
    type is (real(kind=real64));    anything=transfer(chars,anything)
    type is (real(kind=real128));   anything=transfer(chars,anything)
    type is (logical);              anything=transfer(chars,anything)
    class default
      stop 'crud. bytes_to_anything(1) does not know about this type'
   end select
end subroutine bytes_to_anything
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    anything_to_bytes(3f) - [M_anything] convert standard types to bytes (character(len=1):: array(:))
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    function anything_to_bytes_arr(anything) result(chars)
!!
!!     class(*),intent(in)  :: anything
!!             or
!!     class(*),intent(in)  :: anything(:)
!!
!!     character(len=1),allocatable :: chars(:)
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow input arguments of different
!!    types. It is used to create other procedures that can take many
!!    argument types as input options and convert them to a single type
!!    to simplify storing arbitrary data, to simplify generating data
!!    hashes, ...
!!
!!##OPTIONS
!!
!!    VALUEIN  input array or scalar to convert to type CHARACTER(LEN=1).
!!             May be of KIND INTEGER(kind=int8), INTEGER(kind=int16),
!!             INTEGER(kind=int32), INTEGER(kind=int64),
!!             REAL(kind=real32, REAL(kind=real64),
!!             REAL(kind=real128), complex, or CHARACTER(len=*)
!!##RETURN
!!
!!    CHARS    The returned value is an array of bytes (character(len=1)).
!!
!!##EXAMPLE
!!
!!
!!   Sample program
!!
!!    program demo_anything_to_bytes
!!    use M_anything,      only : anything_to_bytes
!!    !!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!    !!use, intrinsic :: iso_fortran_env, only : real32, real64, real128
!!    implicit none
!!    integer :: i
!!       write(*,'(/,4(1x,z2.2))')anything_to_bytes([(i*i,i=1,10)])
!!       write(*,'(/,4(1x,z2.2))')anything_to_bytes([11.11,22.22,33.33])
!!       write(*,'(/,4(1x,z2.2))')anything_to_bytes('This is a string')
!!    end program demo_anything_to_bytes
!!
!!   Expected output
!!
!!        01 00 00 00
!!        04 00 00 00
!!        09 00 00 00
!!        10 00 00 00
!!        19 00 00 00
!!        24 00 00 00
!!        31 00 00 00
!!        40 00 00 00
!!        51 00 00 00
!!        64 00 00 00
!!
!!        8F C2 31 41
!!        8F C2 B1 41
!!        EC 51 05 42
!!
!!        54 68 69 73
!!        20 69 73 20
!!        61 20 73 74
!!        72 69 6E 67
!!
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT
function anything_to_bytes_arr(anything) result(chars)
implicit none

! ident_1="@(#)M_anything::anything_to_bytes_arr(3fp): any vector of intrinsics to bytes (an array of CHARACTER(LEN=1) variables)"

class(*),intent(in)          :: anything(:)
character(len=1),allocatable :: chars(:)
   select type(anything)

    type is (character(len=*));     chars=transfer(anything,chars)
    type is (complex);              chars=transfer(anything,chars)
    type is (complex(kind=dp));     chars=transfer(anything,chars)
    type is (integer(kind=int8));   chars=transfer(anything,chars)
    type is (integer(kind=int16));  chars=transfer(anything,chars)
    type is (integer(kind=int32));  chars=transfer(anything,chars)
    type is (integer(kind=int64));  chars=transfer(anything,chars)
    type is (real(kind=real32));    chars=transfer(anything,chars)
    type is (real(kind=real64));    chars=transfer(anything,chars)
    type is (real(kind=real128));   chars=transfer(anything,chars)
    type is (logical);              chars=transfer(anything,chars)
    class default
      stop 'crud. anything_to_bytes_arr(1) does not know about this type'

   end select
end function anything_to_bytes_arr
!-----------------------------------------------------------------------------------------------------------------------------------
function  anything_to_bytes_scalar(anything) result(chars)
implicit none

! ident_2="@(#)M_anything::anything_to_bytes_scalar(3fp): anything to bytes (an array of CHARACTER(LEN=1) variables)"

class(*),intent(in)          :: anything
character(len=1),allocatable :: chars(:)
   select type(anything)

    type is (character(len=*));     chars=transfer(anything,chars)
    type is (complex);              chars=transfer(anything,chars)
    type is (complex(kind=dp));     chars=transfer(anything,chars)
    type is (integer(kind=int8));   chars=transfer(anything,chars)
    type is (integer(kind=int16));  chars=transfer(anything,chars)
    type is (integer(kind=int32));  chars=transfer(anything,chars)
    type is (integer(kind=int64));  chars=transfer(anything,chars)
    type is (real(kind=real32));    chars=transfer(anything,chars)
    type is (real(kind=real64));    chars=transfer(anything,chars)
    type is (real(kind=real128));   chars=transfer(anything,chars)
    type is (logical);              chars=transfer(anything,chars)
    class default
      stop 'crud. anything_to_bytes_scalar(1) does not know about this type'

   end select
end function  anything_to_bytes_scalar
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!!subroutine setany(anything,default,answer)
!!implicit none
!!
!!$@(#) M_anything::setany(3fp): set absent parameter to default value
!!
!!class(*),intent(in),optional     :: anything
!!class(*),intent(in)              :: default
!!class(*),intent(out),allocatable :: answer
!!if(present(anything))then
!!   answer=anything
!!else
!!   answer=default
!!endif
!!end subroutine setany
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    anyscalar_to_real128(3f) - [M_anything] convert integer or real parameter of any kind to real128
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    pure elemental function anyscalar_to_real128(valuein) result(d_out)
!!
!!     class(*),intent(in) :: valuein
!!     real(kind=128)      :: d_out
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow input arguments of different
!!    types. It is used to create other procedures that can take many
!!    scalar arguments as input options.
!!
!!##OPTIONS
!!
!!    VALUEIN  input argument of a procedure to convert to type REAL128.
!!             May be of KIND kind=int8, kind=int16, kind=int32, kind=int64,
!!             kind=real32, kind=real64, or kind=real128
!!
!!##RESULTS
!!
!!    D_OUT    The value of VALUIN converted to REAL128 (assuming
!!             it is actually in the range of type REAL128).
!!
!!##EXAMPLE
!!
!!
!!   Sample program
!!
!!     program demo_anyscalar_to_real128
!!     use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!     use, intrinsic :: iso_fortran_env, only : real32, real64, real128
!!     implicit none
!!        ! call same function with many scalar input types
!!        write(*,*)squarei(2_int8)
!!        write(*,*)squarei(2_int16)
!!        write(*,*)squarei(2_int32)
!!        write(*,*)squarei(2_int64)
!!        write(*,*)squarei(2.0_real32)
!!        write(*,*)squarei(2.0_real64)
!!        write(*,*)squarei(2.0_real128)
!!     contains
!!
!!     function squarei(invalue) result (dvalue)
!!     use M_anything, only : anyscalar_to_real128
!!     class(*),intent(in)  :: invalue
!!     real(kind=real128)   :: invalue_local
!!     real(kind=real128)   :: dvalue
!!        invalue_local=anyscalar_to_real128(invalue)
!!        dvalue=invalue_local*invalue_local
!!     end function squarei
!!
!!     end program demo_anyscalar_to_real128
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
pure elemental function anyscalar_to_real128(valuein) result(d_out)
use, intrinsic :: iso_fortran_env, only : error_unit !! ,input_unit,output_unit
implicit none

! ident_3="@(#)M_anything::anyscalar_to_real128(3f): convert integer or real parameter of any kind to real128"

class(*),intent(in)          :: valuein
real(kind=real128)           :: d_out
character(len=3)             :: readable
   select type(valuein)
   type is (integer(kind=int8));   d_out=real(valuein,kind=real128)
   type is (integer(kind=int16));  d_out=real(valuein,kind=real128)
   type is (integer(kind=int32));  d_out=real(valuein,kind=real128)
   type is (integer(kind=int64));  d_out=real(valuein,kind=real128)
   type is (real(kind=real32));    d_out=real(valuein,kind=real128)
   type is (real(kind=real64));    d_out=real(valuein,kind=real128)
   Type is (real(kind=real128));   d_out=valuein
   type is (logical);              d_out=merge(0.0_real128,1.0_real128,valuein)
   type is (character(len=*));     read(valuein,*) d_out
   class default
    !!d_out=huge(0.0_real128)
    readable='NaN'
    read(readable,*)d_out
    !!stop '*M_anything::anyscalar_to_real128: unknown type'
   end select
end function anyscalar_to_real128
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    anyscalar_to_double(3f) - [M_anything] convert integer or real parameter of any kind to doubleprecision
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    pure elemental function anyscalar_to_double(valuein) result(d_out)
!!
!!     class(*),intent(in)  :: valuein
!!     doubleprecision      :: d_out
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow input arguments of different
!!    types. It is used to create other procedures that can take many
!!    scalar arguments as input options.
!!
!!##OPTIONS
!!
!!    VALUEIN  input argument of a procedure to convert to type DOUBLEPRECISION.
!!             May be of KIND kind=int8, kind=int16, kind=int32, kind=int64,
!!             kind=real32, kind=real64, or kind=real128
!!
!!##RESULTS
!!
!!    D_OUT    The value of VALUIN converted to doubleprecision (assuming
!!             it is actually in the range of type DOUBLEPRECISION).
!!
!!##EXAMPLE
!!
!!
!!   Sample program
!!
!!     program demo_anyscalar_to_double
!!     use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!     use, intrinsic :: iso_fortran_env, only : real32, real64, real128
!!     implicit none
!!        ! call same function with many scalar input types
!!        write(*,*)squarei(2_int8)
!!        write(*,*)squarei(2_int16)
!!        write(*,*)squarei(2_int32)
!!        write(*,*)squarei(2_int64)
!!        write(*,*)squarei(2.0_real32)
!!        write(*,*)squarei(2.0_real64)
!!        write(*,*)squarei(2.0_real128)
!!     contains
!!
!!     function squarei(invalue) result (dvalue)
!!     use M_anything, only : anyscalar_to_double
!!     class(*),intent(in)  :: invalue
!!     doubleprecision      :: invalue_local
!!     doubleprecision      :: dvalue
!!        invalue_local=anyscalar_to_double(invalue)
!!        dvalue=invalue_local*invalue_local
!!     end function squarei
!!
!!     end program demo_anyscalar_to_double
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
pure elemental function anyscalar_to_double(valuein) result(d_out)
use, intrinsic :: iso_fortran_env, only : error_unit !! ,input_unit,output_unit
implicit none

! ident_4="@(#)M_anything::anyscalar_to_double(3f): convert integer or real parameter of any kind to doubleprecision"

class(*),intent(in)       :: valuein
doubleprecision           :: d_out
doubleprecision,parameter :: big=huge(0.0d0)
   select type(valuein)
   type is (integer(kind=int8));   d_out=dble(valuein)
   type is (integer(kind=int16));  d_out=dble(valuein)
   type is (integer(kind=int32));  d_out=dble(valuein)
   type is (integer(kind=int64));  d_out=dble(valuein)
   type is (real(kind=real32));    d_out=dble(valuein)
   type is (real(kind=real64));    d_out=dble(valuein)
   Type is (real(kind=real128))
      !!if(valuein.gt.big)then
      !!   write(error_unit,*)'*anyscalar_to_double* value too large ',valuein
      !!endif
      d_out=dble(valuein)
   type is (logical);              d_out=merge(0.0d0,1.0d0,valuein)
   type is (character(len=*));      read(valuein,*) d_out
   !type is (real(kind=real128))
   !   if(valuein.gt.big)then
   !      write(error_unit,*)'*anyscalar_to_double* value too large ',valuein
   !   endif
   !   d_out=dble(valuein)
   class default
     d_out=0.0d0
     !!stop '*M_anything::anyscalar_to_double: unknown type'
   end select
end function anyscalar_to_double
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    anyscalar_to_real(3f) - [M_anything] convert integer or real parameter of any kind to real
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    pure elemental function anyscalar_to_real(valuein) result(r_out)
!!
!!     class(*),intent(in)  :: valuein
!!     real                 :: r_out
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow input arguments of different types.
!!    It is used to create other procedures that can take
!!    many scalar arguments as input options.
!!
!!##OPTIONS
!!
!!    VALUEIN  input argument of a procedure to convert to type REAL.
!!             May be of KIND kind=int8, kind=int16, kind=int32, kind=int64,
!!             kind=real32, kind=real64, or kind=real128.
!!
!!##RESULTS
!!
!!    R_OUT    The value of VALUIN converted to real (assuming it is actually
!!             in the range of type REAL).
!!
!!##EXAMPLE
!!
!!   Sample program
!!
!!     program demo_anyscalar_to_real
!!     use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!     use, intrinsic :: iso_fortran_env, only : real32, real64, real128
!!     implicit none
!!        ! call same function with many scalar input types
!!        write(*,*)squarei(2_int8)
!!        write(*,*)squarei(2_int16)
!!        write(*,*)squarei(2_int32)
!!        write(*,*)squarei(2_int64)
!!        write(*,*)squarei(2.0_real32)
!!        write(*,*)squarei(2.0_real64)
!!        write(*,*)squarei(2.0_real128)
!!     contains
!!
!!     function squarei(invalue) result (dvalue)
!!     use M_anything, only : anyscalar_to_real
!!     class(*),intent(in)  :: invalue
!!     real                 :: invalue_local
!!     real                 :: dvalue
!!        invalue_local=anyscalar_to_real(invalue)
!!        dvalue=invalue_local*invalue_local
!!     end function squarei
!!
!!     end program demo_anyscalar_to_real
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
pure elemental function anyscalar_to_real(valuein) result(r_out)
use, intrinsic :: iso_fortran_env, only : error_unit !! ,input_unit,output_unit
implicit none

! ident_5="@(#)M_anything::anyscalar_to_real(3f): convert integer or real parameter of any kind to real"

class(*),intent(in) :: valuein
real                :: r_out
real,parameter      :: big=huge(0.0)
   select type(valuein)
   type is (integer(kind=int8));   r_out=real(valuein)
   type is (integer(kind=int16));  r_out=real(valuein)
   type is (integer(kind=int32));  r_out=real(valuein)
   type is (integer(kind=int64));  r_out=real(valuein)
   type is (real(kind=real32));    r_out=real(valuein)
   type is (real(kind=real64))
      !!if(valuein.gt.big)then
      !!   write(error_unit,*)'*anyscalar_to_real* value too large ',valuein
      !!endif
      r_out=real(valuein)
   type is (real(kind=real128))
      !!if(valuein.gt.big)then
      !!   write(error_unit,*)'*anyscalar_to_real* value too large ',valuein
      !!endif
      r_out=real(valuein)
   type is (logical);              r_out=merge(0.0d0,1.0d0,valuein)
   type is (character(len=*));     read(valuein,*) r_out
   !type is (real(kind=real128));  r_out=real(valuein)
   end select
end function anyscalar_to_real
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!
!!    anyscalar_to_int64(3f) - [M_anything] convert integer any kind to integer(kind=int64)
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!
!!    impure elemental function anyscalar_to_int64(intin) result(value)
!!
!!     class(*),intent(in) :: intin
!!     integer(kind=int64) :: value
!!
!!##DESCRIPTION
!!
!!    This function uses polymorphism to allow arguments of different INTEGER types
!!    as input. It is typically used to create other procedures that can take
!!    many scalar arguments as input options, equivalent to passing the
!!    parameter VALUE as int(VALUE,0_int64).
!!
!!##OPTIONS
!!
!!    VALUEIN  input argument of a procedure to convert to type INTEGER(KIND=int64).
!!             May be of KIND kind=int8, kind=int16, kind=int32, kind=int64.
!!
!!##RESULTS
!!             The value of VALUIN converted to INTEGER(KIND=INT64).
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_anyscalar_to_int64
!!     use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!     implicit none
!!        ! call same function with many scalar input types
!!        write(*,*)squarei(huge(0_int8)),huge(0_int8) , &
!!        & '16129'
!!        write(*,*)squarei(huge(0_int16)),huge(0_int16) , &
!!        & '1073676289'
!!        write(*,*)squarei(huge(0_int32)),huge(0_int32) , &
!!        & '4611686014132420609'
!!        write(*,*)squarei(huge(0_int64)),huge(0_int64) , &
!!        & '85070591730234615847396907784232501249'
!!     contains
!!     !
!!     function squarei(invalue)
!!     use M_anything, only : anyscalar_to_int64
!!     class(*),intent(in)  :: invalue
!!     doubleprecision      :: invalue_local
!!     doubleprecision      :: squarei
!!        invalue_local=anyscalar_to_int64(invalue)
!!        squarei=invalue_local*invalue_local
!!     end function squarei
!!     !
!!     end program demo_anyscalar_to_int64
!!
!!   Results
!!
!!    16129.000000000000       127 \
!!    16129
!!    1073676289.0000000       32767 \
!!    1073676289
!!    4.6116860141324206E+018  2147483647 \
!!    4611686014132420609
!!    8.5070591730234616E+037  9223372036854775807 \
!!    85070591730234615847396907784232501249
!!    2.8948022309329049E+076 170141183460469231731687303715884105727 \
!!    28948022309329048855892746252171976962977213799489202546401021394546514198529
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
impure elemental function anyscalar_to_int64(valuein) result(ii38)
use, intrinsic :: iso_fortran_env, only : error_unit !! ,input_unit,output_unit
implicit none

! ident_6="@(#)M_anything::anyscalar_to_int64(3f): convert integer parameter of any kind to 64-bit integer"

class(*),intent(in)    :: valuein
   integer(kind=int64) :: ii38
   integer             :: ios
   character(len=256)  :: message
   select type(valuein)
   type is (integer(kind=int8));   ii38=int(valuein,kind=int64)
   type is (integer(kind=int16));  ii38=int(valuein,kind=int64)
   type is (integer(kind=int32));  ii38=valuein
   type is (integer(kind=int64));  ii38=valuein
   type is (real(kind=real32));    ii38=int(valuein,kind=int64)
   type is (real(kind=real64));    ii38=int(valuein,kind=int64)
   Type is (real(kind=real128));   ii38=int(valuein,kind=int64)
   type is (logical);              ii38=merge(0_int64,1_int64,valuein)
   type is (character(len=*))   ;
      read(valuein,*,iostat=ios,iomsg=message)ii38
      if(ios.ne.0)then
         write(error_unit,*)'*anyscalar_to_int64* ERROR: '//trim(message)
         stop 2
      endif
   class default
      write(error_unit,*)'*anyscalar_to_int64* ERROR: unknown integer type'
      stop 3
   end select
end function anyscalar_to_int64
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!
!!    anyinteger_to_string(3f) - [M_anything] convert integer of any kind to a string
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    impure function anyinteger_to_string(intin) result(str)
!!
!!     character(len=:),allocatable :: anyinteger_to_string
!!     class(*),intent(in)          :: intin
!!
!!##DESCRIPTION
!!
!!    Converts an integer value to a string representing the value.
!!    This function allows arguments of different INTEGER types as input.
!!
!!##OPTIONS
!!
!!    VALUEIN  INTEGER input argument to be converted to a string.
!!             May be of KIND kind=int8, kind=int16, kind=int32, kind=int64.
!!
!!##RESULTS
!!             The value of VALUIN converted to a CHARACTER string.
!!
!!##EXAMPLE
!!
!!
!!   Sample program
!!
!!    program demo_anyinteger_to_string
!!    use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
!!    use M_anything, only : itoc=>anyinteger_to_string
!!    implicit none
!!       write(*,*)itoc(huge(0_int8)),       '=> 127'
!!       write(*,*)itoc(huge(0_int16)),      '=> 32767'
!!       write(*,*)itoc(huge(0_int32)),      '=> 2147483647'
!!       write(*,*)itoc(huge(0_int64)),      '=> 9223372036854775807',huge(0_int64)
!!       write(*,*)itoc(-(huge(0_int64)-1)), '=> -9223372036854775806'
!!    end program demo_anyinteger_to_string
!!
!!   Results:
!!
!!    127=> 127
!!    32767=> 32767
!!    2147483647=> 2147483647
!!    9223372036854775807=> 9223372036854775807
!!    -9223372036854775806=> -9223372036854775806
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT
impure function anyinteger_to_string(int) result(out)
use,intrinsic :: iso_fortran_env, only : int64

! ident_7="@(#)M_anything::anyinteger_to_string(3f): function that converts an integer value to a character string"

class(*),intent(in)          :: int
character(len=:),allocatable :: out
integer,parameter            :: maxlen=32         ! assumed more than enough characters for largest input value
integer                      :: i, k
integer(kind=int64)          :: intval
integer(kind=int64)          :: int_local
integer                      :: str(maxlen)
integer,parameter            :: dig0=  ichar('0')
integer,parameter            :: minus= ichar('-')

   int_local = anyscalar_to_int64(int)            ! convert input to largest integer type
   intval = abs(int_local)
   do i=1,maxlen                                  ! generate digits from smallest significant digit to largest
      str(i) = dig0 + mod(intval,10_int64)
      intval = intval / 10
      if(intval == 0 )exit
   enddo
   if (int_local < 0 ) then                       ! now make sure the sign is correct
      i=i+1
      str(i) = minus
   endif
   allocate(character(len=i) :: out)
   do k=i,1,-1                                    ! have all the digits in reverse order, now flip them and convert to a string
      out(i-k+1:i-k+1)=char(str(k))
   enddo
end function anyinteger_to_string
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
end module M_anything
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================


PROGRAM ifextract2
 INTEGER :: i
 LOGICAL :: test

 test = .TRUE.
 IF ( test ) THEN
  DO i = 1 , 10 , 1
   PRINT * ,"Then body:" , i
  END DO
 ELSE
  DO i = 1 , 10 , 1
   PRINT * ,"Else body:" , i
  END DO
 END IF
END PROGRAM ifextract2


! { dg-do run }
! { dg-options "-g" }
  integer :: a(10), b(12)
  call sub (a, 10)
  call sub (b, 12)
  write (*,*) a, b
end

subroutine sub (a, n)
  integer :: a(n), n
  do i = 1, n
    a(i) = i
  end do
  write (*,*) a	! { dg-final { gdb-test 14 "a(10)" "10" } }
end subroutine


! { dg-do compile }
!
! PR fortran/34514
!
! Initialization and typespec changes.
!
integer :: n = 5, m = 7
parameter (n = 42) ! { dg-error "Initializing already initialized variable" }
dimension :: m(3)  ! { dg-error "after its initialization" }
end


program t
  implicit none
  integer::i
  i=f(-1)
  print '(i0)',i
contains
  integer function f(i)
    integer::i
    print '(i0)',i
    if (i.lt.0) then
      f=i
      return
    endif
    f=i+1
  end function f
end program t


program readVariables
    implicit none;

    integer i;
    real r;

    print *, "Enter value of integer : ";
    read *, i;

    print *, "Enter value of real : ";
    read *, r

    print *, "Value of i = ", i , char(10),"Value of r = ", r;
end program


module mod_three
    implicit none
contains
    subroutine three()
    implicit none
	  INTEGER :: J
	  REAL, ALLOCATABLE :: M (:)

	  DO J=1, 10
		M(J)=4
	  END DO

    end subroutine three
end module mod_three


!
! do.f
!
! Example of a parallel and do directives
!
! 2008-2009
! Creation: A. Muller, FSC

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

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

!$omp DO
      do 20 i=1,N
         a(i,2)=2*i
 20   continue
!$omp END PARALLEL

      print *,a

      end


!************************************************************
!
!  This example shows how to read and write integer datatypes
!  to an attribute.  The program first writes integers to an
!  attribute with a dataspace of DIM0xDIM1, then closes the
!  file.  Next, it reopens the file, reads back the data, and
!  outputs it to the screen.
!
!  This file is intended for use with HDF5 Library version 1.8
!  with --enable-fortran2003
!
!************************************************************
PROGRAM main

  USE HDF5
  USE ISO_C_BINDING

  IMPLICIT NONE
  CHARACTER(LEN=20), PARAMETER :: filename  = "h5ex_t_intatt_F03.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset   = "DS1"
  CHARACTER(LEN=2) , PARAMETER :: attribute = "A1"
  INTEGER          , PARAMETER :: dim0      = 4
  INTEGER          , PARAMETER :: dim1      = 7

  INTEGER(HID_T)  :: file, space, dset,attr ! Handles
  INTEGER :: hdferr
  INTEGER(hsize_t),   DIMENSION(1:2) :: dims = (/dim0, dim1/)
  INTEGER, DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
  INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
  INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
  INTEGER :: i, j
  TYPE(C_PTR) :: f_ptr
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! Initialize DATA.
  !
  DO i = 1, dim0
     DO j = 1, dim1
        wdata(i,j) = (i-1) * (j-1) - (j-1)
     ENDDO
  ENDDO
  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create dataspace with a null dataspace.
  !
  CALL H5Screate_f(H5S_NULL_F, space, hdferr)
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr)
  CALL h5sclose_f(space, hdferr)
  !
  ! Create dataspace.  Setting maximum size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the attribute and write the integer data to it.  In this
  ! example we will save the data as 64 bit big endian integers,
  ! regardless of the native integer type.  The HDF5 library
  ! automatically converts between different integer types.
  !
  CALL H5Acreate_f(dset, attribute, H5T_STD_I64BE, space, attr, hdferr)
  f_ptr = C_LOC(wdata(1,1))
  CALL H5Awrite_f(attr, H5T_NATIVE_INTEGER, f_ptr, hdferr)
  !
  ! Close and release resources.
  !
  CALL H5Aclose_f(attr, hdferr)
  CALL H5Dclose_f(dset, hdferr)
  CALL H5Sclose_f(space, hdferr)
  CALL H5Fclose_f(file, hdferr)
  !
  ! Now we begin the read section of this example.
  !
  ! Open file and dataset, and attribute.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f(file, dataset, dset, hdferr)
  CALL h5aopen_f(dset, attribute, attr, hdferr)
  !
  ! Get dataspace and allocate memory for read buffer.
  !
  CALL h5aget_space_f(attr, space, hdferr)
  CALL h5sget_simple_extent_dims_f(space, dims, maxdims, hdferr)

  ALLOCATE(rdata(1:dims(1),1:dims(2)))
  !
  ! Read the data.
  !
  f_ptr = C_LOC(rdata(1,1))
  CALL h5aread_f( attr, H5T_NATIVE_INTEGER, f_ptr, hdferr)
  !
  ! Output the data to the screen.
  !
  WRITE(*, '(A,":")') attribute
  DO i=1, dims(1)
     WRITE(*,'(" [")', ADVANCE='NO')
     WRITE(*,'(80i3)', ADVANCE='NO') rdata(i,1:dims(2))
     WRITE(*,'(" ]")')
  ENDDO
  !
  ! Close and release resources.
  !
  DEALLOCATE(rdata)
  CALL h5aclose_f(attr , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
END PROGRAM main


program main

  use compute_module
  use gitstuff

  implicit none

  double precision :: x, y, z

  print *, "running code version: ", githash()

  x = 1.0
  y = 2.0

  z = compute(x, y)

  call print_result(z)

end program main


      PROGRAM squared
      INTEGER :: i
      WRITE (*,*) "Please enter a number."
      READ (*,*) i
      WRITE (*,*) "Your number squared is ", i*i
      STOP
      END PROGRAM


PROGRAM day_of_week
!
!  Purpose:
!    This program displays the day of week corresponding to
!    a input integer value.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/06/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
CHARACTER(len=11) :: c_day  ! Character string containing day
INTEGER :: i_day            ! Integer day of week

! Prompt the user for the numeric day of the week
WRITE (*,*) 'Enter the day of the week (1-7): '
READ  (*,*) i_day

! Get the corresponding day of the week.
SELECT CASE (i_day)
CASE (1)
   c_day = 'Sunday'
CASE (2)
   c_day = 'Monday'
CASE (3)
   c_day = 'Tuesday'
CASE (4)
   c_day = 'Wednesday'
CASE (5)
   c_day = 'Thursday'
CASE (6)
   c_day = 'Friday'
CASE (7)
   c_day = 'Saturday'
CASE DEFAULT
   c_day = 'Invalid day'
END SELECT

! Write the resulting day
WRITE (*,*) 'Day = ', c_day

END PROGRAM day_of_week


program charlen
!! shows how to properly specify character length and character array

implicit none (type, external)

character*(5) :: cb5  !< obsolete, don't use

!>  good to use
character(5)  :: c5
character(*), parameter :: ca(2) = ['hello', 'sorry']

if (.not.all([len(cb5)==5, len(c5)==5, len(ca)==5, size(ca)==2])) error stop
print *, ca

end program


! { dg-do compile }
! { dg-options "-ffree-form -std=f95" }
!
! Test errors for DEC-style PARAMETER statements with a real standard.
!

subroutine sub()
  implicit real(8) (A-Z)
  parameter pi = 3.1415926535d0 ! { dg-error "Legacy Extension: PARAMETER" }
  print *, pi
end subroutine

end


! { dg-do compile }
!
! PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-procedure
!
! Contributed by James Van Buskirk

  implicit none
  procedure(my_dcos), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" }
  f => my_dcos           ! { dg-error "Nonintrinsic elemental procedure 'my_dcos' is invalid in procedure pointer assignment" }
contains
  real elemental function my_dcos(x)
    real, intent(in) :: x
    my_dcos = cos(x)
  end function
end


module access_vars
implicit none

   public
   real, private :: priv  = 1.5
   real, public :: publ = 2.5

contains
   subroutine print_vars()
      print *, "priv = ", priv
      print *, "publ = ", publ
   end subroutine print_vars

end module access_var


PROGRAM mem_leak
IMPLICIT NONE
INTEGER :: i, istat
INTEGER, DIMENSION(:), POINTER :: ptr1, ptr2

! Check associated status of ptrs.
WRITE (*,'(A,2L5)') ' Are ptr1, ptr2 associated? ', &
      ASSOCIATED(ptr1), ASSOCIATED(ptr2)

! Allocate and initialize memory
ALLOCATE (ptr1(1:10), STAT=istat)
ALLOCATE (ptr2(1:10), STAT=istat)
ptr1 = (/ (i, i = 1,10 ) /)
ptr2 = (/ (i, i = 11,20 ) /)

! Check associated status of ptrs.
WRITE (*,'(A,2L5)') ' Are ptr1, ptr2 associated? ', &
      ASSOCIATED(ptr1), ASSOCIATED(ptr2)

WRITE (*,'(A,10I3)') ' ptr1 = ', ptr1   ! Write out data
WRITE (*,'(A,10I3)') ' ptr2 = ', ptr2

ptr2 => ptr1                            ! Reassign ptr2

WRITE (*,'(A,10I3)') ' ptr1 = ', ptr1   ! Write out data
WRITE (*,'(A,10I3)') ' ptr2 = ', ptr2

NULLIFY(ptr1)                           ! Nullify pointer
DEALLOCATE(ptr2, STAT=istat)            ! Deallocate memory

END PROGRAM mem_leak


SUBROUTINE get_diagonal ( ptr_a, ptr_b, error )
!
!  Purpose:
!    To extract the diagonal elements from the rank two
!    square array pointed to by ptr_a, and store them in
!    a rank one array allocated on ptr_b.  The following
!    error conditions are defined:
!      0 -- No error.
!      1 -- ptr_a not associated on input
!      2 -- ptr_b already associated on input
!      3 -- Array on ptr_a not suqare
!      4 -- Unable to allocate memory for ptr_b
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/23/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, DIMENSION(:,:), POINTER :: ptr_a ! Ptr to square array
INTEGER, DIMENSION(:), POINTER :: ptr_b   ! Ptr to output array
INTEGER, INTENT(OUT) :: error             ! Errors flag

! Data dictionary: declare variable types & definitions
INTEGER :: i                        ! Loop counter
INTEGER :: istat                    ! Allocate status
INTEGER, DIMENSION(2) :: l_bound    ! Lower bounds on ptr_a
INTEGER, DIMENSION(2) :: u_bound    ! Upper bounds on ptr_a
INTEGER, DIMENSION(2) :: extent     ! Extent of array on ptr_a

! Check error conditions
error_1: IF ( .NOT. ASSOCIATED ( ptr_a ) ) THEN
   error = 1
ELSE IF ( ASSOCIATED ( ptr_b ) ) THEN
   error = 2
ELSE
   ! Check for square array
   l_bound = LBOUND ( ptr_a )
   u_bound = UBOUND ( ptr_a )
   extent = u_bound - l_bound + 1
   error_3: IF ( extent(1) /= extent(2) ) THEN
      error = 3
   ELSE
      ! Everything is ok so far, allocate ptr_b.
      ALLOCATE ( ptr_b(extent(1)), STAT=istat )
      error_4: IF ( istat /= 0 ) THEN
         error = 4
      ELSE
         ! Everything is ok, extract diagonal.
         ok: DO i = 1, extent(1)
            ptr_b(i) = ptr_a(l_bound(1)+i-1,l_bound(2)+i-1)
         END DO ok

         ! Reset error flag.
         error = 0
      END IF error_4
   END IF error_3
END IF error_1

END SUBROUTINE get_diagonal


function gt_int(x,y) result (ordered)
! Arguments
integer, intent(in) :: x
integer, intent(in) :: y

! Result
logical :: ordered

! Compare
if (x > y) then
   ordered = .true.
else
   ordered = .false.
end if

end function gt_int


!Warning! This program uses MPI3 features. Not all computers will have
!MPI3 libraries available yet
PROGRAM ireduce

  USE mpi
  IMPLICIT NONE

  INTEGER, PARAMETER :: tag = 100

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

  CALL MPI_Init(ierr)

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

  CALL MPI_Ireduce(rank, recv, 1, MPI_INTEGER, MPI_MAX, 0, &
      MPI_COMM_WORLD, handle, ierr)
  CALL MPI_Wait(handle, MPI_STATUS_IGNORE, ierr)
  PRINT *, 'On rank ', rank, ' MPI_Ireduce gives maximum rank as ', recv

  CALL MPI_Finalize(ierr)

END PROGRAM ireduce


program main ! GitHub FortranTip leak.f90
implicit none
integer :: i
real, pointer :: p(:)
do i=1,2
   p => ran(5)
   print*,p
   ! line below commented out to produce memory leak
   ! deallocate (p)
end do
contains
function ran(n) result(p)
integer, intent(in) :: n
real, pointer :: p(:) ! better to return allocatable
allocate (p(n))
call random_number(p)
end function ran
end program main
! On WSL2, gfortran leak.f90 && valgrind ./a.out says
! ==3128== LEAK SUMMARY:
! ==3128==    definitely lost: 40 bytes in 2 blocks


! chk_decimal_io.f90
!     Check: does the compiler support the DECIMAL specifier in READ/WRITE statements?
!
program chk_decimal_io
    implicit none

    integer            :: ierr
    real, dimension(5) :: value
    real, dimension(5) :: copy
    character(len=20)  :: string

    value = (/ 1.1, 2.3, 4.0, 5.6, 17.11 /)

    write( *, '(a)' ) 'Writing with comma as decimal separator'

    open( 10, file = 'chk_decimal_io.data' )

    write( 10, '(5f10.3)', decimal = 'comma' ) value

    rewind( 10 )

    !
    ! Read with default values - then we expect the first two to be one and 100
    !
    read( 10, * ) copy

    if ( copy(1) /= 1.0 .or. copy(2) /= 100.0 ) then
        write( *, '(a,2e15.5)' ) '   Expected value 1.0 and 100.0, but got: ', copy(1:2)
    else
        write( *, '(a,2e15.5)' ) '   First test succeeded, as expected got: ', copy(1:2)
    endif

    !
    ! Read using commas as decimal separators
    !
    write( *, '(a)' ) 'Reading with list-directed READ:'
    rewind( 10 )

    read( 10, *, decimal = 'comma' ) copy

    if ( any( value /= copy ) ) then
        write( *, '(/,a)' )      '    NOTE: Found differences with the original values'
        write( *, '(a,5e15.5)' ) '    Original: ', value
        write( *, '(a,5e15.5)' ) '    Read:     ', copy
    else
        write( *, '(a,2e15.5)' ) '    Second test succeeded - all values are the same'
    endif

    write( *, '(a)' ) 'Reading with explicit format:'
    rewind( 10 )

    read( 10, '(5f10.0)', decimal = 'comma' ) copy

    if ( any( value /= copy ) ) then
        write( *, '(/,a)' )      '    NOTE: Found differences with the original values'
        write( *, '(a,5e15.5)' ) '    Original: ', value
        write( *, '(a,5e15.5)' ) '    Read:     ', copy
    else
        write( *, '(a,2e15.5)' ) '    Third test succeeded - all values are the same'
    endif

    !
    ! Now find out if list-directed reads can deal with semicolons as separator
    !
    write( *, '(a)' ) 'Reading a file with commas and semicolons:'

    rewind( 10 )
    write( 10, '(a)' ) '1,2;3,4;5,6'
    rewind( 10 )

    read(  10, *, decimal = 'comma', iostat = ierr ) value(1:3)

    if ( ierr /= 0 ) then
        write( *, '(a)' ) '    An error occurred while reading the string "1,2;3,4;5,6"'
    else
        write( *, '(a)' ) '    String "1,2;3,4;5,6" read without problems'
        string = "1.2 3.4 5.6"
        read( string, * ) copy(1:3)

        if ( any( value(1:3) /= copy(1:3) ) ) then
            write( *, '(a)' ) '    Differences between the values that were read', &
                              '    with commas/semilcolons and points/commas:'
            write( *, '(a,5e15.5)' ) '    Read with commas: ', value
            write( *, '(a,5e15.5)' ) '    Read with points: ', copy
        else
            write( *, '(a)' ) '    All values identical - no difference using commas/semicolons or points/commas'
        endif
    endif

end program chk_decimal_io


! 2. Write function that reverses a list, preferably in place.

    program Exercises
        implicit none
        integer :: list(4)

        list = (/1, 2, 5, 3/)
        call reverse(list)

        contains
        subroutine reverse(list)
            ! Reverses in place.
            integer, dimension(1:) :: list
            integer :: i
            integer :: s
            integer :: halfSize
            integer :: temp

            s = size(list)
            halfSize = s / 2

            ! Swap pairs of elements in the list.
            do i=1,halfSize
                temp = list(i)
                list(i) = list(s-i+1)
                list(s-i+1) = temp
            end do

        end subroutine reverse

    end program Exercises


program do2
implicit none
integer :: i
    open(unit=0, file="prueba2.txt",status="new" , action="write")
    do i=1, 1000,5
      write (10,*)i
    end do
    close(unit=0)

  end program do2


! If allocation errors must be handled, use allocatable rather than automatic arrays in procedures,
! and check the stat of allocate.
subroutine foo(x)
implicit none
real, intent(in)  :: x(:)
real              :: y(size(x)) ! automatic array -- program crashes if there is no memory for it
real, allocatable :: z(:)
integer           :: ierr
allocate (z(size(x)),stat=ierr)
if (ierr /= 0) then ! allocate errors can be handled
   print*,"could not allocate z in foo"
   return
end if
end subroutine foo


PROGRAM bad_ptr
IMPLICIT NONE
INTEGER :: i, istat
INTEGER, DIMENSION(:), POINTER :: ptr1, ptr2

! Allocate and initialize memory
ALLOCATE (ptr1(1:10), STAT=istat)       ! Allocate ptr1
ptr1 = (/ (i, i = 1,10 ) /)             ! Initizlize ptr1
ptr2 => ptr1                            ! Assign ptr2

! Check associated status of ptrs.
WRITE (*,'(A,2L5)') ' Are ptr1, ptr2 associated? ', &
      ASSOCIATED(ptr1), ASSOCIATED(ptr2)

WRITE (*,'(A,10I3)') ' ptr1 = ', ptr1   ! Write out data
WRITE (*,'(A,10I3)') ' ptr2 = ', ptr2

! Now deallocate memory associated with ptr1
DEALLOCATE(ptr1, STAT=istat)            ! Deallocate memory

! Check associated status of ptrs.
WRITE (*,'(A,2L5)') ' Are ptr1, ptr2 associated? ', &
      ASSOCIATED(ptr1), ASSOCIATED(ptr2)

! Write out memory associated with ptr2
WRITE (*,'(A,10I3)') ' ptr2 = ', ptr2

ALLOCATE (ptr1(1:2), STAT=istat)        ! Reallocate ptr1
ptr1 = (/ 21, 22 /)

WRITE (*,'(A,10I3)') ' ptr1 = ', ptr1   ! Write out data
WRITE (*,'(A,10I3)') ' ptr2 = ', ptr2

END PROGRAM bad_ptr


PROGRAM alloc_test
  IMPLICIT NONE
  INTEGER, DIMENSION(:), ALLOCATABLE :: array

  PRINT *, 'Before allocation ', ALLOCATED(array)
  ALLOCATE(array(10))
  PRINT *, 'After allocation ', ALLOCATED(array)
  DEALLOCATE(array)
  PRINT *, 'After deallocation ', ALLOCATED(array)

END PROGRAM alloc_test


program main
    implicit none
    integer :: i, j, m, n, max_n
    integer, allocatable :: task(:)
    integer, allocatable :: buff(:, :)

    m = 10
    max_n = 6
    allocate(task(m))
    do i = 1, m
        task(i) = mod(i, max_n)
    end do

    allocate(buff(max_n, m))
    buff = 0

    !$acc parallel loop gang(dim:2) copy(buff)
    do i = 1, m
        n = task(i)
        !$acc loop
        do j = 1, n
            buff(j, i) = 1
        end do
    end do

    print*, buff
    deallocate(task, buff)
end program main


PROGRAM simple_if

  IMPLICIT NONE
  INTEGER :: test, candidate

  test = 2
  candidate = 4

  IF (test < candidate) THEN
    PRINT *, 'Test ', test, ' less than candidate ', candidate
  ELSE IF (test == candidate) THEN
    PRINT *, 'Test ', test, ' equal to candidate ', candidate
  ELSE
    PRINT *, 'Test ', test, ' greater than candidate ', candidate
  END IF

END PROGRAM simple_if


! One dimensional array as shared variable
      subroutine initialize (n,u)
      implicit none

      integer n
      double precision u(n)
      integer i

!$omp parallel do
      do i = 1,n
         u(i) = 0.0
      enddo
!$omp end parallel do

      return
      end


MODULE date_class
!
!  This module implements a date class, which stores
!   and manipulates dates on the Gregorian calendar.
!   It implements set methods, get methods, predicate
!   methods, and a "to_string" method for displays.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/28/06    S. J. Chapman        Original code
!
IMPLICIT NONE

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

   ! Instance variables.  Note that the default
   ! date is January 1, 1900.
   PRIVATE
   INTEGER :: year = 1900   ! Year (0 - xxxx)
   INTEGER :: month = 1     ! Month (1-12)
   INTEGER :: day = 1       ! Day (1-31)

!  CONTAINS

!     ! Bound procedures
!     PUBLIC
!     PROCEDURE :: set_date ==> set_date_sub
!     PROCEDURE :: get_day ==> get_day_fn
!     PROCEDURE :: get_month ==> get_month_fn
!     PROCEDURE :: get_year ==> get_year_fn
!     PROCEDURE :: is_leap_year ==> is_leap_year_fn
!     PROCEDURE :: is_equal ==> is_equal_fn
!     PROCEDURE :: is_earlier ==> is_earlier_fn
!     PROCEDURE :: is_later ==> is_later_fn
!     PROCEDURE :: to_string ==> to_string_fn

END TYPE date

! Restrict access to the actual procedure names
!PRIVATE :: set_date_sub, get_day_fn, get_month_fn, get_year_fn
!PRIVATE :: is_leap_year_fn, is_equal_fn, is_earlier_fn
!PRIVATE :: is_later_fn, to_string_fn

! Now add methods
CONTAINS

   SUBROUTINE set_date_sub(this, day, month, year)
   !
   ! Subroutine to set the initial date
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object
   INTEGER,INTENT(IN) :: day         ! Day (1-31)
   INTEGER,INTENT(IN) :: month       ! Month (1-12)
   INTEGER,INTENT(IN) :: year        ! Year (0 - xxxx)

   ! Save date
   this%day   = day
   this%month = month
   this%year  = year

   END SUBROUTINE set_date_sub

   INTEGER FUNCTION get_day_fn(this)
   !
   ! Function to return the day from this object
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object

   ! Get day
   get_day_fn = this%day

   END FUNCTION get_day_fn

   INTEGER FUNCTION get_month_fn(this)
   !
   ! Function to return the month from this object
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object

   ! Get month
   get_month_fn = this%month

   END FUNCTION get_month_fn

   INTEGER FUNCTION get_year_fn(this)
   !
   ! Function to return the year from this object
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object

   ! Get year
   get_year_fn = this%year

   END FUNCTION get_year_fn

   LOGICAL FUNCTION is_leap_year_fn(this)
   !
   ! Is this year a leap year?
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object

   ! Perform calculation
   IF ( MOD(this%year, 400) == 0 ) THEN
      is_leap_year_fn = .TRUE.
   ELSE IF ( MOD(this%year, 100) == 0 ) THEN
      is_leap_year_fn = .FALSE.
   ELSE IF ( MOD(this%year, 4) == 0 ) THEN
      is_leap_year_fn = .TRUE.
   ELSE
      is_leap_year_fn = .FALSE.
   END IF

   END FUNCTION is_leap_year_fn

   LOGICAL FUNCTION is_equal_fn(this,that)
   !
   ! Are these two dates equal?
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object
   TYPE(date) :: that               ! Another date for comparison

   ! Perform calculation
   IF ( (this%year == that%year) .AND. &
        (this%month == that%month) .AND. &
        (this%day == that%day) ) THEN
      is_equal_fn = .TRUE.
   ELSE
      is_equal_fn = .FALSE.
   END IF

   END FUNCTION is_equal_fn

   LOGICAL FUNCTION is_earlier_fn(this,that)
   !
   ! Is the date in "that" earlier than the date
   ! stored in the object?
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object
   TYPE(date) :: that               ! Another date for comparison

   ! Perform calculation
   IF ( that%year > this%year ) THEN
      is_earlier_fn = .FALSE.
   ELSE IF ( that%year < this%year ) THEN
      is_earlier_fn = .TRUE.
   ELSE
      IF ( that%month > this%month) THEN
         is_earlier_fn = .FALSE.
      ELSE IF ( that%month < this%month ) THEN
         is_earlier_fn = .TRUE.
      ELSE
         IF ( that%day >= this%day ) THEN
            is_earlier_fn = .FALSE.
         ELSE
            is_earlier_fn = .TRUE.
         END IF
      END IF
   END IF

   END FUNCTION is_earlier_fn

   LOGICAL FUNCTION is_later_fn(this,that)
   !
   ! Is the date in "that" later than the date
   ! stored in the object?
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object
   TYPE(date) :: that               ! Another date for comparison

   ! Perform calculation
   IF ( that%year > this%year ) THEN
      is_later_fn = .TRUE.
   ELSE IF ( that%year < this%year ) THEN
      is_later_fn = .FALSE.
   ELSE
      IF ( that%month > this%month ) THEN
         is_later_fn = .TRUE.
      ELSE IF ( that%month < this%month ) THEN
         is_later_fn = .FALSE.
      ELSE
         IF ( that%day > this%day ) THEN
            is_later_fn = .TRUE.
         ELSE
            is_later_fn = .FALSE.
         END IF
      END IF
   END IF

   END FUNCTION is_later_fn

   CHARACTER(len=10) FUNCTION to_string_fn(this)
   !
   ! Represent the date as a string: MM/DD/YYYY.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   TYPE(date) :: this               ! Date object

   ! Declare local variables
   CHARACTER(len=2) :: dd            ! Day
   CHARACTER(len=2) :: mm            ! Month
   CHARACTER(len=4) :: yy            ! Year

   ! Get components
   WRITE (dd,'(I2)') this%day
   WRITE (mm,'(I2)') this%month
   WRITE (yy,'(I4)') this%year

   ! Return string
   to_string_fn = mm // '/' // dd // '/' // yy

   END FUNCTION to_string_fn

END MODULE date_class

PROGRAM test_date
!
!  This program tests the date class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/28/06    S. J. Chapman        Original code
!
USE date_class                  ! Import date class
IMPLICIT NONE

! Declare local variables
TYPE(date) :: d1               ! Date 1
TYPE(date) :: d2               ! Date 2
TYPE(date) :: d3               ! Date 3
TYPE(date) :: d4               ! Date 4

! Initialize dates d1, d2, and d3 (d4 defaults)
CALL set_date_sub(d1,4,1,1996)
CALL set_date_sub(d2,1,3,1998)
CALL set_date_sub(d3,3,1,1996)

! Write out the dates
WRITE (*,'(A,A)') 'Date 1 = ', to_string_fn(d1)
WRITE (*,'(A,A)') 'Date 2 = ', to_string_fn(d2)
WRITE (*,'(A,A)') 'Date 3 = ', to_string_fn(d3)
WRITE (*,'(A,A)') 'Date 4 = ', to_string_fn(d4)

! Check for leap years
IF ( is_leap_year_fn(d1) ) THEN
   WRITE (*,'(I4,A)') get_year_fn(d1), ' is a leap year.'
ELSE
   WRITE (*,'(I4,A)') get_year_fn(d1), ' is a not leap year.'
END IF

IF ( is_leap_year_fn(d2) ) THEN
   WRITE (*,'(I4,A)') get_year_fn(d2), ' is a leap year.'
ELSE
   WRITE (*,'(I4,A)') get_year_fn(d2), ' is a not leap year.'
END IF

! Check for equality
IF ( is_equal_fn(d1,d3) ) THEN
   WRITE (*,'(3A)') to_string_fn(d3), ' is equal to ', to_string_fn(d1)
ELSE
   WRITE (*,'(3A)') to_string_fn(d3), ' is not equal to ', to_string_fn(d1)
END IF

! Check is_earlier
IF ( is_earlier_fn(d1,d3) ) THEN
   WRITE (*,'(3A)') to_string_fn(d3), ' is earlier than ', to_string_fn(d1)
ELSE
   WRITE (*,'(3A)') to_string_fn(d3), ' is not earlier than ', to_string_fn(d1)
END IF

! Check is_later
IF ( is_later_fn(d1,d3) ) THEN
   WRITE (*,'(3A)') to_string_fn(d3), ' is later than ', to_string_fn(d1)
ELSE
   WRITE (*,'(3A)') to_string_fn(d3), ' is not later than ', to_string_fn(d1)
END IF

END PROGRAM test_date


program t
  implicit none
  integer::i,j
  j=-1
  i=f(j)
  print '(i0)',i
  print '(i0)',j
contains
  integer function f(i)
    integer::i
    intent(inout)::i
    print '(i0)',i
    if (i.lt.0) then
      i=999
      f=i
      return
    endif
    f=i+1
  end function f
end program t


! Simulate F0 format with more options, for compilers disallowing NaN, Inf.
! Fortran 95/2003 module and test program in this file f0noIEEE.f90 by
! J F Harper, Mathematics, Victoria University, Wellington, NZ 10 Jan 2012.
!
! Compilers vary in their own treatments of leading zero and optional + sign
! because Fortran standards f90,f95,f2003 differ, and f95 was ambiguous. The
! module lets users choose their own treatment. The test program avoids IEEE
! features such as NaN or Inf. I hope it works with f95 compilers that do
! not support them, but I do not have such a compiler to test it with.
!
! Usage: function f0(x,n,s) or f0(x,n) returns the shortest possible string
! of characters containing x in F0.n format, with leading zero and + sign
! controlled by the character string s if it is present, or by SS,F0.n
! format as in f2003 if not, so if separate positive and negative zeros are
! supported then f0(-0.0,n) shall begin with a - sign. Arguments:
!
! x: value to be written by f0 [double precision or default real]
! n: number of digits to be written after the decimal point [integer]
! s: specifying treatment of + sign and leading zero [character(*)]
!
! If s is absent or contains neither LZ nor SP the effect is that of format
! SS,F0.n as in the f2003 standard. If s contains SP the effect is that of
! SP,F0.n, i.e. a + sign if x>0 or x is +0.0, a - sign if x<0 or -0.0.
! If the processor does not support separate -0.0 and +0.0 then 0.0 is
! treated as +0.0. A zero before the decimal point is inserted if the
! output would otherwise have had no digits at all, or if s contains LZ and
! there would otherwise be no digits before the decimal point.
!
! Public entities defined in this module are
! four integer parameters: p1 = kind(1.0), p2 = kind(1d0),
!     ispace = space needed for -huge(1) in I0 format,
!     rspace = space needed for -huge(1d0) in F0.0 format,
! two real parameters: zero1 = 0 of kind p1, zero2 = 0 of kind p2.
! generic character function: f0 with four private specific forms, for real
!     kinds p1 and p2, and s present or absent.
!
module leadzero
  implicit none
  private
  public p1,p2,zero1,zero2,ispace,rspace,f0
  integer,parameter :: &
       p2 = kind(1d0), &           ! double precision kind
       p1 = kind(1.0), &           ! default real (single precision) kind
       ispace = range(1) + 2, &    ! space needed for -huge(1) in I0 format
       rspace = range(1d0) + 4     ! space for -huge(real) in F0.0
  real(p1),parameter:: zero1 = 0
  real(p2),parameter:: zero2 = 0
  interface f0 ! no optional args in spec.expr. so 4 procedures here
     module procedure p2f0short, p1f0short, p2f0no_s, p1f0no_s
  end interface f0

contains

  pure function p1f0long(x,n,s) result(out)
    real(p1),intent(in)::x
    integer,intent(in) ::  n  ! using f0.n format
    character(*),intent(in)::s! for leading zero, SP options
    character(rspace+abs(n))::         out
! so len(out) = max possible space for x in f0.n format
    integer  :: ios
    character:: fmt*(7+2*ispace)
     out = ' '
    if (n<0) then
       out = '*** Error in f0: n<0 ***'
    else
       write(fmt,"(A,I0,A,I0,A)")'(SS,F',len(out),'.',n,')' ! SS: no + sign
       write(out,fmt,iostat=ios) x
       if(ios/=0) then
          out = '*** Error in f0: reading x ***'
       else
          out = fixstring(s,out,sign(1.0_p1,x)<zero1.and.x==zero1)
       end if
    end if
  end function p1f0long

  pure function p2f0long(x,n,s) result(out)
    real(p2),intent(in)::x
    integer,intent(in) ::  n  ! using f0.n format
    character(*),intent(in)::s! for leading zero, SP options
    character(rspace+abs(n))::         out
! so len(out) = max possible space for x in f0.n format
    integer  :: ios
    character:: fmt*(7+2*ispace)
    out = ' '
    if (n<0) then
       out = '*** Error n<0 ***'
    else
       write(fmt,"(A,I0,A,I0,A)")'(SS,F',len(out),'.',n,')' ! SS: no + sign
       write(out,fmt,iostat=ios) x
       if(ios/=0) then
          out = '*** Error reading x ***'
       else
          out = fixstring(s,out,sign(1.0_p2,x)<zero2.and.x==zero2)
       end if
    end if
  end function p2f0long

  pure function fixstring(   s,in,neg0) result(out)
    character(*),intent(in)::s,in
    logical,intent(in)::neg0 ! true if x is negative zero
    character(len(in))::                       out
    logical:: usingsp
    usingsp = (index(s,'SP')>0)
    out=adjustl(in)
    if (scan(out,'Aa')>0) then ! x is not a number
       out = 'NaN'
    else if(scan(out,'Ii')>0) then ! x is infinite
       out = merge('-Inf', &
            merge('+Inf','Inf ',usingsp),scan(out,'-')>0)// &
            repeat(' ',len(out)-4)
    else
       if (neg0.and.scan(out,'-')==0) out = '-'//out
! If s contains 'LZ' then insert leading zero; if not, delete it
       if (index(s,'LZ')>0) then
          if (out(1:2)=='-.' ) out = '-0'//out(2:)
          if (out(1:1)=='.'  ) out =  '0'//out
       else
          if (out(1:3)=='-0.') out =  '-'//out(3:)
          if (out(1:2)=='0.' ) out =       out(2:)
! Ensure at least one digit is written (n might be 0)
          if(trim(out)=='.'  ) out = '0.'
          if(trim(out)=='-.' ) out = '-0.'
       end if
! If s contains 'SP' then insert + sign if not negative
       if (usingsp.and.scan(out,'-')==0) out = '+'//out
    end if
  end function fixstring

  pure function p1f0short(x,n,s) ! trimmed invocation of p1f0long
    real(p1),intent(in) ::x
    integer,intent(in)  ::  n
    character,intent(in)::    s*(*)
    character:: p1f0short*(len_trim(p1f0long(x,n,s)))
    p1f0short = trim(p1f0long(x,n,s))
  end function p1f0short

  pure function p2f0short(x,n,s) ! trimmed invocation of p2f0long
    real(p2),intent(in) ::x
    integer,intent(in)  ::  n
    character,intent(in)::    s*(*)
    character:: p2f0short*(len_trim(p2f0long(x,n,s)))
    p2f0short = trim(p2f0long(x,n,s))
  end function p2f0short

  pure function p1f0no_s(x,n) ! like p1f0short with s absent
    real(p1),intent(in)::x
    integer,intent(in) ::  n
    character:: p1f0no_s*(len_trim(p1f0long(x,n,' ')))
    p1f0no_s = trim(p1f0long(x,n,' '))
  end function p1f0no_s

  pure function p2f0no_s(x,n) ! like p2f0short with s absent
    real(p2),intent(in)::x
    integer,intent(in) ::  n
    character:: p2f0no_s*(len_trim(p2f0long(x,n,' ')))
    p2f0no_s = trim(p2f0long(x,n,' '))
  end function p2f0no_s

end module leadzero


! { dg-do compile }
! { dg-options "-std=f2003" }
!
! Test our conformance to item 4.9 ("Kind type parameters of integer
! specifiers") of the Fortran 2003 status document at
! ftp://ftp.nag.co.uk/sc22wg5/N1551-N1600/N1579.pdf
!
! The non-default integer variables are allowed since Fortran 2003.
! The non-default logical variables are allowed since Fortran 2008.

  integer(kind=8) :: i, j, k, n
  logical(kind=8) :: l1, l2, l3

  open(10, status="scratch", iostat=i)

  backspace(10, iostat=i)
  endfile(10, iostat=i)
  rewind(10, iostat=i)

  read(*, '(I2)', iostat=i) k
  read(*, '(I2)', advance='no', size=j) k

  inquire(iolength=i) "42"
  inquire(10, iostat=i)
  inquire(10, number=j)
  inquire(10, recl=k)
  inquire(10, nextrec=n)

  inquire(10, exist=l1) ! { dg-error "Non-default LOGICAL kind" }
  inquire(10, named=l3) ! { dg-error "Non-default LOGICAL kind" }
  inquire(10, opened=l2) ! { dg-error "Non-default LOGICAL kind" }
  inquire(10, pending=l2) ! { dg-error "Non-default LOGICAL kind" }

  close(10, iostat=i)

end


MODULE character_subs

CONTAINS
   FUNCTION abc( n )
   !
   !  Purpose:
   !    To return a string containing the first N characters
   !    of the alphabet.
   !
   !  Record of revisions:
   !      Date       Programmer          Description of change
   !      ====       ==========          =====================
   !    11/25/06    S. J. Chapman        Original code
   !
   IMPLICIT NONE

   ! Declare calling parameters:
   INTEGER, INTENT(IN) :: n         ! Length of string to return
   CHARACTER(len=n) abc             ! Returned string

   ! Declare local variables:
   CHARACTER(len=26) :: alphabet = 'abcdefghijklmnopqrstuvwxyz'

   ! Get string to return
   abc = alphabet(1:n)

   END FUNCTION abc

END MODULE character_subs


program hello_world

  use mpi_f08
  use iso_fortran_env, only: int32, int64
  implicit none

  integer(int32) :: ierr, my_rank, size

  call mpi_init(ierr)

  call mpi_comm_rank(MPI_COMM_WORLD, my_rank, ierr)
  call mpi_comm_size(MPI_COMM_WORLD, size, ierr)

  print *
  write(*, '(2(a,i2))') 'Hello Fortran World! I am rank ', my_rank, ' of size ', size
  print *

  call mpi_finalize(ierr)

end


program pingpong

  implicit none

  include 'mpif.h'

  integer :: mpierror, mpisize, mpirank
  integer, dimension(MPI_STATUS_SIZE) :: mpistatus
  integer :: sendbuf, recvbuf, to, from

  call MPI_Init(mpierror)

  if (mpierror /= 0) then
     stop 'Error initialising MPI'
  end if

  call MPI_Comm_size(MPI_COMM_WORLD, mpisize, mpierror)
  call MPI_Comm_rank(MPI_COMM_WORLD, mpirank, mpierror)

  to = modulo(mpirank+1, mpisize)
  from = modulo(mpirank-1, mpisize)

  sendbuf = mpirank

  if ((mpirank/2)*2 == mpirank) then
     call MPI_Send(sendbuf, 1, MPI_INTEGER, to, 0, MPI_COMM_WORLD, mpierror)
     call MPI_Recv(recvbuf, 1, MPI_INTEGER, from, 0, MPI_COMM_WORLD, &
          & mpistatus, mpierror)
  else
     call MPI_Recv(recvbuf, 1, MPI_INTEGER, from, 0, MPI_COMM_WORLD, &
          & mpistatus, mpierror)
     call MPI_Send(sendbuf, 1, MPI_INTEGER, to, 0, MPI_COMM_WORLD, mpierror)
  end if

  write(*,'(i2,a,i2,a,i2,a,i2)') mpirank, '/', mpisize, '    sent: ', &
       & sendbuf, '    recv: ', recvbuf

  call MPI_Finalize(mpierror)

end program pingpong


PROGRAM dual_if

  IMPLICIT NONE
  INTEGER :: test1, candidate1
  INTEGER :: test2, candidate2

  test1 = 2
  candidate1 = 4

  test2 = 6
  candidate2 = 6

  IF (test1 == candidate1 .OR. test2 == candidate2) THEN
    PRINT *,'One or more candidates are matched'
    IF ((test1 == candidate1) .EQV. (test2 == candidate2)) THEN
      PRINT *,' Both candidates matched'
    END IF
  ELSE
    PRINT *, 'Neither candidate matched'
  END IF

END PROGRAM dual_if


! kindmodule.f90
! Defines working precision

module kindmodule

    use, intrinsic :: iso_fortran_env

    implicit none

    integer, parameter, public :: wp=real64
    integer, parameter, public :: sp=kind(1e0)

end module kindmodule


module swap_interface
 implicit none

 interface swap
   module procedure swapreal, swapint
 end interface swap

CONTAINS

SUBROUTINE swapreal(a,b)
 IMPLICIT NONE
 REAL, INTENT(INOUT) :: a,b
 REAL :: temp
 temp=a
 a=b
 b=temp
 END SUBROUTINE swapreal

SUBROUTINE swapint(a,b)
 IMPLICIT NONE
 INTEGER, INTENT(INOUT) :: a,b
 INTEGER                :: temp
 temp=a
 a=b
 b=temp
 END SUBROUTINE swapint

end module swap_interface


program moduletest
  ! Include functionality from the 'my_module' module
  Use my_module
  Implicit none

  ! Declare test integers
  Integer :: x, y, z

  ! Set one component of the addition to an arbitrary value
  y = 5

  ! Loop from 1 to 10, adding the index value to y each time and
  ! print out the result.
  do x = 1, 10
    z = add_vars(x, y)
    print *, 'z = ', z
  end do

end program


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


! { dg-do run }
! { dg-shouldfail "Compile-time specifier checking" }
!
! Contributed by Dominique Dhumieres <dominiq at lps dot ens dot fr>
program read
   character(50) :: buf='0.D99999'
   double precision val
   read (UNIT=buf, FMT='(D60.0)', ERR=10) Val
   STOP 1
10 read (UNIT=buf, FMT='(D60.0)') Val
end program read
! { dg-output "At line 10 of file.*" }
! { dg-output "Fortran runtime error: Bad value during floating point read" }


program arrays_op_7
implicit none

integer :: x(3), y(3)

x = 3
call f(x, y)
print *, y

contains

    subroutine f(x, y)
    integer, intent(in) :: x(:)
    integer, intent(out) :: y(:)
    y = x
    end subroutine

end program


program kinds

   use iso_fortran_env

   implicit none

   print *, 'Logical  : ', logical_kinds
   print *, 'Character: ', character_kinds
   print *, 'Integer  : ', integer_kinds
   print *, 'Real     : ', real_kinds

end program kinds


module m ! alloc_dt.f90 on GitHub FortranTip
implicit none
type :: data_frame
   character (len=20)              :: title
   character (len=20), allocatable :: colnames(:) ! (ncol)
   real              , allocatable :: x(:,:)      ! (nobs,ncol)
end type data_frame
contains
!
subroutine dealloc(dt) ! deallocate allocatable components of dt
type(data_frame), intent(out) :: dt
end subroutine dealloc
!
end module m
!
program main
use m, only: data_frame, dealloc
implicit none
type(data_frame), allocatable :: dt_alloc ! allocatable scalar
type(data_frame)              :: dt       ! regular scalar
integer, parameter            :: nobs = 100, ncol = 3
allocate (dt_alloc)
allocate (dt_alloc%colnames(ncol), dt_alloc%x(nobs,ncol), &
   dt%colnames(ncol), dt%x(nobs,ncol))
print*,allocated(dt_alloc), allocated(dt_alloc%colnames), &
   allocated(dt_alloc%x),allocated(dt%colnames),allocated(dt%x)
deallocate (dt_alloc) ! also deallocates allocatable components
! A derived type that is not allocatable can be passed
! to an intent(out) dummy argument to deallocate its components
call dealloc(dt)
print*,allocated(dt_alloc),allocated(dt%colnames),allocated(dt%x)
print*,len(dt%title) ! 20, since data_frame%title not allocatable
end program main
! output:
!  T T T T T
!  F F F
! 20


PROGRAM ranktest

  IMPLICIT NONE
  INTEGER, DIMENSION(0:9, -1:10) :: array1
  INTEGER, DIMENSION(:, :), ALLOCATABLE :: array2

  ALLOCATE(array2(-5:4, 1:10))
  array2(3, 7) = 4

END PROGRAM ranktest


program Assignment1

real :: t, n, sum

print*, "Enter the first number"
read*, t
print*, "Enter the second number"
read*, n
sum = t + n
print*, 'The sum of the two numbers is', sum

end program Assignment1


      PROGRAM W07

      PARAMETER (N=10)
      INTEGER A(N)

      I = 1
      J = N
      DO WHILE (I.LT.N)
         A(I) = A(J)
         J = J-1
         I = I+1
      ENDDO
      PRINT *, 'that is all'
      END


The genetics program at UCD covers a classical genetics approach and a more molecular based approach to give students a good well rounded view of the field.  The majors major was restructured in 2004, and the requirements were trimmed in some areas.

It is often said that UC Davis has the Number 1 ranked undergraduates Undergraduate Genetics Program in the nation.

Genetics core courses are offered through the Molecular and Cellular Biology department in the Biological Sciences Division of Biological Sciences.

Genetics is quickly becoming a subject that relies heavly on computers and mathematics.  Hence, one of the most popular minors for genetics majors is Quantitative Biology and Bioinformatics.  This minor can be tailored to completely focus on how one uses math and computers to solve current problems in genetics.


!> Module holding basic KIND parameters
module kind_params_mod
  use iso_c_binding
  implicit none

  public

  !> Douple precision kind parameter
  integer, parameter :: GO_WP = SELECTED_REAL_KIND(12,307)

  ! Kind type for double precision
  integer, parameter :: GO_DP = c_double

end module kind_params_mod


PROGRAM free_source_form_test
    INTEGER :: i
    INTEGER, PARAMETER :: n = 10
    REAL :: x, y, z

    ! This will print something to screen
    DO I = 1, n
        print '(A, I2, A, I2)', 'This is iteration ', I,    &
                                 ' out of ', n
    END DO
    x = 3; y = 5; z = 7
    print *, x, y, z

END PROGRAM free_source_form_test


C***************************************************
C test the simplest helloworld in OpenMP Fortan
C Liao, 12/7/2010
C***************************************************
      PROGRAM HELLO
      include 'omp_lib.h'

      INTEGER NTHREADS, TID
!$OMP PARALLEL PRIVATE(NTHREADS, TID)
      TID = OMP_GET_THREAD_NUM()
      PRINT *, 'Hello World by thread ', TID
c$omp end parallel
      PRINT *, 'the end'
      END


! For derived types with pointer components, whether copying
! is shallow or deep is complicated. See the Fortran Discourse
! thread "Should we avoid assignment of derived types in
! robust programs?"
program main
character (len=20)    :: fmt = "(a,' =',*(1x,i0))"
integer , target      :: a(2)
integer , pointer     :: b(:)
integer , allocatable :: c(:), f(:)
a = [4,9]
b => a ! shallow copy -- changing a changes b
allocate (c, source=a) ! deep copy -- changing a won't change c
associate (d => a)   ! d is a shallow copy
associate (e => (a)) ! e is a deep copy since (a) is expression
f = a ! deep copy
d = d - 1 ! changes a, b, d
print fmt, "a", a
print fmt, "b", b
print fmt, "c", c
print fmt, "d", d
print fmt, "e", e
print fmt, "f", f
end associate ; end associate
end program main
! output:
! a = 3 8
! b = 3 8
! c = 4 9
! d = 3 8
! e = 4 9
! f = 4 9


PROGRAM test_blocks
IMPLICIT NONE
INTEGER :: i, j, k
i = 1
j = 2
k = 3

WRITE(*, *) "BEFORE BLOCK: i, j, k = ", i, j, k
test_block: BLOCK
  INTEGER :: j
  WRITE(*, *) 'In block before DO loop.'
  DO j = 1, 10
    WRITE(*, *) 'In block: i, j, k     = ', i, j, k
    IF (j > 2) EXIT test_block
  END DO
  WRITE(*, *) 'In block after DO loop.'
END BLOCK test_block

WRITE(*, *) 'After block: i, j, k  = ', i, j, k

END PROGRAM test_blocks


!-----------------------------------------------------------------------------!
! \file   Utils/harness/Data_Types.f90
! \author Thomas M. Evans
! \date   Thu Sep  3 16:34:02 2009
! \brief  HARNESS_DATA_TYPES module definition.
! \note   Copyright (C) 2014 Oak Ridge National Laboratory, UT-Battelle, LLC.
!-----------------------------------------------------------------------------!
! $Id: template.f90,v 1.1 2009/09/03 01:59:52 9te Exp $
!-----------------------------------------------------------------------------!

!=============================================================================!
! \module harness_data_types
! \brief  Defines FORTRAN data types.
!=============================================================================!

module harness_data_types

  implicit none

  ! FLOATING-POINT precision control: 4, 8, 16 Byte types.
  integer, parameter :: REAL4  = selected_real_kind(6, 37)
  integer, parameter :: REAL8  = selected_real_kind(13, 300)
  integer, parameter :: REAL16 = selected_real_kind(27, 2400)

  ! INTEGER precision control: 1, 2, 4, 8 Byte types.
  integer, parameter :: INT1 = selected_int_kind(2)
  integer, parameter :: INT2 = selected_int_kind(4)
  integer, parameter :: INT4 = selected_int_kind(9)
  integer, parameter :: INT8 = selected_int_kind(18)

  ! LOGICAL default
  integer, parameter :: LOGIC = kind(.true.)

  ! CHARACTER default
  integer, parameter :: CHAR = kind("len=1")

end module harness_data_types

!-----------------------------------------------------------------------------!
! end of Utils/harness/Data_Types.f90
!-----------------------------------------------------------------------------!


!*******************************************************************
!> author: Akira Kageyama
!  license: MIT
!  date: 2020.01.15
!
!  ユーティリティライブラリ
!
!  @note これは教育用のコードである。
!        メモリの節約については全く考慮していない。
!
module ut_m
  use constants_m
  implicit none
  private
  public :: ut__assert, &
            ut__fatal,  &
            ut__i2c3,   &
            ut__message

  interface ut__message
    !! 文字列（+ 数値）を標準出力に書き出すルーチンの多重定義
    !!
    !! `message_decorated_なんとか` は飾り文字で囲む
    !!
    !! `message_型名[_型名]` は文字列の後のその型の数値を同じ行に書く
     module procedure message_decorated_str,          &
                      message_decorated_str_sint,     &
                      message_decorated_str_dint,     &
                      message_str,                    &
                      message_str_double,             &
                      message_str_double_double,      &
                      message_str_sint,               &
                      message_str_dint,               &
                      message_str_sint_double,        &
                      message_str_dint_double
  end interface

contains

  subroutine message_decorated_str(mark,string)
    !! 飾り文字でメーセージ文を囲む
    !!
    !!   Usage:
    !!
    !!      call message_decorated_str('#',"This is a test.")
    !!
    !!   Output:
    !!
    !!      ###################
    !!      # This is a test. #
    !!      ###################
    !!
    character, intent(in)        :: mark    !! この文字でメーセージを囲む
    character(len=*), intent(in) :: string  !! 出力メーセージ（文字列）

    integer(SI) :: len

    len = len_trim(string) + 4

    write(6,*) repeat(mark,len)
    write(6,*) mark//' '//trim(string)//' '//mark
    write(6,*) repeat(mark,len)
  end subroutine message_decorated_str

  subroutine message_decorated_str_sint(mark,string,int)
    !!  飾り文字でメーセージ文と単精度整数を囲む
    !!
    !!  Usage:
    !!
    !!     call mess...('#','This is message at nloop = ', nloop)
    !!
    character, intent(in)        :: mark   !! この文字で全体を囲む
    character(len=*), intent(in) :: string !! メーセージ文字列
    integer(SI), intent(in)      :: int    !! 文字列の後に書く単精度整数
    character(len=200) :: string_int

    write(string_int,'(a,i8)') string, int

    call message_decorated_str(mark, string_int)
  end subroutine message_decorated_str_sint

  subroutine message_decorated_str_dint(mark,string,int)
    !! 飾り文字でメーセージ文と倍精度整数を囲む
    !!
    !! Usage:
    !!
    !!    call mess...('#','This is message at nloop = ', nloop)
    !!
    character, intent(in)        :: mark   !! この文字で全体を囲む
    character(len=*), intent(in) :: string !! メーセージ文字列
    integer(DI), intent(in)      :: int    !! 文字列の後に書く倍精度整数
    character(len=200) :: string_int

    write(string_int,'(a,i16)') string, int

    call message_decorated_str(mark, string_int)
  end subroutine message_decorated_str_dint

  subroutine message_str(string)
    !! 普通のprint文
    character(len=*), intent(in) :: string !! メーセージ文字列

    write(6,*) string
  end subroutine message_str

  subroutine message_str_double(string, double)
    !! 文字列 + 倍精度実数2つの出力
    character(len=*), intent(in) :: string !! メーセージ文字列
    real(DR), intent(in)         :: double !! 書き出される実数

    write(6,*) string, double
  end subroutine message_str_double

  subroutine message_str_double_double(string, double1, double2)
    !! 飾り文字でメーセージ文と倍精度実数2つを囲む
    character(len=*), intent(in) :: string  !! メーセージ文字列
    real(DR), intent(in)         :: double1 !! 書き出される実数1
    real(DR), intent(in)         :: double2 !! 書き出される実数2

    write(6,*) string, double1, double2
  end subroutine message_str_double_double

  subroutine message_str_sint(string, int)
    !! 文字列 + 単精度整数の出力
    character(len=*), intent(in) :: string  !! メーセージ文字列
    integer(SI), intent(in)      :: int     !! 書き出される整数

    write(6,*) string, int
  end subroutine message_str_sint

  subroutine message_str_dint(string, int)
    !! 文字列 + 倍精度整数の出力
    character(len=*), intent(in) :: string  !! メーセージ文字列
    integer(DI), intent(in)      :: int     !! 書き出される整数

    write(6,*) string, int
  end subroutine message_str_dint

  subroutine message_str_sint_double(string, i1, d1)
    !! 文字列 + 単精度整数 + 倍精度実数の出力
    character(len=*), intent(in) :: string  !! メーセージ文字列
    integer(SI), intent(in)      :: i1      !! 書き出される整数
    real(DR), intent(in)         :: d1      !! 書き出される実数

    write(6,*) string, i1, d1
  end subroutine message_str_sint_double

  subroutine message_str_dint_double(string, i1, d1)
    !! 文字列 + 倍精度整数 + 倍精度実数の出力
    character(len=*), intent(in) :: string  !! メーセージ文字列
    integer(DI), intent(in)      :: i1      !! 書き出される整数
    real(DR), intent(in)         :: d1      !! 書き出される実数

    write(6,*) string, i1, d1
  end subroutine message_str_dint_double

!
! Private
!===============
! Public
!

  subroutine ut__assert(must_be_true,message)
    !! アサーション
    logical,          intent(in) :: must_be_true !! 必須条件
    character(len=*), intent(in) :: message      !! 遺言

    if ( .not.must_be_true ) then
       call ut__fatal(message)
    end if
  end subroutine ut__assert

  subroutine ut__fatal(last_will)
    !! 致命的エラー
    !!
    !!   Print the last_will and stop.
    !!
    character(len=*), intent(in) :: last_will   !! 遺言
    call ut__message('!',last_will)
    stop 'Program stopped by ut__fatal.'
  end subroutine ut__fatal

  function ut__i2c3(i)
    !! 整数を文字列（3文字固定）に変換する
    !!
    !!  Convert an integer into 3 characters.
    !!
    !!             e.g., i=10 --> str3="010"
    !!
    integer(SI), intent(in) :: i
    character(len=3)        :: ut__i2c3
    if (i>999) then
       ut__i2c3 = 'XXX'
    else
       write(ut__i2c3,'(i3.3)') i
    end if
  end function ut__i2c3

end module ut_m


! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
integer :: x
!ERROR: The type of 'x' has already been declared
real :: x
integer(8) :: i
parameter(i=1,j=2,k=3)
integer :: j
!ERROR: The type of 'k' has already been implicitly declared
real :: k
end


           program demo_cpu_time
           implicit none
           real :: start, finish
              !
              call cpu_time(start)
              ! put code to test here
              call cpu_time(finish)
              !
              ! writes processor time taken by the piece of code.
              print '("Processor Time = ",f6.3," seconds.")',finish-start
           end program demo_cpu_time


program alloctest
  integer :: a, &
    b

  a = &
    ! multi line expr
    5
    !this is a comment
  b = &
    10 ! this is a comment
  print *, & ! multi line print
    !multiline print
    a * b
    !this is a comment

end program alloctest


! ###################################################################
! Copyright (c) 2013-2020, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMxtalExtract.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMmkxtalExtract
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief extract information from a crystal structure file and put in txt file for input redirect
!
!> @date   07/19/18 MDG 1.0 original
!--------------------------------------------------------------------------
program EMxtalExtract

use local
use typedefs
use HDFsupport
use io
use crystal
use symmetry
use files

IMPLICIT NONE

type(unitcell)                  :: cell
character(fnlen)                :: progname, progdesc, fname, txtname
integer(kind=irg)               :: numarg, i, io_int(3)
real(kind=dbl)                  :: io_real(5)
integer(kind=irg)               :: iargc        !< external function for command line
character(fnlen)                :: arg          !< to be read from the command line

!> numbers of the space groups with two settings
integer(kind=irg),parameter     :: tworig(24)=(/48,50,59,68,70,85,86,88,125,126,129,130,133,134,137,138,&
                                                141,142,201,203,222,224,227,228/)

 !nullify(cell)
 !allocate(cell)

 progname = 'EMxtalExtract.f90'
 progdesc = 'Extract all information from an HDF crystal structure file and dump it in regular or Wyckoff form to a text file'

! deal with the command line arguments, if any
 call Interpret_Program_Arguments(1,(/ 926 /), progname)

 call EMsoft(progname, progdesc)

 numarg = iargc()
 if (numarg.gt.0) then ! there is at least one argument
  do i=1,numarg
    call getarg(i,arg)
! does the argument start with a '-' character?
    if (arg(1:1).eq.'-') then
        if (trim(arg).eq.'-h') then
         call Message(' Program should be called as follows: ', frm = "(/A)")
         call Message('        '//trim(progname)//' [-h] ', frm = "(A)")
         call Message(' To produce this message, type '//trim(progname)//' -h', frm = "(A)")
        end if
    end if
  end do
 end if

 call ReadValue('Enter input xtal file name (*.xtal) ', fname)
 cell%fname = trim(fname)
 call CrystalData(cell,verbose=.TRUE.)
 call CalcPositions(cell,'v')

 call ReadValue('Enter text file name for output (*.txt) ', txtname)
 open (unit=dataunit, file=trim(txtname), status='unknown',form='formatted')

! 1. write the crystal system
 if (cell%SG%SYM_trigonal.eqv..TRUE.) then
    write(dataunit,"(I1)") 5
    if (cell%xtal_system.eq.4) then
      write(dataunit,"(I1)") 1
    else
      write(dataunit,"(I1)") 0
    end if
 else
    write(dataunit,"(I1)") cell%xtal_system
 end if

! 2. lattice parameters (only the ones that are needed)
! a is always needed
 write(dataunit,"(F10.5)") cell%a
 select case (cell%xtal_system)
    case (1)
  ! tetragonal
    case (2)
     write(dataunit,"(F10.5)") cell%c
  ! orthorhombic
    case (3)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
  ! hexagonal
    case (4)
     write(dataunit,"(F10.5)") cell%c
  ! rhombohedral
    case (5)
     write(dataunit,"(F10.5)") cell%alpha
  ! monoclinic
    case (6)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
     write(dataunit,"(F10.5)") cell%beta
  ! triclinic
    case (7)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
     write(dataunit,"(F10.5)") cell%alpha
     write(dataunit,"(F10.5)") cell%beta
     write(dataunit,"(F10.5)") cell%gamma
 end select

! 3. space group number
 write(dataunit,"(I3)") cell%SYM_SGnum

! 4. some space groups have a second setting
 if (minval(tworig-cell%SYM_SGnum).eq.0) then
   write(dataunit,"(I3)") cell%SYM_SGset
 end if

! 5. the atom coordinates, site occupations, and Debye-Waller factors are output here...
 do i=1,cell%ATOM_ntype
   if (i.gt.1) write(dataunit,"('y')")
   write(dataunit,"(I2)") cell%ATOM_type(i)
   write(dataunit,"(4(F10.5,','),F10.5)") cell%ATOM_pos(i,1:5)
 end do
 write(dataunit,"('n')")

! 6. xtal file name
 write(dataunit,"(A)") trim(cell%fname)

! 7. source, if defined
 if (trim(cell%source).eq.'undefined') then
   write(dataunit,"(A)") ''''''
   call Message('')
   call Message('=========================')
   call Message('The current version of the structure file has an empty Source field.')
   call Message('Please edit the text file and add a citation describing where the structure data comes from (max 512 characters).')
   call Message('=========================')
   call Message('')
 else
   write(dataunit,"('''',A,'''')") trim(cell%source)
 end if

 close(unit=dataunit,status='keep')

 call Message('')
 call Message('The text output file '//trim(fname)//' has been created.')
 call Message('You can edit this file with a text editor to make corrections,')
 call Message('or to add a Source string on the last line (if not already present) between single quotes')
 call Message('Then, use the following command to update the actual structure file:')
 call Message('')
 call Message('EMmkxtal < '//trim(txtname))
 call Message('')

end program EMxtalExtract


C******************************************************************************
C FILE: omp_bug1.f
C DESCRIPTION:
C   This example attempts to show use of the PARALLEL DO construct.  However
C   it will generate errors at compile time.  Try to determine what is causing
C   the error.  See omp_bug1fix.f for a corrected version.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM WORKSHARE3

      INTEGER TID, OMP_GET_THREAD_NUM, N, I, CHUNKSIZE, CHUNK
      PARAMETER (N=50)
      PARAMETER (CHUNKSIZE=5)
      REAL A(N), B(N), C(N)

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.0
        B(I) = A(I)
      ENDDO
      CHUNK = CHUNKSIZE

!$OMP  PARALLEL DO SHARED(A,B,C,CHUNK)
!$OMP& PRIVATE(I,TID)
!$OMP& SCHEDULE(STATIC,CHUNK)

      TID = OMP_GET_THREAD_NUM()
      DO I = 1, N
         C(I) = A(I) + B(I)
         PRINT *,'TID= ',TID,'I= ',I,'C(I)= ',C(I)
      ENDDO

!$OMP  END PARALLEL DO

      END


      program ifthenelse01

      read *,i

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

      end


MODULE x
CONTAINS
FUNCTION swap_string(string)
IMPLICIT NONE
CHARACTER(len=*), INTENT(IN) :: string
CHARACTER(len=len(string)) :: swap_string
INTEGER :: length, i
length = LEN(string)
DO i = 1, length
    swap_string(length-i+1:length-i+1) = string(i:i)
END DO
END FUNCTION
END MODULE
PROGRAM test
USE x
CHARACTER(len=12) :: str
str = 'ABCDEFGHI'
WRITE (*,*) swap_string(str)
END PROGRAM test


module MOD
contains
  subroutine SUB(a,b)
    implicit none
    integer :: a
    integer, optional :: b
    integer :: b_aux

    if (.NOT. present(b)) then
       b_aux=0
    else
       b_aux=b
    end if
    print*, a,b_aux
  end subroutine SUB
end module MOD

program TEST
  use MOD
  implicit none

  integer :: i=2, j=1

  call SUB(i,j)
  call SUB(i)
  call SUB(j)

end program TEST


program t
  integer::a = 10, b = 20

  if (a == 10) then
   a = 30
   b = 20
  else
   a =  b + 20
   b = 40
  end if

  print *,a, b
end program t


! { dg-do compile }
! { dg-options "-finit-local-zero -fno-automatic" }
!
! PR fortran/53818
!
! Contributed by John Moyard
!
logical function testing(date1, date2) result(test)
  integer  date1, date2
  test = ( (date1 < date2) .or. ( date1==date2 ))
end function testing


program logical1
    ! this program checks logical operators
    implicit none

       ! variable declaration
       logical :: a, b

       ! assigning values
       a = .true.
       b = .false.

       print *, a, b

end program logical1


! this is a comment
program alloctest
  ! this is a comment
  ! this is a comment

  integer, allocatable :: a(:, :)
  integer :: i, j !this is a comment
  allocate(a(2, 2))

! this is a comment

! this is a comment

  !this is a comment
  do i = 1, 2
    do j = 1, 2
      a(i, j) = i * j
    end do
    !this is a comment
  end do
  print *, a
  !this is a comment
end program alloctest
! this is a comment


!! R560 implicit-stmt
!    is IMPLICIT implicit-spec-list
!    or IMPLICIT NONE
!
!! R561 implicit-spec
!    is declaration-type-spec ( letter-spec-list )
!
!! R562 letter-spec
!    is letter [ – letter ]

10 IMPLICIT None

implicit real (X, y, Z), integer (i, j, k-L)

end