!Note:  This file was reformatted from a COMP.LANG.FORTRAN message.  ! comments
! were added and may need to be removed in favor or "*" or "C",
! for your specific compiler and source form selected.
!
!OK -- This mess compiles with MS Fortran 5.1, MS FPS1 and FPS4, Digital's
!DVF5 and Compaq's CVF 6.1

!I haven't had a chance to test it, but it is simple enough that it should
!just work.

!IIRC - the GNU LGPL allows one to use code by only supplying the source
!for the LGPL'd code, not your own.  If neither that, nor any of the other
!licenses listed below suits, I can be flexible.  The main reason I am not
!just putting this into the public domain is that then I'd have no
!protection if someone wants to sue me over some misuse of this.

!HTH
!Kevin

!*-----------------------------------------------------------------------
!*
!*  These two routines are designed to allow precision to be deliberately
!*  thrown away in an IEEE floating point compliant computing environment
!*  (such as Intel x87 or Apple SANE) in order to more closely model
!*  computations in less precise floating point systems.
!*
!*-----------------------------------------------------------------------
!*
!*  Copyright 2001 Kevin G. Rhoads
!*
!*  Use is licensed under many of the so-called "public" licenses, per
!*  choice of user: GNU GPL, GNU LGPL, Artistic License, or the Q License
!*
!*-----------------------------------------------------------------------
!*
!*  It is the responsibility of the user of this code to ensure that the
!*  initialization routine is called FIRST!  => call moyel_init()
!*  before using moyel.
!*
!*-----------------------------------------------------------------------
!*
!*  The function moyel is designed to "trim" precision from IEEE 32 bit
!reals.
!
!*  If you need to trim doubles or extended reals, convert to single and
!*  use moyel or write your own.
!*
!*  trimmed_real = moyel( untrimmed_real, how_much_to_trim )
!*  where how_much_to_trim is an integer
!*  valid ranges for trimming are 0 to 24 bits
!*  if (how_much_to_trim .lt. 0) it is treated as zero
!*  if (how_much_to_trim .gt. 24) it is treated as 24
!*  for IEEE 32 bit reals, 24 bits of triming will remove all mantissa bits
!*  of UNnormals and DEnormals, and will leave only the implicit 1 bit of
!*  normalized reals
!*
!*-----------------------------------------------------------------------
!*
!*  Regarding Hexadecimal constants:  the old (non-standard) Microsoft
!syntax is #XXXXXXXX while the newer (on it's way to becoming standard)
!syntax is Z"XXXXXXXX" or Z'XXXXXXXX'  -- both are provided below, with the
!new syntax commented out.  Also, the hexadecimal constants have been printed
!out as standard decimal integers and are provided in that form also.  So if
!your Fortran compiler does not support Hex constants in any form, use the
!decimal ones (but I suggest the Hex ones be kept in as comment lines)
!*
!*-----------------------------------------------------------------------
      real function moyel(arg,trim)
      real arg,foo
      integer bar,trim
      equivalence (foo,bar)
      integer masks(25)
      common /moyeldat/masks
      save /moyeldat/
!*-----
!*
!* It is the responsibility of the user of this code to ensure that the
!* initialization routine is called FIRST!  But, just in case, we will
!* do what we can to guard against garbage computations.
!*
!*      if ( masks(25).ne.Z"FEABCD98" ) then
!*      if ( masks(25).ne.Z'FEABCD98' ) then
!*      if ( masks(25).ne.-22295144 ) then
      if ( masks(25).ne.#FEABCD98 ) then
          call moyel_init()
      endif
!*
      foo = arg
      if (trim.le.0) then
!* do nothing
      elseif (trim.ge.24) then
          bar = iand(bar,masks(24))
      else
          bar = iand(bar,masks(trim))
      endif
      moyel = foo
      return
      end
!*-----------------------------------------------------------------------
      subroutine moyel_init()
      integer masks(25)
      common /moyeldat/masks
      save /moyeldat/
!*-----
      masks(1)  = #FFFFFFFE
      masks(2)  = #FFFFFFFC
      masks(3)  = #FFFFFFF8
      masks(4)  = #FFFFFFF0
      masks(5)  = #FFFFFFE0
      masks(6)  = #FFFFFFC0
      masks(7)  = #FFFFFF80
      masks(8)  = #FFFFFF00
      masks(9)  = #FFFFFE00
      masks(10) = #FFFFFC00
      masks(11) = #FFFFF800
      masks(12) = #FFFFF000
      masks(13) = #FFFFE000
      masks(14) = #FFFFC000
      masks(15) = #FFFF8000
      masks(16) = #FFFF0000
      masks(17) = #FFFE0000
      masks(18) = #FFFC0000
      masks(19) = #FFF80000
      masks(20) = #FFF00000
      masks(21) = #FFE00000
      masks(22) = #FFC00000
      masks(23) = #FF800000
      masks(24) = #FF000000
      masks(25) = #FEABCD98
!*      masks( 1) =        -2
!*      masks( 2) =        -4
!*      masks( 3) =        -8
!*      masks( 4) =       -16
!*      masks( 5) =       -32
!*      masks( 6) =       -64
!*      masks( 7) =      -128
!*      masks( 8) =      -256
!*      masks( 9) =      -512
!*      masks(10) =     -1024
!*      masks(11) =     -2048
!*      masks(12) =     -4096
!*      masks(13) =     -8192
!*      masks(14) =    -16384
!*      masks(15) =    -32768
!*      masks(16) =    -65536
!*      masks(17) =   -131072
!*      masks(18) =   -262144
!*      masks(19) =   -524288
!*      masks(20) =  -1048576
!*      masks(21) =  -2097152
!*      masks(22) =  -4194304
!*      masks(23) =  -8388608
!*      masks(24) = -16777216
!*      masks(25) = -22295144
!*      masks(1)  = Z"FFFFFFFE"
!*      masks(2)  = Z"FFFFFFFC"
!*      masks(3)  = Z"FFFFFFF8"
!*      masks(4)  = Z"FFFFFFF0"
!*      masks(5)  = Z"FFFFFFE0"
!*      masks(6)  = Z"FFFFFFC0"
!*      masks(7)  = Z"FFFFFF80"
!*      masks(8)  = Z"FFFFFF00"
!*      masks(9)  = Z"FFFFFE00"
!*      masks(10) = Z"FFFFFC00"
!*      masks(11) = Z"FFFFF800"
!*      masks(12) = Z"FFFFF000"
!*      masks(13) = Z"FFFFE000"
!*      masks(14) = Z"FFFFC000"
!*      masks(15) = Z"FFFF8000"
!*      masks(16) = Z"FFFF0000"
!*      masks(17) = Z"FFFE0000"
!*      masks(18) = Z"FFFC0000"
!*      masks(19) = Z"FFF80000"
!*      masks(20) = Z"FFF00000"
!*      masks(21) = Z"FFE00000"
!*      masks(22) = Z"FFC00000"
!*      masks(23) = Z"FF800000"
!*      masks(24) = Z"FF000000"
!*      masks(25) = Z"FEABCD98"
!*      masks(1)  = Z'FFFFFFFE'
!*      masks(2)  = Z'FFFFFFFC'
!*      masks(3)  = Z'FFFFFFF8'
!*      masks(4)  = Z'FFFFFFF0'
!*      masks(5)  = Z'FFFFFFE0'
!*      masks(6)  = Z'FFFFFFC0'
!*      masks(7)  = Z'FFFFFF80'
!*      masks(8)  = Z'FFFFFF00'
!*      masks(9)  = Z'FFFFFE00'
!*      masks(10) = Z'FFFFFC00'
!*      masks(11) = Z'FFFFF800'
!*      masks(12) = Z'FFFFF000'
!*      masks(13) = Z'FFFFE000'
!*      masks(14) = Z'FFFFC000'
!*      masks(15) = Z'FFFF8000'
!*      masks(16) = Z'FFFF0000'
!*      masks(17) = Z'FFFE0000'
!*      masks(18) = Z'FFFC0000'
!*      masks(19) = Z'FFF80000'
!*      masks(20) = Z'FFF00000'
!*      masks(21) = Z'FFE00000'
!*      masks(22) = Z'FFC00000'
!*      masks(23) = Z'FF800000'
!*      masks(24) = Z'FF000000'
!*      masks(25) = Z'FEABCD98'
      return
      end