add project on polymorphic type instead of multiple types

test_vect_type/a.f90

+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
+
+
+
+
+
+
+
+
+
+
+
+
+

test_vect_type/test.f90

+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

test_vect_type/test_prog.f90

+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

test_vect_type/toto.f90

+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