Commit 2bb1562e authored by Bérangère Lamy's avatar Bérangère Lamy
Browse files

add project on polymorphic type instead of multiple types

parent 6c98727e
No related merge requests found
Showing with 250 additions and 0 deletions
+250 -0
module alpha
type general
integer :: int_
real :: float_
character :: char_
class(*), allocatable :: unknown_
contains
procedure :: SINT => set_integer
procedure :: SFLOAT => set_real
procedure :: SCHAR => set_character
procedure :: SUNKNOWN => set_unknown
procedure :: PUNKNOWN => print_unknown
end type general
contains
subroutine set_integer(self, int_)
class(general), intent(inout) :: self
integer, intent(inout) :: int_
self%int_ = int_
end subroutine set_integer
subroutine set_real(self, float_)
class(general), intent(inout) :: self
real, intent(inout) :: float_
self%float_ = float_
end subroutine set_real
subroutine set_character(self, char_)
class(general), intent(inout) :: self
character, intent(inout) :: char_
self%char_ = char_
end subroutine set_character
subroutine set_unknown(self, unknown_)
class(general), intent(inout) :: self
class(*), intent(inout), pointer :: unknown_
self%unknown_ = unknown_
end subroutine set_unknown
subroutine print_unknown(self)
class(general), intent(inout) :: self
class(*), intent(inout), pointer :: unknown_
SELECT TYPE(unknown_)
TYPE IS(INTEGER)
unknown_ => self%unknown_
print*,unknown_
TYPE IS(REAL)
unknown_ => self%unknown_
print*,unknown_
END SELECT
!ptr => self%unknown_
!ptrr => self%unknown_
!ptr <= self%unknown_
!ptrr <= self%unknown_
!SELECT TYPE(self%unknown_)
!SELECT TYPE(ptr)
!SELECT TYPE(ptrr)
! TYPE IS(INTEGER)
! !print*,self%unknown_
! !print*,ptr
! print*,ptrr
! TYPE IS(REAL)
! !print*,self%unknown_
! !print*,ptr
! print*,ptrr
! !TYPE IS(CHARACTER*1)
! ! print*,self%unknown_
!END SELECT
end subroutine print_unknown
end module alpha
!_______________________
program a
use alpha
implicit none
type(general) :: test
integer :: int_1, int_2
real :: float_1, float_2
character :: char_1, char_2
integer, target :: int_3
real, target :: float_3
class(*),pointer :: unknown_1, unknown_2, ptr
int_1 = 10
int_2 = 20
float_1 = 15.0
float_2 = 25.0
char_1 = 'a'
char_2 = 'b'
test = general(int_=int_1, float_=float_1, char_=char_1)
unknown_1 => int_3
unknown_2 => float_3
print*,test%int_, test%float_, test%char_
call test % SINT(int_2)
call test % SFLOAT(float_2)
call test % SCHAR(char_2)
print*,test%int_, test%float_, test%char_
call test % SUNKNOWN(unknown_1)
print*,test%unknown_
end program a
File added
File added
MODULE VECTOR
IMPLICIT NONE
TYPE STD_VECTOR
CLASS(*), DIMENSION(:), POINTER :: v_ptr
INTEGER :: v_size_in_array
INTEGER :: v_size_in_memory
integer, dimension(:), allocatable, target :: ptr_int
CONTAINS
PROCEDURE :: ALLOC => ALLOCATE_STD_VECTOR
!PROCEDURE :: MODIF => MODIF_STD_VECTOR
!PROCEDURE :: DEALLOC => DEALLOCATE_STD_VECTOR
END TYPE STD_VECTOR
CONTAINS
SUBROUTINE ALLOCATE_STD_VECTOR(self, array)
CLASS(STD_VECTOR), intent(inout) :: self
CLASS(*), intent(in), dimension(:) :: array
SELECT TYPE(ARRAY)
TYPE IS(INTEGER)
print*,"hello"
ALLOCATE(self%ptr_int, SOURCE=array)
self%v_ptr => ptr_int
SELECT TYPE(self%v_ptr)
TYPE IS(INTEGER)
print*,self%v_ptr
!self%v_ptr = self%v_ptr * 1
!print*,self%v_ptr
END SELECT
CLASS DEFAULT
print*,"error, no type"
END SELECT
END SUBROUTINE ALLOCATE_STD_VECTOR
END MODULE VECTOR
File added
program test
use VECTOR
implicit none
integer, dimension(:), allocatable, TARGET :: tester
class(*), dimension(:), pointer :: tester_ptr
type(STD_VECTOR) :: v_tester
allocate(tester(10))
tester_ptr => tester
!tester(:) = [(i, i=1,10,2)]
tester(:) = (/1,2,3,4,5,6,7,8,9,10/)
!print*,tester
!v_tester.alloc(tester)
!call alloc(v_tester, tester)
call v_tester%alloc(tester_ptr)
tester <= v_tester%v_ptr
print*,tester
end program test
module toto
implicit none
interface totos
PROCEDURE toto1, toto2
end interface totos
contains
subroutine toto1(titi)
integer, intent(inout) :: titi
print*,titi
end subroutine toto1
subroutine toto2(titi)
real, intent(inout) :: titi
print*,titi
end subroutine toto2
end module toto
program try
use toto
implicit none
integer :: alpha
real :: beta
call totos(alpha)
call totos(beta)
end program try
File added
File added
File added
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment