! bof
! **********************************************************************
! Fortran 95 module f95_standard_definitions

! **********************************************************************
! Source Control Strings

! $Id: f95def.f90 1.1 2004/12/30 22:29:45Z Dan Exp $

! **********************************************************************
!  Copyright 2004 Purple Sage Computing Solutions, Inc.

!   This library is free software; you can redistribute it and/or
!   modify it under the terms of the GNU Library General Public
!   License as published by the Free Software Foundation; either
!   version 2 of the License, or (at your option) any later version.

!   This library is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!   Library General Public License for more details.

!   You should have received a copy of the GNU Library General Public
!   License along with this library; if not, write to the Free
!   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

! To report bugs, suggest enhancements, etc. to the Authors,
! Contact:
!    Purple Sage Computing Solutions, Inc.
!                               send email to dnagle@erols.com
!                                   or fax to 703 425-0983 (USA)
!                                  or mail to 10483 Malone Ct.
!                                             Fairfax, VA 22032 USA

! **********************************************************************
! f95_standard_definitions description

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

!  f95_standard_definitions uses

!     no modules

!  f95_standard_definitions constants

!     f95_standard_definitions_rcs_id= this file's RCS Identifier

!     no_such_precision= return value from selected_real_kind()
!     no_such_range= return value from selected_real_kind()
!     no_such_real= return value from selected_real_kind()
!     not_a_kind= kind value if no processor support

!     substring_not_found= index() return value
!     null_substring= index() return value
!     none_in_set= scan() return value
!     all_in_set= verify() return value

!     not_a_unit= unit number of a file not connected
!     not_a_filesize= filesize if it can't be determined
!     no_records_read= next record if no records read yet
!     fmt_overflow= printed when value overflows format width

!     cc_skipline= skips one line if asa carriage control
!     cc_newpage= skips to next page if asa carriage control
!     cc_overwrite= overwrite current line if asa carriage control
!     cc_newline= start next line if asa carriage control

!     not_a_time= date_and_time()/system_clock() return value
!     not_a_count= system_clock() rate and max return value
!     date_len= date_and_time() date length
!     time_len= date_and_time() time length
!     zone_len= date_and_time() zone length

!     values_size= size of the values array argument of date_and_time()
!     values_year= values array element containing the year
!     values_month= values array element containing the month
!     values_day= values array element containing the day
!     values_utc= values array element containing the delta to utc
!     values_hour= values array element containing the hour
!     values_minute= values array element containing the minute
!     values_second= values array element containing the second
!     values_msec= values array element containing the millisecond

!     max_rank= maximum rank (of arrays)
!     status_success= no error value from iostat= and stat= specifiers

!  f95_standard_definitions types

!     none

!  f95_standard_definitions data

!     none

!  processor_dependencies operators
 
!     none
 
!  f95_standard_definitions library

!     is_valid_kind() true if kind is (possibly) supported

!     substring_len() compute length of a substring from first and last indices
!     array_order() compute order value from array subscripts
!     array_indices() compute array subscripts from order value
!     triplet_count() count implied by a triplet

!     is_status_error() true if status indicates processor error
!     is_status_info() true if status indicates processor information
!     is_status_success() true if status indicates success

!     has_cpu_time() true if processor reports cpu time

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

!  f95_standard_definitions

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

module f95_standard_definitions

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

!  f95_standard_definitions uses no module
!  this module provides definitions specified by the Fortran 90 standard

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

!  explicit names

implicit none

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

!  explicit exports

private

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

!  static module data

save

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

!  f95_standard_definitions RCS strings

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

!  module source filename supplied by RCS

character( len= *), public, parameter :: f95_standard_definitions_rcs_id = &
   '$Id: f95def.f90 1.1 2004/12/30 22:29:45Z Dan Exp $'

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

!  f95_standard_definitions constants

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

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

!  f95_standard_definitions constants relating to kinds

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

!  error return values from selected_?_kind() specified by Fortran standard

integer, public, parameter :: not_a_kind = -1

!  selected_real_kind()

integer, public, parameter :: no_such_precision = -1
integer, public, parameter :: no_such_range = -2
integer, public, parameter :: no_such_real = -3

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

!  f95_standard_definitions constants relating to string intrinsics

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

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

!  magic index()/scan()/verify() return values

integer, public, parameter :: substring_not_found = 0                ! index()
integer, public, parameter :: null_substring = 1                     ! index()

integer, public, parameter :: none_in_set = 0                        ! scan()
integer, public, parameter :: all_in_set = 0                         ! verify()

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

!  f95_standard_definitions constants relating to input/output

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

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

!  not_a_unit= inquire unit number of a file not connected

integer, public, parameter :: not_a_unit = -1

!  not_a_filesize= size of a file when filesize is not available

integer, public, parameter :: not_a_filesize = -1

!  no_records_read= nextrec before any records have been processed

integer, public, parameter :: no_records_read = 1

!  fmt_overflow= character in numeric output when the value overflows the width

character( len= *), public, parameter :: fmt_overflow = '*'

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

!  f77 (asa) carriage control in effect for processor dependent units

!  skip a line

character( len= *), public, parameter :: cc_skipline = '0'

!  skip to new page

character( len= *), public, parameter :: cc_newpage = '1'

!  overwrite current line

character( len= *), public, parameter :: cc_overwrite = '+'

!  start new line

character( len= *), public, parameter :: cc_newline = ' '

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

!  f95_standard_definitions constants relating to date and time intrinsics

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

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

!  date_and_time()/system_clock() return 'processor has no clock'

integer, public, parameter :: not_a_time = -huge( 0)

!  system_clock() rate and count when 'processor has no clock'

integer, public, parameter :: not_a_count = 0

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

!  length of date_and_time() date, time & zone strings

integer, public, parameter :: date_len = 8                           ! date*8
integer, public, parameter :: time_len = 10                          ! time*10
integer, public, parameter :: zone_len = 5                           ! zone*5

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

!  size of date_and_time() values array

integer, public, parameter :: values_size = 8                        ! values( size)

!  date_and_time() values array elements

integer, public, parameter :: values_year = 1                        ! year
integer, public, parameter :: values_month = 2                       ! month
integer, public, parameter :: values_day = 3                         ! day
integer, public, parameter :: values_utc = 4                         ! delta to utc ( time zone)
integer, public, parameter :: values_hour = 5                        ! hour
integer, public, parameter :: values_minute = 6                      ! minute
integer, public, parameter :: values_second = 7                      ! second
integer, public, parameter :: values_msec = 8                        ! millisecond

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

!  f95_standard_definitions constants relating to command lines and environment

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

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

!  command line values

integer, public, parameter :: command_too_short = -1                 ! value longer than command variable

!  environment values

integer, public, parameter :: value_too_short = -1                   ! value longer than value variable
integer, public, parameter :: no_such_variable = 1                   ! no such variable in the environment
integer, public, parameter :: no_environment = 2                     ! processor has no environment

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

!  f95_standard_definitions miscellaneous constants

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

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

!  maximum array rank

integer, public, parameter :: max_rank = 7

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

!  (de)allocate, iostat, etc. status 'no error'

integer, public, parameter :: status_success = 0                     ! IOSTAT= or STAT=

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

!  f95_standard_definitions types

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

!     none

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

!  f95_standard_definitions data

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

!     none

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

!  f95_standard_definitions library

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

!     none

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

!  public module procedures

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

!  export the generic names, not the specific names

public :: is_valid_kind                                              ! export

public :: substring_len                                              ! export
public :: array_order                                                ! export
public :: array_indices                                              ! export
public :: triplet_count                                              ! export

public :: is_status_error                                            ! export
public :: is_status_info                                             ! export
public :: is_status_success                                          ! export

public :: has_cpu_time                                               ! export

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

!  module procedures

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

contains                                                             ! f95_standard_definitions

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

! This procedure returns true if its argument represents
! a possibly valid kind value.

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

!  is_valid_kind()

elemental logical function is_valid_kind( k)

integer, intent( in) :: k

!  is_valid_kind()

continue                                                             ! is_valid_kind()

   is_valid_kind = ( k > 0)                                          ! valid kind

return                                                               ! is_valid_kind()

!  is_valid_kind()

end function is_valid_kind

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

! This procedure uses Fortran character storage order to translate
! from a substring's first and last indices to the substring length.

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

! substring_len() number of characters inferred from first and last indices

elemental integer function substring_len( first, last)

!  substring_len() interface

integer, intent( in) :: first                                        ! first character in substring

integer, intent( in) :: last                                         ! last character in substring

!  substring_len()

continue                                                             ! substring_len()

   substring_len = max( last - first + 1, 0)                         ! length of substring

return                                                               ! substring_len()

!  substring_len()

end function substring_len

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

! These procedures use Fortran array storage order to translate
! between an array order value and subscripts using lower and
! upper bounds.

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

! array_order() array order value from subscripts

pure integer function array_order( indices, lb, ub)

!  array_order() interface

integer, dimension( :), intent( in) :: indices                       ! indices to be reduced

integer, dimension( :), optional, intent( in) :: lb                  ! optional lower bounds of array

integer, dimension( :), intent( in) :: ub                            ! upper bounds of array

!  array_order() local

   integer, dimension( max_rank) :: local_lb                         ! use input or default_lb = 1

   integer, dimension( 0: max_rank) :: d                             ! partial translations

   integer :: this_extent                                            ! loop through extents

   integer :: rank                                                   ! rank of translation

!  array_order()

continue                                                             ! array_order()

!  setup lower bounds

   default_lb: if( present( lb) )then                                ! lower bounds

      rank = min( size( indices), size( ub), size( lb), max_rank)    ! rank of translation

      local_lb( 1: rank) = lb                                        ! use argument

   else default_lb                                                   ! lower bounds

      rank = min( size( indices), size( ub), max_rank)               ! rank of translation

      local_lb( 1: rank) = 1                                         ! use default_lb

   endif default_lb                                                  ! lower bounds

!  loop over each dimension

   array_order = 1                                                   ! initialize
   d( 0) = max( ub( 1) - local_lb( 1) + 1, 0)

   each_extent: do this_extent = 1, rank                             ! rank of array

      array_order = array_order + ( indices( this_extent) - local_lb( this_extent)) * d( this_extent - 1)

      d( this_extent) = max( ub( this_extent) - local_lb( this_extent) + 1, 0) * d( this_extent - 1)

   enddo each_extent                                                 ! rank of array

return                                                               ! array_order()

!  array_order()

end function array_order

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

! array_indices() array subscripts from array order value

pure integer function array_indices( offset, lb, ub)

!  array_indices() interface

integer, intent( in) :: offset                                       ! from array base

integer, dimension( :), optional, intent( in) :: lb                  ! optional lower bounds of array

integer, dimension( :), intent( in) :: ub                            ! upper bounds of array

dimension :: array_indices( size( ub))                               ! number of indices returned

!  array_indices() local

   integer, dimension( max_rank) :: local_lb                         ! use input or default_lb = 1

   integer, dimension( max_rank) :: d                                ! partial translations

   integer :: this_extent                                            ! loop through extents

   integer :: reduced_offset                                         ! reduce offset as indices are computed

   integer :: rank                                                   ! rank of translation

!  array_indices()

continue                                                             ! array_indices()

!  setup lower bounds

   default_lb: if( present( lb) )then                                ! lower bounds

      rank = min( size( ub), size( lb), max_rank)                    ! rank of translation

      local_lb( 1: rank) = lb                                        ! use argument

   else default_lb                                                   ! lower bounds

      rank = min( size( ub), max_rank)                               ! rank of translation

      local_lb( 1: rank) = 1                                         ! use default_lb

   endif default_lb                                                  ! lower bounds

!  loop over each dimension

   d( 1: rank) = max( ub( 1: rank) - local_lb( 1: rank) + 1,  0)     ! initialize
   reduced_offset = offset - 1

   each_extent: do this_extent = 1, rank                             ! rank of array

      array_indices( this_extent) = mod( reduced_offset, d( this_extent)) + local_lb( this_extent)

      reduced_offset = reduced_offset / d( this_extent)              ! reduce offset by this extent

   enddo each_extent                                                 ! rank of array

return                                                               ! array_indices()

!  array_indices()

end function array_indices

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

! This procedure computes the Fortran iteration count
! or the number of array elements implied by a triplet
! of default_lb integers.

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

! triplet_count() iteration count from a triplet of integers

elemental integer function triplet_count( m1, m2, m3)

!  triplet_count() interface

integer, intent( in) :: m1                                           ! lower bound

integer, intent( in) :: m2                                           ! upper bound

integer, optional, intent( in) :: m3                                 ! (optional) increment

!  triplet_count() text

continue                                                             ! triplet_count()

!  compute count whether m3 present or not

   default_m3: if( present( m3) )then                                ! skip increment

      triplet_count = max( ( m2 - m1 + m3) / m3, 0)

   else default_m3                                                   ! skip increment

      triplet_count = max( ( m2 - m1 + 1), 0)

   endif default_m3                                                  ! skip increment

return                                                               ! triplet_count()

!  triplet_count()

end function triplet_count

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

! The following functions detect the conditions indicated according
! to rules specified by the Fortran standard.  The status return
! value is required to be a code indicating, an error, some information,
! or success.

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

!  is_status_error()/is_status_end()/is_status_success() interpret status

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

!  is_status_error() true if status_value indicates error

pure logical function is_status_error( status_value)

integer, intent( in) :: status_value

!  is_status_error()

continue                                                             ! is_status_error()

   is_status_error = ( status_value > 0)                             ! error condition

return                                                               ! is_status_error()

!  is_status_error()

end function is_status_error

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

!  is_status_info() true if status_value indicates processor information

pure logical function is_status_info( status_value)

integer, intent( in) :: status_value

!  is_status_info()

continue                                                             ! is_status_info()

   is_status_info = ( status_value < 0)                              ! processor information

return                                                               ! is_status_info()

!  is_status_info()

end function is_status_info

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

!  is_status_success() true if status_value indicates success

pure logical function is_status_success( status_value)

integer, intent( in) :: status_value

!  is_status_success()

continue                                                             ! is_status_success()

   is_status_success = ( status_value == 0)                          ! status ok

return                                                               ! is_status_success()

!  is_status_success()

end function is_status_success

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

! This function diagnoses the return value of the cpu_time() intrinsic
! to see if the processor reports cpu time.

! Remember that the standard discourages interprocessor comparisons
! of cpu time due to possibly differing definitions of cpu time on
! different processors.

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

!  has_cpu_time() true if processor reports cpu time

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

logical function has_cpu_time()

!  has_cpu_time() local

   real :: ct                                                        ! intrinsic result

!  has_cpu_time()

continue                                                             ! has_cpu_time()

   call cpu_time( ct)                                                ! trial request

   has_cpu_time = ( ct >= 0.0)                                       ! negative means no cpu time

return                                                               ! has_cpu_time()

!  has_cpu_time()

end function has_cpu_time

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

!  f95_standard_definitions

! $Id: f95def.f90 1.1 2004/12/30 22:29:45Z Dan Exp $
! **********************************************************************

end module f95_standard_definitions                                  ! eof