Clicky
Showing changes from revision #0 to #1:
(追記) Added (追記ここまで) | (削除) Removed (削除ここまで) | (削除) Chan (削除ここまで)(追記) ged (追記ここまで)
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##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