! bof
! **********************************************************************
! Fortran 95 program make_processor_model

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

! $Id: make_pm.f90 2.2 2005/05/30 15:47:01Z Dan Release $

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

! **********************************************************************
! Summary of License

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

!   This program 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 General Public License for more details.

!   You should have received a copy of the GNU General Public License
!   along with this program; 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 mail to 10483 Malone Ct.
!                                             Fairfax, VA 22032 USA

! **********************************************************************
! writes a processor_dependencies module and a processor_model program

! **********************************************************************
! use none

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

!  make_processor_model uses

!     <none>

!  make_processor_model includes

!     <none>

!  make_processor_model reads

!     make_pm.in: an optional namelist file of quantities beyond diagnosis

!  make_processor_model writes

!     make_pm.log: logfile of make_processor_model actions
!     coco.inc | f90ppr.inc | fpp.inc: optional file of preprocessor definitions
!     procdep.f90: fortran 95 source code module processor_dependencies
!     pm.f90: fortran 95 source code to display processor model

!  make_processor_model library

!     read_input_file() reads the processor description file, if present
!     seek_namelist_group() tries to find a namelist group in the input file
!     seek_integer_kinds() seeks integer kinds
!     seek_real_kinds() seeks real kinds
!     check_character_kinds() checks user specified character kinds
!     check_logical_kinds() checks user specified logical kinds
!     check_hardware_values() experiments to verify claims about the hardware
!     is_power_of_2() returns true if its positive argument is a power of two
!     check_ieee_single() experiments to verify ieee single format
!     check_ieee_double() experiments to verify ieee double format
!     check_ieee_single_extended() experiments to verify ieee single extended format
!     check_ieee_double_extended() experiments to verify ieee double extended format
!     diagnose_input_output() experiments on input/output processor dependencies
!     write_bit_size() writes a bit_size() using the Method of Olagnon
!     write_include_file() write preprocessor include file
!     write_processor_dependencies() writes the processor_dependencies module
!     write_processor_model() writes the processor_model program

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

!  make_processor_model

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

program make_processor_model

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

!  use no module

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

!  declare all variable names

implicit none                                                        ! no implicit declarations

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

!  make_processor_model RCS strings

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

!  program identifier string supplied by RCS

character( len= *), parameter :: make_pm_rcs_id = &
   '$Id: make_pm.f90 2.2 2005/05/30 15:47:01Z Dan Release $'

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

!  make_processor_model stop character codes

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

!  program normal exit

character( len= *), parameter :: normal_stop_code = &
   'make_processor_model: complete'

!  program error exit

character( len= *), parameter :: error_stop_code = &
   'make_processor_model: not complete'

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

!  make_processor_model logical units

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

!  make_pm.log unit

integer, parameter :: log_unit = 10                                  ! write logfile

!  make_pm.in unit

integer, parameter :: nml_unit = 11                                  ! read namelist

!  procdep.f90 unit

integer, parameter :: pd_unit = 12                                   ! write module source

!  pm.f90 unit

integer, parameter :: pm_unit = 13                                   ! write program source

!  preprocessor include file

integer, parameter :: inc_unit = 14                                  ! write include file

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

!  unit to use to guess the name of a file opened without a name

integer, parameter :: fn_unit = 3                                    ! logical unit number
character( len= *), parameter :: ch_fn_unit = '3'                    ! search for this character

!  unit for direct access experiments

integer, parameter :: da_unit = fn_unit + 1                          ! use another unit

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

!  make_processor_model formats

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

!  format for fortran source output

character( len= *), parameter :: fmtpr = '( a)'                      ! string

!  format for default kind values (non-advancing i/o)

character( len= *), parameter :: fmti = '( 1x, i20)'                 ! + integer

!  formats for fortran source output with single integer

character( len= *), parameter :: fmtpri = '( a, 1x, i20)'            ! string + integer

!  format for fortran source output with single digit integer & closing paren

character( len= *), parameter :: fmtprip = '( a, 1x, i5, ")")'       ! string + integer + ")"

!  format for fortran source output with 2 integers & closing paren

character( len= *), parameter :: fmtpriip = &
                                 '( a, 1x, i5, ", ", i5, ")")'       ! string + integer + "," + integer + ")"

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

!  make_processor_model constants

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

!  character buffer length reserved for file names

integer, parameter :: name_len = 1024                                ! hopefully long enough

!  character component length reserved for kind names

integer, parameter :: kind_len = 64                                  ! must be long enough

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

!  this can't be changed because it's the name of the file containing the namelists

character( len= *), parameter :: rc_name = 'make_pm.in'              ! nml_unit

!  this can't be changed because it's opened before make_pm.in is read

character( len= *), parameter :: logname = 'make_pm.log'             ! log_unit

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

!  ascii change case

integer, parameter :: change_case = 32                               ! compare lower case

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

!  denotes a kind not supported

integer, parameter :: not_supported = -1                             ! internal code

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

!  codes for various standards

integer, parameter :: no_std = 0                                     ! any standard pre-f90 (no modules)
integer, parameter :: f90_std = no_std + 1                           ! f90
integer, parameter :: f95_std = f90_std + 1                          ! f95
integer, parameter :: f03_std = f95_std + 1                          ! f03
integer, parameter :: f08_std = f03_std + 1                          ! f08

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

!  codes for various preprocessors

integer, parameter :: no_inc = 0                                     ! no preprocessor file
integer, parameter :: coco_inc = no_inc + 1                          ! coco.inc
integer, parameter :: f90ppr_inc = coco_inc + 1                      ! f90ppr.inc
integer, parameter :: fpp_inc = f90ppr_inc + 1                       ! fpp.inc

character( len= *), parameter :: coco_name = 'coco.inc'              ! coco include filename
character( len= *), parameter :: f90ppr_name = 'f90ppr.inc'          ! f90ppr include filename
character( len= *), parameter :: fpp_name = 'fpp.inc'                ! fpp include filename

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

!  complaints, messages, etc.

character( len= *), parameter :: cant_open = "can't open "           ! announce failure

character( len= *), parameter :: write_ln = '      write( unit= *, fmt= *)'

character( len= *), parameter :: star_banner = &
   '! **********************************************************************'

character( len= *), parameter :: wa_str = '(words)'                  ! units for message

character( len= *), parameter :: ba_str = '(bytes)'                  ! units for message

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

!  default number of (named) kinds

integer, parameter :: default_number_of_integers = 4                 ! byte, short, int, long

integer, parameter :: default_number_of_reals = 3                    ! single, double, quad

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

!  make_processor_model() types

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

!  an integer kind

type :: integer_kind_t                                               ! describe an integer kind

   character( len= kind_len) :: kind_name                            ! the kinds name (less the '_k')

   integer :: kind_value                                             ! integers have kind values
   integer :: max_digits                                             ! most digits this kind supports
   integer :: integer_bit_size                                       ! estimated size in bits

   logical :: supported                                              ! kind is byte, short, int, long, or int<bits>
   logical :: default_kind                                           ! one kind is the default

end type integer_kind_t                                              ! describe an integer kind

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

!  a real kind (& therefore a complex kind)

type :: real_kind_t                                                  ! describe an real kind

   character( len= kind_len) :: kind_name                            ! the kinds name (less the '_k')

   integer :: kind_value                                             ! reals have kind values
   integer :: max_precision                                          ! reals support a precision
   integer :: max_range                                              ! reals support a range
   integer :: real_bit_size                                          ! estimated size in bits

   logical :: supported                                              ! kind is one of single, double, quad
   logical :: default_kind                                           ! one kind is the default real
   logical :: default_dp_kind                                        ! one kind is the default double precision

end type real_kind_t                                                 ! describe an real kind

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

!  a logical kind

type :: logical_kind_t                                               ! describe a logical kind

   character( len= kind_len) :: kind_name                            ! the kinds name (less the '_k')

   integer :: kind_value                                             ! logicals have kind values

   logical :: supported                                              ! kind is one of single, double, quad
   logical :: default_kind                                           ! one kind is the default

end type logical_kind_t                                              ! describe a logical kind

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

!  a character kind

type :: character_kind_t                                             ! describe a character kind

   character( len= kind_len) :: kind_name                            ! the kinds name (less the '_k')

   integer :: kind_value                                             ! characters have kind values

   logical :: supported                                              ! kind is one of single, double, quad
   logical :: default_kind                                           ! one kind is the default

   character( len= name_len) :: inquiry_string                       ! argument to selected_char_kind()

end type character_kind_t                                            ! describe a character kind

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

!  make_processor_model data

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

!  configuration data

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

!  standard code designates the standard supported by the processor

integer :: standard = no_std                                         ! set via namelist string

character( len= *), parameter :: f90_str = 'Fortran 90'
character( len= *), parameter :: f95_str = 'Fortran 95'
character( len= *), parameter :: f03_str = 'Fortran 2003'
character( len= *), parameter :: f08_str = 'Fortran 2008'

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

!  preprocessor code designates the preprocessor, if any, of the include file

integer :: ppr_inc = no_inc                                          ! set via namelist string

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

!  status date and time strings

integer, parameter :: dt_len = 10                                    ! long enough for date string
integer, parameter :: tm_len = 10                                    ! long enough for time string

character( len= dt_len) :: run_date = ' '                            ! date for logfile
character( len= tm_len) :: run_time = ' '                            ! time for logfile

integer, parameter :: ts_len = dt_len + tm_len                       ! long enough for both

character( len= ts_len) :: timestamp                                 ! timestamp pd & pm

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

!  data which are computed by make_processor_model

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

!  measured hardware values

logical :: storage_size_is_2n                                        ! true when all storage units appear to be 2^n

integer :: measured_word_size                                        ! from bit_size()

integer :: measured_char_size                                        ! from size-transfer

integer :: measured_byte_size                                        ! from size-transfer

integer, parameter :: ua_len = max( len( ba_str), len( wa_str))

character( len= ua_len) :: ua_str

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

!  describes the integer kinds found

integer :: number_of_integers = 0                                    ! from count_integer_kinds()

type( integer_kind_t), allocatable, dimension( :) :: integer_kinds   ! array of integers found

!  indexes to integer kind array

integer :: byte_idx = 1
integer :: short_idx = 2
integer :: int_idx = 3
integer :: long_idx = 4                                              ! from seek_integer_kinds()

!  describes the real kinds found

integer :: number_of_reals = 0                                       ! from count_real_kinds()

type( real_kind_t), allocatable, dimension( :) :: real_kinds         ! array of kinds found

!  indexes to real kind array

integer :: single_idx = 1
integer :: double_idx = 2
integer :: quad_idx = 3                                              ! from seek_real_kinds()

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

!  values obtained via I/O experiments

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

!  maximum record length

integer :: mrecl                                                     ! from inquire()

!  name of a file opened without a name

character( len= name_len) :: def_fn                                  ! from inquire()

!  iostat end-of-record and end-of-file codes

integer :: eor_flag, eof_flag                                        ! from read()

!  flags from leading zero experiments

logical :: lz_f_flag, lz_e_flag                                      ! from write()

!  flag from leading plus experiments

logical :: plus_flag                                                 ! from write()

!  see if list directed format uses separator ( comma or dot)

logical :: has_ld_sep                                                ! from write()

!  values of list-directed format experiments

integer :: ld_min, ld_max                                            ! from write()

!  iostat values when trying to read missing records within direct access files

integer :: da_missing, da_eof                                        ! from read()

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

!  big_endian or little_endian

logical :: measured_big_endian                                       ! true if big endian

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

!  data which must be read from the input file

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

!  logical kinds read from input file

type( logical_kind_t) :: byte_logical                                ! logical kinds
type( logical_kind_t) :: short_logical
type( logical_kind_t) :: int_logical
type( logical_kind_t) :: long_logical

logical :: define_logicals                                           ! true if defining logical kinds

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

!  character kinds read from input file

type( character_kind_t) :: ascii_character                           ! ascii characters
type( character_kind_t) :: ebcdic_character                          ! ebcdic characters
type( character_kind_t) :: iso_10646_character                       ! iso_10646 characters

logical :: define_characters                                         ! true if defining character kinds

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

!  mark type/kind not to be investigated

logical :: want_ib                                                   ! allow user to defeat any mention of integer byte
logical :: want_is                                                   ! allow user to defeat any mention of integer short
logical :: want_ii                                                   ! allow user to defeat any mention of integer int
logical :: want_il                                                   ! allow user to defeat any mention of integer long

logical :: want_rs                                                   ! allow user to defeat any mention of real single
logical :: want_rd                                                   ! allow user to defeat any mention of real double
logical :: want_rq                                                   ! allow user to defeat any mention of real quad

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

!  the namelist input file

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

!  namelists to be read from make_pm.in

!  note that the values specified here are the defaults

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

!  namelist of file names

character( len= name_len) :: pdname = 'procdep.f90'                  ! module processor_dependencies

character( len= name_len) :: pmname = 'pm.f90'                       ! program processor_model

character( len= name_len) :: incname = ''                            ! preprocessor include file ( none by default)

namelist /files/ pdname, pmname, incname                             ! file names

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

!  namelist of hardware variables

logical :: ieeefp = .true.                                           ! ieee 754 format

logical :: twoscomp = .true.                                         ! 2's complement integers

integer :: bytesize = 0                                              ! default is diagnosed byte size

integer :: wordsize = 0                                              ! if > 0, word addressable

namelist /hw/ ieeefp, twoscomp, bytesize, wordsize                   ! hardware

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

!  namelist of software variables

integer :: stdin = 5                                                 ! unit= * for input

integer :: stdout = 6                                                ! unit= * for output

integer :: stderr = -1                                               ! no preconnected error unit

character( len= 3) :: std = 'f95'                                    ! f90, f95 or f03 standard

integer, parameter :: vers_len = 80                                  ! length of version strings

character( len= vers_len) :: com_vers = ''                           ! Example: 'Acme Fortran 90 v 1.0a'
character( len= vers_len) :: com_sern = 'Compiler S/N'               ! Example: 'S/N: 007'

character( len= vers_len) :: os_vers = 'OS Version'                  ! Example: 'Ajax Z80 Unix v 19.5.e'

namelist /sw/ stdin, stdout, stderr, &                               ! preconnected units
              std, com_vers, com_sern, os_vers                       ! versions

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

!  namelist of kinds variables for kinds which can't be diagnosed

integer :: ascii = 1                                                 ! default character is ascii

integer :: ebcdic = not_supported                                    ! no ebcdic

integer :: iso_10646 = not_supported                                 ! no iso_10646

logical :: strings = .false.                                         ! true if ISO Varying String module is available

logical :: logeqint = .true.                                         ! make logicals same kinds as integers

integer :: logbyte = not_supported                                   ! off by default

integer :: logshort = not_supported                                  ! off by default

integer :: logint = not_supported                                    ! off by default

integer :: loglong = not_supported                                   ! off by default

namelist /kinds/ ascii, ebcdic, iso_10646, strings, &                ! character kinds
                 logeqint, logbyte, logshort, logint, loglong        ! logical kinds

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

!  namelist of floating point parameters ( xp= x's precision, xr= x's range, x= { single | double | quad})

logical :: autoreal = .true.                                         ! attempt automatic kind detection

integer :: sp = 6, sr = 37                                           ! an ieee 32 bit ( single)

integer :: dp = 15, dr = 307                                         ! an ieee 64 bit ( double)

integer :: qp = 33, qr = 4931                                        ! an 'ieee' 128 bit ( quad)

namelist /float/ autoreal, &                                         ! search for reals
                 sp, sr, dp, dr, qp, qr                              ! floating point parameters

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

!  namelist of integer parameters ( xd= x's digits, x= { byte | short | int | long})

logical :: autoint = .true.                                          ! attempt automatic kind detection

integer :: bd = 2, sd = 4, id = 9, ld = 18                           ! integer digits for byte, short, int, long

namelist /fixed/ autoint, &                                          ! search for integers
                 bd, sd, id, ld                                      ! integer parameters

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

!  make_processor_model local

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

!  status flag from subroutines

   integer :: istat                                                  ! ok = 0, error > 0, something < 0

!  index of change case loops

   integer :: char_ptr                                               ! loop through strings

!  count numbers of various kinds

   integer :: count_kinds                                            ! number of kinds etc detected

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

!  make_processor_model text

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

continue                                                             ! make_processor_model

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

!  open logfile or quit

   open( unit= log_unit, file= logname, status= 'REPLACE', &         ! attempt open
         action= 'WRITE', iostat= istat)

!  if can't open the logfile, complain to stdout and quit

   open_error: if( istat > 0 )then                                   ! if error with open

      write( unit= *, fmt= fmtpr) 'ERROR: ' // cant_open // logname  ! add filename to complaint

      stop error_stop_code                                           ! and quit

   endif open_error                                                  ! if error with open

!  write banner in logfile

   write( unit= log_unit, fmt= fmtpr) 'make_processor_model'         ! program name
   write( unit= log_unit, fmt= fmtpr) make_pm_rcs_id                 ! program version

!  write date/time in logfile

   call date_and_time( date= run_date, time= run_time)               ! time of this run

   timestamp = run_date // run_time                                  ! combine

   write( unit= log_unit, fmt= fmtpr) 'timestamp: ' // timestamp     ! log timestamp

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

!  try to read namelist input file

   write( unit= log_unit, fmt= fmtpr) 'reading ' // rc_name          ! log attempt

   call read_input_file( istat)                                      ! read file 'make_pm.in'

!  check results of attempt to read input

   read_input_file_status: if( istat > 0 )then                       ! if error reading make_pm.in

      write( unit= log_unit, fmt= fmtpr) 'ERROR: trouble reading ' // rc_name

      stop error_stop_code                                           ! quit

   elseif( istat < 0 )then read_input_file_status                    ! no file named 'make_pm.in'

      write( unit= log_unit, fmt= fmtpr) 'no ' // rc_name // ' found'

   else read_input_file_status                                       ! read file 'make_pm.in'

      write( unit= log_unit, fmt= fmtpr) 'read ' // rc_name // ' ok'

   endif read_input_file_status                                      ! handle return code from read_input_file()

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

!  search for only those kinds requested

   want_ib = bd > 0                                                  ! seek byte integers ?
   want_is = sd > 0                                                  ! seek short integers ?
   want_ii = id > 0                                                  ! seek int integers ?
   want_il = ld > 0                                                  ! seek long integers ?

   want_rs = sp > 0                                                  ! seek single reals ?
   want_rd = dp > 0                                                  ! seek double reals ?
   want_rq = qp > 0                                                  ! seek quad reals ?

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

!  write processor_dependencies and processor_model for f90 or f95 or f03

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

!  make character comaprisons in lower case only

   each_character_std: do char_ptr = 1, len( std)                    ! loop thru first to last

      to_lower_case_std: select case( std( char_ptr: char_ptr))      ! examine each character

      case( 'A': 'Z') to_lower_case_std                              ! upper case to lower case

         std( char_ptr: char_ptr) = achar( iachar( std( char_ptr: char_ptr)) + change_case)

      end select to_lower_case_std                                   ! ignore other characters

   enddo each_character_std                                          ! examine each character

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

!  check std is 'f90' or 'f95' or 'f03' or 'f08'

   which_standard: select case( std)                                 ! convert std to integer code

!  standard supported is Fortran 95

   case( 'f95') which_standard                                       ! write for f95

      write( unit= log_unit, fmt= fmtpr) 'processor supports Fortran 95 standard'

      standard = f95_std

!  set default compiler version string if it's null

      f95_version: if( com_vers == '' )then                          ! f95 default string

         com_vers = f95_str

      endif f95_version                                              ! f95 default string

!  standard supported is Fortran 90

   case( 'f90') which_standard                                       ! write for f90

      write( unit= log_unit, fmt= fmtpr) 'processor supports Fortran 90 standard'

      standard = f90_std                                             ! support f90 standard

!  set default compiler version string if it's null

      f90_version: if( com_vers == '' )then                          ! f90 default string

         com_vers = f90_str

      endif f90_version                                              ! f90 default string

!  standard supported is Fortran 2003

   case( 'f03') which_standard                                       ! write for f03

      write( unit= log_unit, fmt= fmtpr) 'processor supports Fortran 2003 standard'

      standard = f03_std                                             ! support f03 standard

!  set default compiler version string if it's null

      f03_version: if( com_vers == '' )then                          ! f03 default string

         com_vers = f03_str

      endif f03_version                                              ! f03 default string

!  standard supported is Fortran 2003

   case( 'f08') which_standard                                       ! write for f03

      write( unit= log_unit, fmt= fmtpr) 'processor supports Fortran 2008 standard'

      standard = f08_std                                             ! support f08 standard

!  set default compiler version string if it's null

      f08_version: if( com_vers == '' )then                          ! f08 default string

         com_vers = f08_str

      endif f08_version                                              ! f08 default string

!  no earlier standard is supported ( must have modules)

   case default which_standard                                       ! must be f90 or f95 or f03

      write( unit= log_unit, fmt= fmtpr) 'ERROR: std = ' &
             // trim( std) // ': std must = f90, f95, f03 or f08'    ! must have modules!

      stop error_stop_code                                           ! quit

   end select which_standard                                         ! check f90 or f95 or f03

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

!  write preprocessor include file for coco or f90ppr or fpp or none

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

!  make character comaprisons in lower case only

   each_character_inc: do char_ptr = 1, len( incname)                ! loop thru first to last

      to_lower_case: select case( incname( char_ptr: char_ptr))      ! examine each character

      case( 'A': 'Z') to_lower_case                                  ! upper case to lower case

         incname( char_ptr: char_ptr) = achar( iachar( incname( char_ptr: char_ptr)) + change_case)

      end select to_lower_case                                       ! ignore other characters

   enddo each_character_inc                                          ! examine each character

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

!  check preprocessor is coco or f90ppr or fpp

   select_preprocessor: select case( incname)                        ! which preprocessor

!  preprocessor is coco ( Part 3 of the Standard)

   case( coco_name) select_preprocessor                              ! write for coco

      write( unit= log_unit, fmt= fmtpr) 'include file for coco'

      ppr_inc = coco_inc

!  preprocessor is f90ppr ( Moware)

   case( f90ppr_name) select_preprocessor                            ! write for f90ppr

      write( unit= log_unit, fmt= fmtpr) 'include file for f90ppr'

      ppr_inc = f90ppr_inc                                           ! f90ppr preprocessor

!  preprocessor is fpp/cpp or ...

   case( fpp_name) select_preprocessor                               ! write for fpp/cpp

      write( unit= log_unit, fmt= fmtpr) 'include file for fpp/cpp'

      ppr_inc = fpp_inc                                              ! fpp/cpp preprocessor

!  only formats supported

   case default select_preprocessor                                  ! must be coco or f90ppr or fpp

!  so other names are errors

      null_string_ok: if( len_trim( incname) > 0 )then               ! null string means no preprocessor file

         write( unit= log_unit, fmt= fmtpr) 'ERROR: incname = ' &
                // trim( incname) // ': incname must = coco.inc, f90ppr.inc or fpp.inc'

         stop error_stop_code                                        ! quit

!  no name is the default

      else null_string_ok                                            ! null string means no preprocessor file

         write( unit= log_unit, fmt= fmtpr) 'no preprocessor include file'

      endif null_string_ok                                           ! null string means no preprocessor file

   end select select_preprocessor                                    ! which preprocessor

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

!  log iso_varying_strings

   has_varying_strings: if( strings )then                            ! report strings

      write( unit= log_unit, fmt= fmtpr) 'processor supports iso_varying_strings'

   else has_varying_strings                                          ! report strings

      write( unit= log_unit, fmt= fmtpr) 'processor does not support iso_varying_strings'

   endif has_varying_strings                                         ! report strings

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

!  check hardware parameters before doing anything else

   call check_hardware_values                                        ! check user input

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

!  get kinds via selected_<what>_kind() or make_pm.in

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

!  determine integer kinds ---------------------------------------------

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

!  seek integer kinds if requested

   detect_ints: if( autoint )then                                    ! want automatic search

      call count_integer_kinds                                       ! find out how many integer kinds

   endif detect_ints                                                 ! want automatic search

   number_of_integers = max( number_of_integers, default_number_of_integers)

   allocate( integer_kinds( number_of_integers), stat= istat)        ! array of integer kinds

   int_alloc_error: if( istat > 0 )then

      write( unit=log_unit, fmt= fmtpr) 'ERROR: trouble allocating integer kind array'

      stop error_stop_code                                           ! quit
         
   endif int_alloc_error

!  name string, kind value, number of digits, bit size, is supported, is the default kind

   integer_kinds( byte_idx) = integer_kind_t( 'byte', 0, bd, 0, .false., .false.)
   integer_kinds( short_idx) = integer_kind_t( 'short', 0, sd, 0, .false., .false.)
   integer_kinds( int_idx) = integer_kind_t( 'int', 0, id, 0, .false., .false.)
   integer_kinds( long_idx) = integer_kind_t( 'long', 0, ld, 0, .false., .false.)

!  automatically find integer kinds

   find_ints: if( autoint )then                                      ! want automatic search

      call seek_integer_kinds                                        ! values of array of integer kinds

   endif find_ints                                                   ! want automatic search

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

!  detect integer kinds

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

!  processor kind values

   integer_kinds( byte_idx)% kind_value = selected_int_kind( bd)     ! byte kind
   integer_kinds( short_idx)% kind_value = selected_int_kind( sd)    ! short kind
   integer_kinds( int_idx)% kind_value = selected_int_kind( id)      ! int kind
   integer_kinds( long_idx)% kind_value = selected_int_kind( ld)     ! long kind

!  byte is supported if it exists and is not the same as short and the user wants it

   integer_kinds( byte_idx)% supported = ( integer_kinds( byte_idx)% kind_value > 0) &
      .and. ( integer_kinds( byte_idx)% kind_value /= integer_kinds( short_idx)% kind_value) &
      .and. want_ib

!  short is supported if it exists and is not the same as int and the user wants it

   integer_kinds( short_idx)% supported = ( integer_kinds( short_idx)% kind_value > 0) &
      .and. ( integer_kinds( short_idx)% kind_value /= integer_kinds( int_idx)% kind_value) &
      .and. want_is

!  int is supported if it exists and is not the same as long and the user wants it

   integer_kinds( int_idx)% supported = ( integer_kinds( int_idx)% kind_value > 0) &
      .and. ( integer_kinds( int_idx)% kind_value /= integer_kinds( long_idx)% kind_value) &
      .and. want_ii

!  long is supported if it exists and the user wants it

   integer_kinds( long_idx)% supported = ( integer_kinds( long_idx)% kind_value > 0) &
      .and. want_il

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

!  write integer kinds in logfile

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'assigned integer kinds:'

!  processor has bytes   

   has_byte: if( integer_kinds( byte_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' byte'

   endif has_byte
   
!  processor has shorts

   has_short: if( integer_kinds( short_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' short'

   endif has_short

!  processor has ints

   has_int: if( integer_kinds( int_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' int'

   endif has_int

!  processor has longs

   has_long: if( integer_kinds( long_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' long'

   endif has_long

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  complain if there isn't at least one integer kind detected

   count_kinds = count( integer_kinds% supported)                    ! count supported integer kinds

   count_integers: if( count_kinds < 1 )then                         ! report bad count

      write( unit= log_unit, fmt= fmtpr) 'WARNING: no integer kinds detected'

   endif count_integers                                              ! report bad count

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

!  detect default integer kind

   integer_kinds( byte_idx)% default_kind = integer_kinds( byte_idx)% supported &
      .and. integer_kinds( byte_idx)% kind_value == kind( 0)         ! default is byte

   integer_kinds( short_idx)% default_kind = integer_kinds( short_idx)% supported &
      .and. integer_kinds( short_idx)% kind_value == kind( 0)        ! default is short

   integer_kinds( int_idx)% default_kind = integer_kinds( int_idx)% supported &
      .and. integer_kinds( int_idx)% kind_value == kind( 0)          ! default is int

   integer_kinds( long_idx)% default_kind = integer_kinds( long_idx)% supported &
      .and. integer_kinds( long_idx)% kind_value == kind( 0)         ! default is long

!  report default integer kind

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'default integer kind:'

!  default is byte

   def_integer: if( integer_kinds( byte_idx)% default_kind )then     ! default integer

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' byte'

!  default is short

   elseif( integer_kinds( short_idx)% default_kind )then def_integer ! default integer

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' short'

!  default is int

   elseif( integer_kinds( int_idx)% default_kind )then def_integer   ! default integer

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' int'

!  default is long

   elseif( integer_kinds( long_idx)% default_kind )then def_integer  ! default integer

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' long'

!  default is not found

   else def_integer                                                  ! no default integer

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' WARNING: default integer not detected!'

   endif def_integer                                                 ! default integer

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  complain if there isn't exactly one default integer kind detected

   count_kinds = count( integer_kinds% default_kind)                 ! count default integer kinds

   count_def_integers: if( count_kinds < 1 )then                     ! complain if too few

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default integer kind not detected!'

   elseif( count_kinds > 1 )then count_def_integers                  ! complain if too few

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default integer kind not unique!'

   endif count_def_integers                                          ! possible complaints

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

!  determine real kinds ------------------------------------------------

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

!  seek real kinds if requested

   detect_reals: if( autoreal )then                                  ! want automatic search

      call count_real_kinds                                          ! find out how many real kinds

   endif detect_reals                                                ! want automatic search

   number_of_reals = max( default_number_of_reals, number_of_reals)

   allocate( real_kinds( number_of_reals), stat= istat)

   real_alloc_error: if( istat > 0 )then

      write( unit=log_unit, fmt= fmtpr) 'ERROR: trouble allocating real kind array'

      stop error_stop_code                                           ! quit
         
   endif real_alloc_error

!  name string, kind value, precision, range, bit size, is supported, is the default kind, is the default double

   real_kinds( single_idx) = &
      real_kind_t( 'single', 0, sp, sr, 0, .false., .false., .false.)
   real_kinds( double_idx) = &
      real_kind_t( 'double', 0, dp, dr, 0, .false., .false., .false.)
   real_kinds( quad_idx) = &
      real_kind_t( 'quad', 0, qp, qr, 0, .false., .false., .false.)

!  automatically find real kinds

   find_reals: if( autoreal )then                                    ! want automatic search

      call seek_real_kinds                                           ! try to detect real kinds

   endif find_reals                                                  ! want automatic search

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

!  detect real kinds

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

!  get kind values

   real_kinds( single_idx)% kind_value = selected_real_kind( sp, sr) ! single kind
   real_kinds( double_idx)% kind_value = selected_real_kind( dp, dr) ! double kind
   real_kinds( quad_idx)% kind_value = selected_real_kind( qp, qr)   ! quad kind

!  single is supported if it exists and is no the same as double and the user wants it

   real_kinds( single_idx)% supported = ( real_kinds( single_idx)% kind_value > 0) &
      .and. ( real_kinds( single_idx)% kind_value /= real_kinds( double_idx)% kind_value) &
      .and. want_rs

!  double is supported if it exists and is no the same as quad and the user wants it

   real_kinds( double_idx)% supported = ( real_kinds( double_idx)% kind_value > 0) &
      .and. ( real_kinds( double_idx)% kind_value /= real_kinds( quad_idx)% kind_value) &
      .and. want_rd

!  quad is supported if it exists and the user wants it

   real_kinds( quad_idx)% supported = real_kinds( quad_idx)% kind_value > 0 &
      .and. want_rq

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

!  log real kinds

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'assigned real kinds:'

   has_single: if( real_kinds( single_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' single'

   endif has_single

   has_double: if( real_kinds( double_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' double'

   endif has_double

   has_quad: if( real_kinds( quad_idx)% supported )then

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' quad'

   endif has_quad

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  detect default real kind

   real_kinds( single_idx)% default_kind = real_kinds( single_idx)% supported &
      .and. real_kinds( single_idx)% kind_value == kind( 0.0)        ! default is single

   real_kinds( double_idx)% default_kind = real_kinds( double_idx)% supported &
      .and. real_kinds( double_idx)% kind_value == kind( 0.0)        ! default is double

   real_kinds( quad_idx)% default_kind = real_kinds( quad_idx)% supported &
      .and. real_kinds( quad_idx)% kind_value == kind( 0.0)          ! default is quad

!  report default real kind

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'default real kind:'

   def_real: if( real_kinds( single_idx)% default_kind )then         ! default real

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' single'

   elseif( real_kinds( double_idx)% default_kind )then def_real      ! default real

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' double'

   elseif( real_kinds( quad_idx)% default_kind )then def_real        ! default real

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' quad'

   else def_real                                                     ! no default real

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' WARNING: default real not detected!'

   endif def_real                                                    ! default real

   write( unit= log_unit, fmt= *)                                    ! end of record

!  single is the default double precision kind if it exists and has the kind of 0.0d0

   real_kinds( single_idx)% default_dp_kind = real_kinds( single_idx)% supported &
      .and. real_kinds( single_idx)% kind_value == kind( 0.0d0)      ! double precision is single

!  double is the default double precision kind if it exists and has the kind of 0.0d0

   real_kinds( double_idx)% default_dp_kind = real_kinds( double_idx)% supported &
      .and. real_kinds( double_idx)% kind_value == kind( 0.0d0)      ! double precision is double

!  quad is the default double precision kind if it exists and has the kind of 0.0d0

   real_kinds( quad_idx)% default_dp_kind = real_kinds( quad_idx)% supported &
      .and. real_kinds( quad_idx)% kind_value == kind( 0.0d0)        ! double precision is quad

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

!  report the double precision kind

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'double precision kind:'

   def_dp: if( real_kinds( single_idx)% default_dp_kind )then        ! double precision

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' single'

   elseif( real_kinds( double_idx)% default_dp_kind )then def_dp     ! double precision

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' double'

   elseif( real_kinds( quad_idx)% default_dp_kind )then def_dp       ! double precision

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' quad'

   else def_dp                                                       ! no double precision

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' WARNING: double precision not detected!'

   endif def_dp                                                      ! double precision

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  complain if there aren't at least two real kinds detected

   count_reals: if( count( real_kinds% supported) < 2 )then          ! count supported real kinds

      write( unit= log_unit, fmt= fmtpr) 'WARNING: fewer than 2 real kinds detected'

   endif count_reals                                                 ! count supported real kinds

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

!  complain if there aren't exactly two default real kinds detected

   count_kinds = count( real_kinds% default_kind)                    ! count supported default real kinds

   count_def_reals: if( count_kinds < 1 )then                        ! complain if too few

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default real kind not detected'

   elseif( count_kinds > 1 )then count_def_reals                     ! complain if too many

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default real kind not unique'

   endif count_def_reals                                             ! possible complaints

   count_kinds = count( real_kinds% default_dp_kind)                 ! count supported default real kinds

   count_def_dp_reals: if( count_kinds < 1 )then                     ! complain if too few

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default double kind not detected'

   elseif( count_kinds > 1 )then count_def_dp_reals                  ! complain if too many

      write( unit= log_unit, fmt= fmtpr) 'WARNING: default double kind not unique'

   endif count_def_dp_reals                                          ! possible complaints

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

!  check correspondence between default real and double precision kinds

   s_dp_real: if( kind( 0.0) == kind( 0.0d0) )then                   ! single real <-> dp real

      write( unit= log_unit, fmt= fmtpr) 'default real kind same value as double precision real kind'

   endif s_dp_real                                                   ! single real <-> dp real

!  try to guess correspondence between real and integer kinds

   int_real: if( kind( 0) == kind( 0.0) )then                        ! default integer <-> default real

      write( unit= log_unit, fmt= fmtpr) 'default integer kind same value as default real kind'

   elseif( kind( 0) == kind( 0.0d0) )then int_real                   ! default integer <-> default dp

      write( unit= log_unit, fmt= fmtpr) 'default integer kind same value as double precision kind'

   else int_real

      write( unit= log_unit, fmt= fmtpr) 'NOTE: integer kind <-> real kind correspondence not detected!'

   endif int_real                                                    ! default integer <-> default real

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

!  process character kinds from input valiables

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

!  name string, kind value, is supported, is the default, string passed to selected_char_kind()

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

!  ascii characters

   ascii_character = character_kind_t( 'ascii', max( ascii, not_supported), ascii > 0, .false., 'ASCII')

!  ebcdic characters

   ebcdic_character = character_kind_t( 'ebcdic', max( ebcdic, not_supported), ebcdic > 0, .false., 'EBCDIC')

!  iso_10646 characters

   iso_10646_character = character_kind_t( 'iso_10646', max( iso_10646, not_supported), iso_10646 > 0, .false., &
                                           'ISO_10646')

!  found any character kinds

   define_characters = ascii_character% supported .or. ebcdic_character% supported &
                     .or. iso_10646_character% supported

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

!  log character kinds

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'defined character kinds:'

   want_char: if( define_characters )then                            ! if characters defined

      define_ascii: if( ascii_character% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' ascii'

      endif define_ascii

      define_ebcdic: if( ebcdic_character% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' ebcdic'

      endif define_ebcdic

      define_iso_10646: if( iso_10646_character% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' iso_10646'

      endif define_iso_10646

   else want_char                                                    ! if characters defined

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' none'

   endif want_char                                                   ! if characters defined

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  default character kind

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'default character kind:'

   default_char: if( define_characters )then                         ! default character

      ascii_character% default_kind = ascii_character% supported .and. ascii_character% kind_value == kind( ' ')
      ebcdic_character% default_kind = ebcdic_character% supported &
                                  .and. ebcdic_character% kind_value == kind( ' ')
      iso_10646_character% default_kind = iso_10646_character% supported &
                                    .and. iso_10646_character% kind_value == kind ( ' ')

      default_ascii: if( ascii_character% default_kind )then         ! default is ascii

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' ascii'

      endif default_ascii                                            ! default is ascii

      default_ebcdic: if( ebcdic_character% default_kind )then       ! default is ebcdic

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' ebcdic'

      endif default_ebcdic                                           ! default is ebcdic

      default_iso_10646: if( iso_10646_character% default_kind )then ! default is iso 10646

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' iso_10646'

      endif default_iso_10646                                        ! default is iso 10646

   else default_char                                                 ! default character

      write( unit= log_unit, fmt= fmti, advance= 'NO') kind( ' ')    ! no name so print value

   endif default_char                                                ! default character

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  character kinds sanity check

   define_char: if( define_characters )then                          ! if defined character kinds

      call check_character_kinds                                     ! check user input

   endif define_char                                                 ! if defined character kinds

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

!  process logical kinds from input variables

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

!  name string, kind value, is supported, is the default

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

!  if logical kinds correspond to integer kinds

   log_eq_int: if( logeqint )then                                    ! make logicals same as integers

!  byte kind

      same_byte: if( integer_kinds( byte_idx)% supported )then

         byte_logical = logical_kind_t( 'l_byte', integer_kinds( byte_idx)% kind_value, .true., .false.)

      else same_byte

         byte_logical = logical_kind_t( '', not_supported, .false., .false.)

      endif same_byte

!  short kind

      same_short: if( integer_kinds( short_idx)% supported )then

         short_logical = logical_kind_t( 'l_short', integer_kinds( short_idx)% kind_value, .true., .false.)

      else same_short

         short_logical = logical_kind_t( '', not_supported, .false., .false.)

      endif same_short

!  int kind

      same_int: if( integer_kinds( int_idx)% supported )then

         int_logical = logical_kind_t( 'l_int', integer_kinds( int_idx)% kind_value, .true., .false.)

      else same_int

         int_logical = logical_kind_t( '', not_supported, .false., .false.)

      endif same_int

!  long kind

      same_long: if( integer_kinds( long_idx)% supported )then

         long_logical = logical_kind_t( 'l_long', integer_kinds( long_idx)% kind_value, .true., .false.)

      else same_long

         long_logical = logical_kind_t( '', not_supported, .false., .false.)

      endif same_long

!  logical kinds specified individually

   else log_eq_int

!  byte kind

      want_bl: if( logbyte > 0 )then

         byte_logical = logical_kind_t( 'l_byte', max( logbyte, not_supported), .true., .false.)

      else want_bl

         byte_logical = logical_kind_t( '', max( logbyte, not_supported), .false., .false.)

      endif want_bl

!  short kind

      want_sl: if( logshort > 0 )then

         short_logical = logical_kind_t( 'l_short', max( logshort, not_supported), .true., .false.)

      else want_sl

         short_logical = logical_kind_t( '', max( logshort, not_supported), .false., .false.)

      endif want_sl

!  int kind

      want_intl: if( logint > 0 )then

         int_logical = logical_kind_t( 'l_int', max( logint, not_supported), .true., .false.)

      else want_intl

         int_logical = logical_kind_t( '', max( logint, not_supported), .false., .false.)

      endif want_intl

 !  long kind

      want_ll: if( loglong > 0 )then

         long_logical = logical_kind_t( 'l_long', max( loglong, not_supported), .true., .false.)

      else want_ll

         long_logical = logical_kind_t( '', max( loglong, not_supported), .false., .false.)

      endif want_ll

   endif log_eq_int                                                  ! make logicals same as integers

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

!  ensure unique logical kind values

   byte_logical% supported = byte_logical% kind_value > 0 &
      .and. byte_logical% kind_value /= short_logical% kind_value

   short_logical% supported = short_logical% kind_value > 0 &
      .and. short_logical% kind_value /= int_logical% kind_value

   int_logical% supported = int_logical% kind_value > 0 &
      .and. int_logical% kind_value /= long_logical% kind_value

   long_logical% supported = long_logical% kind_value > 0

!  found any logical kinds

   define_logicals = byte_logical% supported .or. short_logical% supported &
                     .or. int_logical% supported .or. long_logical% supported

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

!  log logical kinds

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'defined logical kinds:'

   report_logicals: if( define_logicals )then                        ! if logicals defined

      report_logical_byte: if( byte_logical% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' byte'

      endif report_logical_byte

      report_logical_short: if( short_logical% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' short'

      endif report_logical_short

      report_logical_int: if( int_logical% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' int'

      endif report_logical_int

      report_logical_long: if( long_logical% supported )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' long'

      endif report_logical_long

   else report_logicals                                              ! if logicals defined

      write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' none'

   endif report_logicals                                             ! if logicals defined

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  default logical kind

   byte_logical% default_kind = byte_logical% supported &
      .and. byte_logical% kind_value == kind( .true.)                ! default logical is byte

   short_logical% default_kind = short_logical% supported &
      .and. short_logical% kind_value == kind( .true.)               ! default logical is short

   int_logical% default_kind = int_logical% supported &
      .and. int_logical% kind_value == kind( .true.)                 ! default logical is int

   long_logical% default_kind = long_logical% supported &
      .and. long_logical% kind_value == kind( .true.)                ! default logical is long

   write( unit= log_unit, fmt= fmtpr, advance= 'NO') 'default logical kind:'

   report_default_logical: if( define_logicals )then                 ! if logicals defined

      report_default_logical_byte: if( byte_logical% default_kind )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' byte'

      endif report_default_logical_byte

      report_default_logical_short: if( short_logical% default_kind )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' short'

      endif report_default_logical_short

      report_default_logical_int: if( int_logical% default_kind )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' int'

      endif report_default_logical_int

      report_default_logical_long: if( long_logical% default_kind )then

         write( unit= log_unit, fmt= fmtpr, advance= 'NO') ' long'

      endif report_default_logical_long

   else report_default_logical                                       ! if logicals defined

      write( unit= log_unit, fmt= fmti, advance= 'NO') kind( .true.) ! no name so print value

   endif report_default_logical                                      ! if logicals defined

   write( unit= log_unit, fmt= *)                                    ! end of record

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

!  sanity check and promotion of logical kinds

   check_logicals: if( define_logicals )then                         ! defined logical kinds

      call check_logical_kinds                                       ! check user input

   endif check_logicals                                              ! defined logical kinds

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

!  try to diagnose (some) i/o parameters

   call diagnose_input_output                                        ! basic io tests

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

!  write the defines include file

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

!  write which kinds are defined to preprocessor include file

   got_incfile: select case( ppr_inc)                                ! inc file was named

!  no include file was requested

   case( no_inc) got_incfile                                         ! inc file was named

      write( unit= log_unit, fmt= fmtpr) 'no preprocessor include file written'

!  an include file was requested

   case default got_incfile                                          ! inc file was named

      write( unit= log_unit, fmt= fmtpr) 'writing ' // trim( incname)

      call write_include_file( istat)                                ! write module processor_dependencies

      write_include_file_error: if( istat > 0 )then                  ! if error writing stdtype.f90

         write( unit= log_unit, fmt= fmtpr) 'ERROR: trouble writing ' // trim( incname)

         stop error_stop_code                                        ! quit

      else write_include_file_error                                  ! trouble closing

         write( unit= log_unit, fmt= fmtpr) 'wrote ' // trim( incname) // ' ok'

      endif write_include_file_error                                 ! if error writing stdtype.f90

   end select got_incfile                                            ! inc file was named

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

!  write the Fortran source for processor_dependencies and processor_model

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

!  write procdep.f90

   write( unit= log_unit, fmt= fmtpr) 'writing ' // trim( pdname)    ! log attempt

   call write_processor_dependencies( istat)                         ! write module processor_dependencies

!  verify status

   write_processor_depend_error: if( istat > 0 )then                 ! if error writing procdep.f90

      write( unit= log_unit, fmt= fmtpr) 'ERROR: trouble writing ' // trim( pdname)

      stop error_stop_code                                           ! quit

   else write_processor_depend_error                                 ! if error writing procdep.f90

      write( unit= log_unit, fmt= fmtpr) 'wrote ' // trim( pdname) // ' ok'

   endif write_processor_depend_error                                ! if error writing procdep.f90

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

!  write pm.f90

   write( unit= log_unit, fmt= fmtpr) 'writing ' // trim( pmname)    ! log attempt

   call write_processor_model( istat)                                ! write program processor_model

!  verify status

   write_processor_model_error: if( istat > 0 )then                  ! if error writing pm.f90

      write( unit= log_unit, fmt= fmtpr) 'ERROR: trouble writing ' // trim( pmname)

      stop error_stop_code                                           ! quit

   else write_processor_model_error                                  ! if error writing pm.f90

      write( unit= log_unit, fmt= fmtpr) 'wrote ' // trim( pmname) // ' ok'

   endif write_processor_model_error                                 ! if error writing pm.f90

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

!  write date/time in logfile

   call date_and_time( date= run_date, time= run_time)               ! time of this run

   timestamp = run_date // run_time                                  ! combine

   write( unit= log_unit, fmt= fmtpr) 'timestamp: ' // timestamp     ! log timestamp

!  close logfile

   close( unit= log_unit, status= 'KEEP')                            ! keep logfile

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

!  make_processor_model

stop normal_stop_code                                                ! make_processor_model

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

!  make_processor_model library

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

contains                                                             ! make_processor_model

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

!  read_input_file() reads the user provided configuration file, if accessible

subroutine read_input_file( istat)

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

!  read_input_file() interface

integer, intent( out) :: istat                                       ! status

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

!  read_input_file() local

   logical :: have_rc                                                ! true if make_pm.in file exists

   logical :: found                                                  ! found a namelist group

   character( len= *), parameter :: error_msg = 'ERROR: trouble reading namelist group '

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

!  read_input_file() text

continue                                                             ! read_input_file()

!  detect file make_pm.in

   inquire( file= rc_name, exist= have_rc)                           ! does rc_name exist?

!  if file make_pm.in exists

   rc_exists: if( have_rc )then                                      ! make_pm.in exists

! open file make_pm.in to read from the beginning

      open( unit= nml_unit, file= rc_name, iostat= istat, position= 'REWIND', &
            action= 'READ', status= 'OLD')

      open_error: if( istat > 0 )then                                ! can't open make_pm.in

         write( unit= log_unit, fmt= fmtpr) cant_open // rc_name     ! complain

         return                                                      ! read_input_file()

      endif open_error                                               ! can't open make_pm.in

   else rc_exists                                                    ! make_pm.in exists

!  no make_pm.in file was found

      istat = -1                                                     ! ok, use defaults

      return                                                         ! read_input_file()

   endif rc_exists                                                   ! make_pm.in exists

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

!  read namelist group 'files'

   call seek_namelist_group( 'files', found, istat)

   found_files: if( found )then

      read( unit= nml_unit, nml= files, iostat= istat)               ! filenames

   endif found_files

   files_error: if( istat > 0 )then                                  ! can't read files

      write( unit= log_unit, fmt= fmtpr) error_msg // '"files"'      ! complain

      return                                                         ! read_input_file()

   endif files_error                                                 ! can't read files

   write( unit= log_unit, nml= files)                                ! echo to logfile

   rewind( unit= nml_unit)                                           ! read namelist groups in any order

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

!  read namelist group 'hw'

   call seek_namelist_group( 'hw', found, istat)

   found_hw: if( found )then

      read( unit= nml_unit, nml= hw, iostat= istat)                  ! hardware

   endif found_hw

   hw_error: if( istat > 0 )then                                     ! can't read hw

      write( unit= log_unit, fmt= fmtpr) error_msg // '"hw"'         ! complain

      return                                                         ! read_input_file()

   endif hw_error                                                    ! can't read hw

   write( unit= log_unit, nml= hw)                                   ! echo to logfile

   rewind( unit= nml_unit)                                           ! read namelist groups in any order

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

!  read namelist group 'sw'

   call seek_namelist_group( 'sw', found, istat)

   found_sw: if( found )then

      read( unit= nml_unit, nml= sw, iostat= istat)                  ! basic software

   endif found_sw

   sw_error: if( istat > 0 )then                                     ! can't read sw

      write( unit= log_unit, fmt= fmtpr) error_msg // '"sw"'         ! complain

      return                                                         ! read_input_file()

   endif sw_error                                                    ! can't read sw

   write( unit= log_unit, nml= sw)                                   ! echo to logfile

   rewind( unit= nml_unit)                                           ! read namelist groups in any order

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

!  read namelist group 'kinds'

   call seek_namelist_group( 'kinds', found, istat)

   found_kinds: if( found )then

      read( unit= nml_unit, nml= kinds, iostat= istat)               ! non-numeric kinds

   endif found_kinds

   kinds_error: if( istat > 0 )then                                  ! can't read kinds

      write( unit= log_unit, fmt= fmtpr) error_msg // '"kinds"'      ! complain

      return                                                         ! read_input_file()

   endif kinds_error                                                 ! can't read kinds

   write( unit= log_unit, nml= kinds)                                ! echo to logfile

   rewind( unit= nml_unit)                                           ! read namelist groups in any order

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

!  read namelist group 'float'

   call seek_namelist_group( 'float', found, istat)

   found_float: if( found )then

      read( unit= nml_unit, nml= float, iostat= istat)               ! real, complex kinds

   endif found_float

   float_error: if( istat > 0 )then                                  ! can't read float

      write( unit= log_unit, fmt= fmtpr) error_msg // '"float"'      ! complain

      return                                                         ! read_input_file()

   endif float_error                                                 ! can't read float

   write( unit= log_unit, nml= float)                                ! echo to logfile

   rewind( unit= nml_unit)                                           ! read namelist groups in any order

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

!  read namelist group 'fixed'

   call seek_namelist_group( 'fixed', found, istat)

   found_fixed: if( found )then

      read( unit= nml_unit, nml= fixed, iostat= istat)               ! integer kinds

   endif found_fixed

   fixed_error: if( istat > 0 )then                                  ! can't read fixed

      write( unit= log_unit, fmt= fmtpr) error_msg // '"fixed"'      ! complain

      return                                                         ! read_input_file()

   endif fixed_error                                                 ! can't read fixed

   write( unit= log_unit, nml= fixed)                                ! echo to logfile

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

!  close file make_pm.in

   close( unit= nml_unit, iostat= istat, status= 'KEEP')             ! (tried to) read all groups

   close_error: if( istat > 0 )then                                  ! trouble closing

      write( unit= log_unit, fmt= fmtpr) 'trouble closing ' // rc_name

   endif close_error                                                 ! trouble closing

return                                                               ! read_input_file()

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

!  read_input_file()

end subroutine read_input_file

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

!  seek_namelist_group() reads the user provided configuration file, if accessible

subroutine seek_namelist_group( group_name, found, istat)

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

!  seek_namelist_group() interface

character( len= *), intent( in) :: group_name                        ! name of namelist to seek

logical, intent( out) :: found                                       ! true if found otherwise false

integer, intent( out) :: istat                                       ! status

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

!  seek_namelist_group() constants

   character( len= *), parameter :: error_msg = 'error seeking namelist group '

   character( len= *), parameter :: afmt = '(a)'                     ! read format

!  introduce namelist group name

   character( len= *), parameter :: signal = '&'                     ! start of namelist group name

!  ignore blanks

   character( len= *), parameter :: blank = ' '                      ! may appear before &

!  namelist separators

   character( len= *), parameter :: separators = ' ,!/'              ! may appear after a group name

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

!  seek_namelist_group() local

   character( len= 1024) :: input_buffer                             ! read with a format

   character( len= 32) :: lower_case_name                            ! lower case namelist group name

   integer :: name_len                                               ! length of group name

   integer :: input_name_len                                         ! length of name in input

   integer :: name_ptr                                               ! point to characters in name

   integer :: signal_ptr                                             ! point to signal in input buffer

   integer :: input_name_loc                                         ! first character in input buffer name

   integer :: input_name_ptr                                         ! point to characters in input buffer name

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

!  seek_namelist_group() text

continue                                                             ! seek_namelist_group()

!  get name length & convert name to lc

   name_len = len_trim( group_name)                                  ! length of name

   lower_case_name = blank                                           ! set to blanks

!  loop through each character in name

   name_to_lower_case: do name_ptr = 1, name_len                     ! each character in name

!  examine each character in name

      each_character: select case( group_name( name_ptr: name_ptr))  ! examine

!  if upper case letter

      case( 'A': 'Z') each_character                                 ! find upper case

!  convert upper case letter to lower case letter

         lower_case_name( name_ptr: name_ptr) = achar( iachar( group_name( name_ptr: name_ptr)) + change_case)

!  otherwise

      case default each_character                                    ! find something else

!  copy character

         lower_case_name( name_ptr: name_ptr) = group_name( name_ptr: name_ptr)

      end select each_character                                      ! examine

   enddo name_to_lower_case                                          ! each character in name

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

!  initialize read records loop

   istat = 0                                                         ! no errors nor end

   found = .false.                                                   ! not found yet

!  read until end of file or nemalist group is found

   seek_name: do while( istat == 0 )                                 ! read til found or eof

!  read a record as a character string

      read( unit= nml_unit, fmt = afmt, iostat= istat) input_buffer  ! read record as characters

!  case of istat

      read_status: select case( istat)                               ! check io status

!  encountered an end

      case( : -1) read_status                                        ! must be eof

!  end of file

         istat = 0                                                   ! eof without finding group name

         exit seek_name                                              ! quit

!  read error

      case( 1: ) read_status                                         ! read error

!  complain & quit

         write( unit= log_unit, fmt= fmtpr) error_msg // group_name  ! add name to complaint

         exit seek_name                                              ! quit

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

!  got record to decode

      case default read_status                                       ! read a string

!  seek signal of namelist group name

         signal_ptr = verify( input_buffer, blank)                   ! find first non blank

!  if one is found

         first_non_blank: if( signal_ptr > 0 )then                   ! point to first non blank

!  if possible group name

            found_signal: if( input_buffer( signal_ptr: signal_ptr) ==  signal )then

!  name starts at next character after signal

               input_name_loc = signal_ptr + 1                       ! first character of name

!  find separator in input buffer

               input_name_len = scan( input_buffer( input_name_loc: ), separators) + signal_ptr

!  convert any upper case letter to lower case to match name

               input_name_to_lower_case: do input_name_ptr = input_name_loc, input_name_len

!  examine each character

                  input_each_character: select case( input_buffer( input_name_ptr: input_name_ptr))

!  upper case letter

                  case( 'A': 'Z') input_each_character               ! upper case to lower case

!  convert to lower case letter

                     input_buffer( input_name_ptr: input_name_ptr) = &
                        achar( iachar( input_buffer( input_name_ptr: input_name_ptr)) + change_case)

                  end select input_each_character                    ! upper case to lower case

               enddo input_name_to_lower_case                        ! do each character

!  look for a name match

               name_eq: if( input_buffer( input_name_loc: input_name_len) == lower_case_name )then

!  found name following signal

                  found = .true.                                     ! eureka

!  if match, backspace so caller can reread record

                  backspace( unit= nml_unit, iostat= istat)          ! put it back

!  check for backspace error

                  back_error: if( istat > 0 )then                    ! if error

                     write( unit= log_unit, fmt= *) error_msg // group_name

                  endif back_error                                   ! if error

!  exit from read loop

                  exit seek_name                                     ! quit successfully

!  name match

               endif name_eq                                         ! name found in input_buffer

!  found signal

            endif found_signal                                       ! & found in input_buffer

!  nonblank record

         endif first_non_blank                                       ! skip blanks in input_buffer

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

!  read iostat case

      end select read_status                                         ! read not error nor end

!  read to eof

   enddo seek_name                                                   ! read til found or eof

!  return

return                                                               ! seek_namelist_group()

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

!  seek_namelist_group()

end subroutine seek_namelist_group

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

!  count_integer_kinds() counts integer kinds

subroutine count_integer_kinds

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

!  This subroutine counts the number of integer kinds this processor supports.

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

!  count_integer_kinds() local

   integer :: count_kinds                                            ! count the number of integer kinds

   integer :: this_kind                                              ! find kinds

   integer :: previous_kind                                          ! the previous kind found

   integer :: this_digits                                            ! loop through digits

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

!  count_integer_kinds()

continue                                                             ! count_integer_kinds()

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

!  The search assumes the following:

!  There must be at least one kind of integer.
!  One kind of integer will support at least one digit.
!  All integer kinds can be found by searching through increasing numbers of digits supported.
!  A negative kind value will be returned only when all kinds have been found.

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

!  initialize search for integer kinds

   count_kinds = 1                                                   ! number of kinds found so far

   this_digits = 1                                                   ! digits tested by selected_int_kind()

   previous_kind = selected_int_kind( this_digits)                   ! must support one integer kind

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

!  do until all kinds are found

   find_all_kinds: do                                                ! loop over digits

      this_kind = selected_int_kind( this_digits)                    ! kind with this digits

!  branch: or all kinds found --> quit, found new kind --> count

      new_or_same_kind: if( this_kind < 0 )then                      ! not a kind value

         exit find_all_kinds                                         ! found all kinds

      elseif( this_kind /= previous_kind )then new_or_same_kind      ! found new kind

         count_kinds = count_kinds + 1                               ! new kind

         previous_kind = this_kind                                   ! update previous kind

      endif new_or_same_kind                                         ! case of kind value

      this_digits = this_digits + 1                                  ! try one more digit

!  do until kind value is negative

   enddo find_all_kinds                                              ! loop over digits

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

!  report and record number of integer kinds

   write( unit= log_unit, fmt= *) 'number of integer kinds found: ', count_kinds

   number_of_integers = count_kinds                                  ! count of kinds

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

!  return with integer kind values known

return                                                               ! count_integer_kinds()

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

!  count_integer_kinds()

end subroutine count_integer_kinds

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

!  seek_integer_kinds() seeks integer kinds

subroutine seek_integer_kinds

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

!  This subroutine finds the integer kinds available and
!  tries to map them to the byte, short, int, and long kind names.

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

!  seek_integer_kinds() constants

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

!  prefix of nondefault integer kind names

   character( len= *), parameter :: kind_prefix = 'int'              ! int<digits>

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

!  seek_integer_kinds() local

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

   integer :: previous_kind                                          ! last valid kind value found

   integer :: selected_kind                                          ! returned by selected_int_kind()

   integer :: this_digits                                            ! loop over digits

   integer :: kinds_count                                            ! count kinds found

   integer :: match_count                                            ! try to assign each kind found

   character( len= kind_len) :: name_buffer                          ! construct unusual names

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

!  seek_integer_kinds()

continue                                                             ! seek_integer_kinds()

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

!  The search assumes the following:

!  There must be at least one kind of integer.
!  One kind of integer will support at least one digit.
!  All integer kinds can be found by searching through increasing numbers of digits supported.
!  A negative kind value will be returned only when all kinds have been found.

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

!  initialize search for integer kinds

   kinds_count = 1                                                   ! start with the first kind to be found
   this_digits = 1                                                   ! which must have at least one digit

   selected_kind = selected_int_kind( r= this_digits)                ! must support one integer kind

   integer_kinds( kinds_count)% kind_value = selected_kind           ! first kind value found
   integer_kinds( kinds_count)% max_digits = this_digits             ! last digits used to select this kind

   previous_kind = selected_kind                                     ! kind already found

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

!  do until kind value is negative

   find_all_kinds: do                                                ! loop over digits

      selected_kind = selected_int_kind( r= this_digits)             ! kind with one more digit

!  branch: all kinds found, found new kind, or found old kind again

      new_or_same_kind: if( selected_kind < 0 )then                  ! not a kind value

         exit find_all_kinds                                         ! found all kinds

      elseif( selected_kind /= previous_kind )then new_or_same_kind  ! found new kind

         kinds_count = kinds_count + 1                               ! new kind

         integer_kinds( kinds_count)% kind_value = selected_kind     ! store kind value

         integer_kinds( kinds_count)% max_digits = this_digits       ! most digits supported

         integer_kinds( kinds_count)% supported = .false.            ! not named yet

         previous_kind = selected_kind                               ! update previous kind

      else new_or_same_kind                                          ! same kind value

         integer_kinds( kinds_count)% max_digits = this_digits       ! supports one more digit

      endif new_or_same_kind                                         ! case of kind value

!  go find next kind

      this_digits = this_digits + 1                                  ! try one more digit

   enddo find_all_kinds                                              ! loop over digits

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

!  found up to max_kinds integer kinds

   report_kinds: do this_digits = 1, ubound( array= integer_kinds, dim= 1)

      call find_integer_bit_size( integer_kinds( this_digits))

      report_supported: if( integer_kinds( this_digits)% kind_value > 0 )then

         write( unit= log_unit, fmt= *) 'found integer kind: ', integer_kinds( this_digits)% kind_value, &
                                        ' supporting digits: ', integer_kinds( this_digits)% max_digits, &
                                        ' estimated bit size: ', integer_kinds( this_digits)% integer_bit_size

      endif report_supported

   enddo report_kinds

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

!  The mapping assumes the following:

!  All kinds supported were found by the above search.
!  The integer kinds will support approximately 2, 4, 9 or 18 digits.
!  A kind may be missing.
!  There are no more than four kinds of integers.
!  These kinds may be sensibly mapped to byte, short, int and long.

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

!  try to set integer kinds parameters

   set_digits: if( storage_size_is_2n )then                          ! (probably) a power of 2 word size

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

!  try to match exactly each kind found with one of byte, short, int, long

      assign_kinds_exactly: do match_count = 1, kinds_count          ! search thru kinds found

         kinds_2n: select case( integer_kinds( match_count)% max_digits )

         case( 2) kinds_2n                                           ! byte digits

            byte_idx = match_count

            bd = integer_kinds( match_count)% max_digits             ! set byte digits inquiry

            integer_kinds( match_count)% kind_name = 'byte'

            integer_kinds( match_count)% supported = .true.          ! this kind is assigned to byte

         case( 4) kinds_2n                                           ! short digits

            short_idx = match_count

            sd = integer_kinds( match_count)% max_digits             ! set short digits inquiry

            integer_kinds( match_count)% kind_name = 'short'

            integer_kinds( match_count)% supported = .true.          ! this kind assigned to short

         case( 9) kinds_2n                                           ! int digits

            int_idx = match_count

            id = integer_kinds( match_count)% max_digits             ! set int digits inquiry

            integer_kinds( match_count)% kind_name = 'int'

            integer_kinds( match_count)% supported = .true.          ! this kind assigned to int

         case( 18) kinds_2n                                          ! long digits

            long_idx = match_count

            ld = integer_kinds( match_count)% max_digits             ! set long digits inquiry

            integer_kinds( match_count)% kind_name = 'long'

            integer_kinds( match_count)% supported = .true.          ! this kind assigned to long

         case default kinds_2n                                       ! odd sizes in 2^n word

            write( unit= name_buffer, fmt= *) integer_kinds( match_count)% max_digits

            integer_kinds( match_count)% kind_name = kind_prefix // adjustl( name_buffer)

            integer_kinds( match_count)% supported = .true.          ! this kind assigned to long

         end select kinds_2n                                         ! select range

      enddo assign_kinds_exactly                                     ! search thru kinds found

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

!  processor word size is not a power of 2

   else set_digits

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

!  try to match approximately each kind found with one of byte, short, int, long

      assign_kinds: do match_count = 1, kinds_count                  ! search thru kinds found

         kinds_odd: select case( integer_kinds( match_count)% max_digits )

         case( 2: 3) kinds_odd                                       ! byte range

            one_byte: if( byte_idx == 0 )then                        ! only one byte

               byte_idx = match_count

               bd = integer_kinds( match_count)% max_digits          ! set byte digits inquiry

               integer_kinds( match_count)% kind_name = 'byte'

               integer_kinds( match_count)% supported = .true.       ! this kind is assigned to byte

            endif one_byte                                           ! only one byte

         case( 4: 5) kinds_odd                                       ! short range

            one_short: if( short_idx == 0 )then                      ! only one short

               short_idx = match_count

               sd = integer_kinds( match_count)% max_digits          ! set short digits inquiry

               integer_kinds( match_count)% kind_name = 'short'

               integer_kinds( match_count)% supported = .true.       ! this kind assigned to short

            endif one_short                                          ! only one short

         case( 9: 10) kinds_odd                                      ! int range

            one_int: if( int_idx == 0 )then                          ! only one int

               int_idx = match_count

               id = integer_kinds( match_count)% max_digits          ! set int digits inquiry

               integer_kinds( match_count)% kind_name = 'int'

               integer_kinds( match_count)% supported = .true.       ! this kind assigned to int

            endif one_int                                            ! only one int

         case( 18: 20) kinds_odd                                     ! long range

            one_long: if( long_idx == 0 )then                        ! only one long

               long_idx = match_count

               ld = integer_kinds( match_count)% max_digits          ! set long digits inquiry

               integer_kinds( match_count)% kind_name = 'long'

               integer_kinds( match_count)% supported = .true.       ! this kind assigned to long

            endif one_long                                           ! only one long

         case default kinds_odd                                      ! odd sized integer kind

            write( unit= name_buffer, fmt= *) integer_kinds( match_count)% max_digits

            integer_kinds( match_count)% kind_name = kind_prefix // adjustl( name_buffer)

            integer_kinds( match_count)% supported = .true.          ! this kind assigned to i<max_digits>

         end select kinds_odd                                        ! select range

      enddo assign_kinds                                             ! search thru kinds found

   endif set_digits

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

!  ensure that byte, short, int, long have entries

   ensure_byte: if( byte_idx == 0 )then                              ! if byte has not been assigned

      find_byte: do match_count = 1, kinds_count                     ! scan small to large

         byte_slot: if( .not. integer_kinds( match_count)% supported )then

            integer_kinds( match_count)% kind_name = 'byte'          ! first is byte

            byte_idx = match_count                                   ! set index
            
            exit find_byte                                           ! done
            
         endif byte_slot                                             ! find unnamed kind
      
      enddo find_byte                                                ! scan small to large
      
   endif ensure_byte                                                 ! if byte has not been assigned

   ensure_short: if( short_idx == 0 )then                            ! if short has not been assigned

      find_short: do match_count = 1, kinds_count                    ! scan small to large

         short_slot: if( .not. integer_kinds( match_count)% supported )then

            integer_kinds( match_count)% kind_name = 'short'         ! next is short

            short_idx = match_count                                  ! set index
            
            exit find_short                                          ! done
            
         endif short_slot                                            ! find unnamed kind
      
      enddo find_short                                               ! scan small to large
      
   endif ensure_short                                                ! if short has not been assigned

   ensure_int: if( int_idx == 0 )then                                ! if int has not been assigned

      find_int: do match_count = 1, kinds_count                      ! scan small to large

         int_slot: if( .not. integer_kinds( match_count)% supported )then

            integer_kinds( match_count)% kind_name = 'int'           ! next is int

            int_idx = match_count                                    ! set index
            
            exit find_int                                            ! done
            
         endif int_slot                                              ! find unnamed kind
      
      enddo find_int                                                 ! scan small to large
      
   endif ensure_int                                                  ! if int has not been assigned

   ensure_long: if( long_idx == 0 )then                              ! if long has not been assigned

      find_long: do match_count = 1, kinds_count                     ! scan small to large

         long_slot: if( .not. integer_kinds( match_count)% supported )then

            integer_kinds( match_count)% kind_name = 'long'          ! next is long

            long_idx = match_count                                   ! set index
            
            exit find_long                                           ! done
            
         endif long_slot                                             ! find unnamed kind
      
      enddo find_long                                                ! scan small to large
      
   endif ensure_long                                                 ! if long has not been assigned

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

!  return with integer kind values known

return                                                               ! seek_integer_kinds()

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

!  seek_integer_kinds()

end subroutine seek_integer_kinds

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

!  find_integer_bit_size() counts integer kinds

subroutine find_integer_bit_size( this_integer)

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

!  This subroutine finds the range of a real kind whose precision is known.

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

!  find_integer_bit_size() interface

type( integer_kind_t), intent( inout) :: this_integer                ! find the range of this precision

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

!  find_integer_bit_size() constants

   integer, parameter :: sign_bit = 1                                ! bits in the sign bit

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

!  find_integer_bit_size() local

   integer :: this_bits                                              ! loop through powers of two

   real :: recip_log10_radix

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

!  find_integer_bit_size()

continue                                                             ! find_integer_bit_size()

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

!  initialize search for integer bit size

   recip_log10_radix = 1.0 / log10( real( radix( 0)) )               ! convert decimal to radix

   this_bits = 1                                                     ! initialize

!  find power of two nearly equal to the digits range

   find_digits_bits: do                                              ! loop over range

      digits_range: if( ceiling( ( this_integer% max_digits * recip_log10_radix) / this_bits) > 1 )then

         this_bits = this_bits + 1                                   ! one more bit

         cycle find_digits_bits                                      ! try again

      else digits_range

         exit find_digits_bits                                       ! quit

      endif digits_range                                             ! case of kind value

   enddo find_digits_bits                                            ! loop over range

   this_integer% integer_bit_size = sign_bit + this_bits             ! estimate

!  if a power of two sized processor, round to nearest power of two

   if_2n_hw: if( storage_size_is_2n )then                            ! hw is 2n

      round_2n: select case( this_integer% integer_bit_size)         ! select power of two

      case( 6: 9) round_2n

         this_integer% integer_bit_size = 8                          ! round to nearest

      case( 14: 17) round_2n

         this_integer% integer_bit_size = 16                         ! round to nearest

      case( 29: 33) round_2n

         this_integer% integer_bit_size = 32                         ! round to nearest

      case( 58: 66) round_2n

         this_integer% integer_bit_size = 64                         ! round to nearest

      case( 116: 132) round_2n

         this_integer% integer_bit_size = 128                        ! round to nearest

      case default round_2n                                          ! remark difficulty

         write( unit= log_unit, fmt= fmtpri) 'WARNING: estimated integer size not nearly a power of 2'

      end select round_2n                                            ! select power of two

   endif if_2n_hw                                                    ! hw is 2n

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

!  return with integer kind values known

return                                                               ! find_integer_bit_size()

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

!  find_integer_bit_size()

end subroutine find_integer_bit_size

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

!  count_real_kinds() counts real kinds

subroutine count_real_kinds

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

!  This subroutine counts the number of real kinds available.

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

!  count_real_kinds() local

   integer :: count_kinds                                            ! count the number of integer kinds

   integer :: this_kind                                              ! find kinds

   integer :: this_precision                                         ! loop through precision

   integer :: previous_kind                                          ! the previous kind found

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

!  count_real_kinds()

continue                                                             ! count_real_kinds()

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

!  The search assumes the following:

!  There must be at least one kind of integer.
!  One kind of integer will support at least one digit.
!  All integer kinds can be found by searching through increasing numbers of digits supported.
!  A negative kind value will be returned only when all kinds have been found.

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

!  initialize search for integer kinds

   count_kinds = 1                                                   ! number of valid results so far

   this_precision = 1                                                ! arg of selected_int_kind()

   previous_kind = selected_real_kind( p= this_precision)            ! must support one integer kind

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

!  do until kind value is negative

   find_all_kinds: do                                                ! loop over digits

      this_kind = selected_real_kind( p= this_precision)             ! kind with one more digit

!  branch: all kinds found --> quit, or found new kind --> count

      new_or_same_kind: if( this_kind < 0 )then                      ! not a kind value so all kinds found

         exit find_all_kinds                                         ! quit seeking

      elseif( this_kind /= previous_kind )then new_or_same_kind      ! found new kind

         count_kinds = count_kinds + 1                               ! new kind

         previous_kind = this_kind                                   ! update previous kind

      endif new_or_same_kind                                         ! case of kind value

      this_precision = this_precision + 1                            ! try one more digit

   enddo find_all_kinds                                              ! loop over digits

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

!  report and record number of real kinds

   write( unit= log_unit, fmt= *) 'number of real kinds found: ', count_kinds

   number_of_reals = count_kinds                                     ! count of kinds

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

!  return with integer kind values known

return                                                               ! count_real_kinds()

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

!  count_real_kinds()

end subroutine count_real_kinds

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

!  seek_real_kinds() seeks real kinds

subroutine seek_real_kinds

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

!  seek_real_kinds() constants

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

   character( len= *), parameter :: kind_prefix = 'r'                ! prefix of nonstandard kind names

   character( len= *), parameter :: range_complaint = &              ! warn of the unexpected
            'NOTE: range does not increase with increasing precision'

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

!  seek_real_kinds() local

   integer :: precision_count                                        ! count by precision

   integer :: kinds_count                                            ! count kinds found
   integer :: this_kind                                              ! loop through kinds

   integer :: selected_kind                                          ! returned by selected_real_kind()

   integer :: previous_kind                                          ! previous kind found

   integer :: match_count                                            ! try to assign each kind found

   character( len= kind_len) :: name_buf                             ! construct names of kinds

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

!  seek_real_kinds()

continue                                                             ! seek_real_kinds()

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

!  initialize search for real kinds by precision

   kinds_count = 1                                                   ! start with the first kind to be found
   precision_count = 1                                               ! which must have a precision of at least 1

   selected_kind = selected_real_kind( p= precision_count)           ! must support two real kinds

   real_kinds( kinds_count)% kind_value = selected_kind              ! first kind value found
   real_kinds( kinds_count)% max_precision = precision_count         ! precision used to select this kind

   previous_kind = selected_kind                                     ! kind already found

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

!  do until kind value is negative

   find_all_kinds: do                                                ! loop over precision

      selected_kind = selected_real_kind( p= precision_count)        ! next kind

!  this precision is too great so seek range of previous kind

      new_old_all_prec: if( selected_kind < 0 )then                  ! to much precision

!  complete the previous real kind

         call seek_range_this_precision( real_kinds( kinds_count))   ! seek range

!  beyond the last kind available

         exit find_all_kinds                                         ! found all kinds by precision

!  found a different kind value greater than zero

      elseif( selected_kind /= previous_kind )then new_old_all_prec  ! found new kind

!  complete the previous real kind

         call seek_range_this_precision( real_kinds( kinds_count))   ! seek range

         real_kinds( kinds_count)% supported = .false.               ! not yet assigned a name

!  start new real kind

         kinds_count = kinds_count + 1                               ! try to find a new kind

         real_kinds( kinds_count)% max_precision = precision_count   ! at least this precision

         real_kinds( kinds_count)% kind_value = selected_kind        ! start new kind

         previous_kind = selected_kind                               ! update

!  still finding the same kind value

      else new_old_all_prec                                          ! same as old kind

         real_kinds( kinds_count)% max_precision = precision_count   ! at least this precision

      endif new_old_all_prec                                         ! case of kind value

      precision_count = precision_count + 1                          ! next precision

   enddo find_all_kinds                                              ! loop over precision

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

!  report real kinds

   report_kinds: do this_kind = 1, ubound( array= real_kinds, dim= 1)

      call find_real_bit_size( real_kinds( this_kind))

      report_supported: if( real_kinds( this_kind)% kind_value > 0 )then

         write( unit= log_unit, fmt= *) 'found real kind: ', real_kinds( this_kind)% kind_value, &
                                        ' supporting precision: ', real_kinds( this_kind)% max_precision, &
                                        ' supporting range: ', real_kinds( this_kind)% max_range, &
                                        ' estimated bit size: ', real_kinds( this_kind)% real_bit_size

      endif report_supported

   enddo report_kinds

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

!  check for range anomalies

   range_check: do this_kind = 2, ubound( array= real_kinds, dim= 1) ! check all pairs of kinds

      anomalie: if( real_kinds( this_kind - 1)% max_range >= real_kinds( this_kind)% max_range )then

         write( unit= log_unit, fmt= *) range_complaint

         write( unit= log_unit, fmt= *) &
            'kind values: ', real_kinds( this_kind - 1)% kind_value, real_kinds( this_kind)% kind_value

         write( unit= log_unit, fmt= *) &
            'ranges: ', real_kinds( this_kind - 1)% max_range, real_kinds( this_kind)% max_range

      endif anomalie

   enddo range_check                                                 ! check all pairs of kinds

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

!  try to set real kinds parameters

   set_kinds: if( storage_size_is_2n )then                           ! word size is 2^n (probably 32 or 64)

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

!  try to match kinds found exactly with single, double, quad

      assign_kinds_exactly: do match_count = 1, ubound( array= real_kinds, dim= 1)

         call find_real_bit_size( real_kinds( match_count))

         kinds_2n: select case( real_kinds( match_count)% real_bit_size )

         case( 32) kinds_2n                                          ! single precision

            single_idx = match_count

            sp = real_kinds( match_count)% max_precision             ! set single precision value
            sr = real_kinds( match_count)% max_range                 ! set single range value

            real_kinds( match_count)% kind_name = 'single'

            real_kinds( match_count)% supported = .true.             ! this kind assigned

         case( 64) kinds_2n                                          ! double precision

            double_idx = match_count

            dp = real_kinds( match_count)% max_precision             ! set double precision value
            dr = real_kinds( match_count)% max_range                 ! set double range value

            real_kinds( match_count)% kind_name = 'double'

            real_kinds( match_count)% supported = .true.             ! this kind assigned

         case( 128) kinds_2n                                         ! quad range

            quad_idx = match_count

            qp = real_kinds( match_count)% max_precision             ! set quad precision
            qr = real_kinds( match_count)% max_range                 ! set quad range

            real_kinds( match_count)% kind_name = 'quad'

            real_kinds( match_count)% supported = .true.             ! this kind assigned

         case default kinds_2n

            write( unit= name_buf, fmt= *) real_kinds( match_count)% max_precision

            real_kinds( match_count)% kind_name = kind_prefix // adjustl( name_buf)

            real_kinds( match_count)% supported = .true.             ! this kind assigned

         end select kinds_2n                                         ! select range

      enddo assign_kinds_exactly                                     ! search thru kinds found

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

!  not a power of 2 word size

   else set_kinds                                                    ! want to auto detect

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

!  try to match kinds found with single, double, quad

      assign_kinds: do match_count = 1, ubound( array= real_kinds, dim= 1)

         kinds_odd: select case( real_kinds( match_count)% max_precision )

         case( 28: 36) kinds_odd                                     ! single precision

            one_single: if( single_idx == 0 )then                    ! only one single

               single_idx = match_count

               sp = real_kinds( match_count)% max_precision          ! set single precision value
               sr = real_kinds( match_count)% max_range              ! set single range value

               real_kinds( match_count)% kind_name = 'single'

               real_kinds( match_count)% supported = .true.          ! this kind assigned

            endif one_single                                         ! only one single

         case( 58: 72) kinds_odd                                     ! double precision

            one_double: if( double_idx == 0 )then                    ! only one double

               double_idx = match_count

               dp = real_kinds( match_count)% max_precision          ! set double precision value
               dr = real_kinds( match_count)% max_range              ! set double range value

               real_kinds( match_count)% kind_name = 'double'

               real_kinds( match_count)% supported = .true.          ! this kind assigned

            endif one_double                                         ! only one double

         case( 120: 144) kinds_odd                                   ! quad precision

            one_quad: if( quad_idx == 0 )then                        ! only one quad

               quad_idx = match_count

               qp = real_kinds( match_count)% max_precision          ! set quad precision value
               qr = real_kinds( match_count)% max_range              ! set quad range value

               real_kinds( match_count)% kind_name = 'quad'

               real_kinds( match_count)% supported = .true.          ! this kind assigned

            endif one_quad                                           ! only one quad

         case default kinds_odd

            write( unit= name_buf, fmt= *) real_kinds( match_count)% max_precision

            real_kinds( match_count)% kind_name = kind_prefix // adjustl( name_buf)

            real_kinds( match_count)% supported = .true.             ! this kind assigned to long

         end select kinds_odd                                        ! select range

      enddo assign_kinds                                             ! search thru kinds found

   endif set_kinds

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

!  ensure that single, double, quad have entries

   ensure_single: if( single_idx == 0 )then                          ! if single has not been assigned

      find_single: do match_count = 1, kinds_count                   ! scan small to large

         single_slot: if( .not. real_kinds( match_count)% supported )then

            real_kinds( match_count)% kind_name = 'single'           ! first is single

            single_idx = match_count                                 ! set index

            exit find_single                                         ! done
            
         endif single_slot                                           ! if unnamed
      
      enddo find_single                                              ! scan small to large
      
   endif ensure_single                                               ! if single has not been assigned

   ensure_double: if( double_idx == 0 )then                          ! if double has not been assigned

      find_double: do match_count = 1, kinds_count                   ! scan small to large

         double_slot: if( .not. real_kinds( match_count)% supported )then

            real_kinds( match_count)% kind_name = 'double'           ! next is double

            double_idx = match_count                                 ! set index
            
            exit find_double                                         ! done
            
         endif double_slot                                           ! if unnamed
      
      enddo find_double                                              ! scan small to large
      
   endif ensure_double                                               ! if double has not been assigned

   ensure_quad: if( quad_idx == 0 )then                              ! if quad has not been assigned

      find_quad: do match_count = 1, kinds_count                     ! scan small to large

         quad_slot: if( .not. real_kinds( match_count)% supported )then

            real_kinds( match_count)% kind_name = 'quad'             ! next is quad

            quad_idx = match_count                                   ! set index
            
            exit find_quad                                           ! done
            
         endif quad_slot                                             ! if unnamed
      
      enddo find_quad                                                ! scan small to large
      
   endif ensure_quad                                                 ! if quad has not been assigned

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

!  return with real kinds values known

return                                                               ! seek_real_kinds()

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

!  seek_real_kinds()

end subroutine seek_real_kinds

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

!  seek_range_this_precision() computes the range of real kinds

subroutine seek_range_this_precision( this_real)

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

!  This subroutine finds the range of a real kind whose precision is known.

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

!  seek_range_this_precision() local

type( real_kind_t), intent( inout) :: this_real                      ! count the number of integer kinds

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

!  seek_range_this_precision() local

   integer :: range_count                                            ! loop through range

   integer :: selected_kind

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

!  seek_range_this_precision()

continue                                                             ! seek_range_this_precision()

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

!  The search assumes the following:

!  The real has been found.
!  The precision has been found and stored in this_real.
!  The range can be found by holding the precision constant.
!  The range can be found by incrementing the range.

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

!  initialize search for integer kinds

   range_count = 1                                                   ! initialize range count

   find_last_max_range: do                                           ! loop over range

      selected_kind = selected_real_kind( p= this_real% max_precision, r= range_count)

!  this range gives the same kind value as the previous range until new kind value or no more kinds

      last_range: if( selected_kind /= this_real% kind_value )then

         exit find_last_max_range                                    ! quit

      else last_range                                                ! case of kind value

         this_real% max_range = range_count                          ! update range

      endif last_range                                               ! case of kind value

      range_count = range_count + 1                                  ! next range

   enddo find_last_max_range                                         ! loop over range

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

!  return with integer kind values known

return                                                               ! seek_range_this_precision()

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

!  seek_range_this_precision()

end subroutine seek_range_this_precision

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

!  find_real_bit_size() counts integer kinds

subroutine find_real_bit_size( this_real)

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

!  This subroutine finds the range of a real kind whose precision is known.

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

!  find_real_bit_size() interface

type( real_kind_t), intent( inout) :: this_real                      ! find the range of this precision

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

!  find_real_bit_size() constants

   integer, parameter :: sign_bit = 1                                ! bits in the sign bit

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

!  find_real_bit_size() local

   integer :: this_bits                                              ! loop through powers of two

   integer :: k                                                      ! as per the standard model of reals

   real :: recip_log10_radix

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

!  find_real_bit_size()

continue                                                             ! find_real_bit_size()

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

!  The calculation assumes the following:

!  There is one bit used as the sign bit.
!  The range is (nearly) a power of two.
!  There is some number of bits in the precision.
!  There are no unused bits.

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

!  initialize search for real bit size

   k_0_1: if( log10( real( radix( 0.0)) ) == anint( log10( real( radix( 0.0)) )) )then

      k = 1

   else k_0_1

      k = 0

   endif k_0_1

   recip_log10_radix = 1.0 / log10( real( radix( 0.0)) )             ! convert decimal to radix

   this_bits = 1                                                     ! initialize

   find_exponent_bits: do                                            ! loop over range

!  find power of two nearly equal to the exponent range

      exp_range: if( ceiling( ( this_real% max_range * recip_log10_radix) / 2.0**this_bits) > 1 )then

         this_bits = this_bits + 1                                   ! one more bit

         cycle find_exponent_bits                                    ! try again

      else exp_range

         exit find_exponent_bits                                     ! quit

      endif exp_range                                                ! case of kind value

   enddo find_exponent_bits                                          ! loop over