Fortran Wiki
extend_dble

Extending an intrinsic function

An existing function can be extended. As an example, here the DBLE() intrinsic function is extended to take a metamorphic scalar intrinsic, a CHARACTER variable, and a LOGICAL.

module M_extend
   use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
   use, intrinsic :: iso_fortran_env, only : real32, real64, real128
   implicit none
   private
   public dble                      ! extend intrinsics to accept CHARACTER values and LOGICALS
   interface dble
      module procedure anyscalar_to_double
   end interface
contains

   pure elemental function anyscalar_to_double(valuein) result(d_out)
      use, intrinsic :: iso_fortran_env, only : error_unit !! ,input_unit,output_unit
      implicit none

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

      class(*),intent(in)       :: valuein
      doubleprecision           :: d_out
      doubleprecision,parameter :: big=huge(0.0d0)
      character(len=3)          :: nanstring
      select type(valuein)
       type is (integer(kind=int8));   d_out=real(valuein,kind=real64)
       type is (integer(kind=int16));  d_out=real(valuein,kind=real64)
       type is (integer(kind=int32));  d_out=real(valuein,kind=real64)
       type is (integer(kind=int64));  d_out=real(valuein,kind=real64)
       type is (real(kind=real32));    d_out=real(valuein,kind=real64)
       type is (real(kind=real64));    d_out=real(valuein,kind=real64)
       Type is (real(kind=real128))
         if(valuein.gt.big)then
            !!write(error_unit,*)'*anyscalar_to_double* value too large ',valuein
            nanstring='NaN'
            read(nanstring,*) d_out
         else
            d_out=real(valuein,kind=real64)
         endif
       type is (logical);              d_out=merge(0.0d0,1.0d0,valuein)
       type is (character(len=*));     read(valuein,*) d_out
       class default
         !!stop '*M_anything::anyscalar_to_double: unknown type'
         nanstring='NaN'
         read(nanstring,*) d_out
      end select
   end function anyscalar_to_double

end module M_extend

program testit
   use M_extend
   implicit none
   ! make sure normal stuff still works
   write(*,*)'##CONVENTIONAL'
   write(*,*)'INTEGER         ', dble(10)
   write(*,*)'INTEGER ARRAY   ', dble([10,20])
   write(*,*)'REAL            ', dble(10.20)
   write(*,*)'DOUBLEPRECISION ', dble(100.20d0)
   ! extensions
   write(*,*)'##EXTENSIONS'
   write(*,*)'CHARACTER       ', dble('100.30')
   write(*,*)'CHARACTER ARRAY ', dble([character(len=10) :: '100.30','400.500'])
   ! call a function with a metamorphic argument
   write(*,*)'METAMORPHIC I   ', promote(111)
   write(*,*)'METAMORPHIC R   ', promote(111.222)
   write(*,*)'METAMORPHIC D   ', promote(333.444d0)
   write(*,*)'METAMORPHIC C   ', promote('555.666e1')
   ! settle this once and for all
   write(*,*)'LOGICAL TRUE    ', dble(.true.)
   write(*,*)'LOGICAL FALSE   ', dble(.false.)
   write(*,*)'LOGICAL ARRAY   ', dble([.false., .true., .false., .true.])
contains
   function promote(value)
      class(*),intent(in) :: value
      doubleprecision     :: promote
      promote=dble(value)**2
   end function promote
end program testit

Expected output

##CONVENTIONAL
INTEGER            10.000000000000000     
INTEGER ARRAY      10.000000000000000 20.000000000000000     
REAL               10.199999809265137     
DOUBLEPRECISION    100.20000000000000     
##EXTENSIONS
CHARACTER          100.30000000000000     
CHARACTER ARRAY    100.30000000000000 400.50000000000000     
METAMORPHIC I      12321.000000000000     
METAMORPHIC R      12370.333311153809     
METAMORPHIC D      111184.90113600001     
METAMORPHIC C      30876470.355599999     
LOGICAL TRUE       0.0000000000000000     
LOGICAL FALSE      1.0000000000000000     
LOGICAL ARRAY      1.0000000000000000 0.0000000000000000 1.0000000000000000 0.0000000000000000