blob: 8be5f7123a1ac727004a0be8e9255d5f36a65ecd [file] [log] [blame]
! { dg-do run }
!
! Test the fix for PR117897 in which the rhs of the pointer assignment at line
! 216 below was marked as being finalizable, contrary to F2023 7.5.6.3 for
! ordinary assignment and certainly wrong in this context.
!
! Contributed by Jean Gual <jean.gual@cerema.fr>
!
Module Uef_Classe_Vector
! Ce module implemente le vector de la STL du C++
Private
CHARACTER (len=3), Parameter :: UEF_PAR_CHAINE_NON_RENSEIGNEE = "N_R"
real, parameter :: UEF_par_vector_progression_ratio = 2
Integer, parameter :: UEF_par_vector_initial_lenght = 10
Type, abstract, public :: Uef_Vector_element
Logical, public :: m_Element_pointe = .false.
End type Uef_Vector_element
Type, private :: Uef_Pointeur_element ! Classe pointeur
Class (Uef_Vector_element), public, pointer :: m_ptr_element => null()
End type Uef_Pointeur_element
Type, public :: Uef_Vector ! Vecteur des classes pointeur
integer , private :: m_position_fin = 0
type(Uef_Pointeur_element), private, allocatable, dimension(:) :: m_les_pointeur_element
Character (:), private, allocatable :: m_label
Class (Uef_Vector_element), allocatable, private :: m_type_element
logical ,private :: m_polymorphe = .false.
Contains
PROCEDURE :: create => Vector_create
PROCEDURE :: add => Vector_add
PROCEDURE :: Pointer => Vector_pointer
PROCEDURE :: size => vector_size
End Type Uef_Vector
Contains
!--------------------
! Vector_create : Cree un vector non deja alloue avec une taille initiale eventuelle
!--------------------
Subroutine Vector_create(le_vector, label, type_element, opt_taille, opt_polymorphe)
! parametres en entree/sortie
Class(Uef_Vector),intent (inout) :: le_vector
Character (len=*),intent(in) :: label
Class (Uef_Vector_element),intent(in) :: type_element
Integer, intent(in), optional :: opt_taille
Logical, intent(in), optional :: opt_polymorphe
! parametres locaux
integer :: taille_initiale
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
! write (*,*) "create:", label
if (allocated(le_vector%m_les_pointeur_element)) then
Call Uef_assert(.false., "Vector_create : vecteur deja cree :"// le_vector%m_label)
endif
if (present(opt_taille)) then
taille_initiale = max( 1, opt_taille )
else
taille_initiale = UEF_par_vector_initial_lenght
endif
if (present(opt_polymorphe)) then
le_vector%m_polymorphe = opt_polymorphe
endif
allocate( le_vector%m_les_pointeur_element(1:taille_initiale))
le_vector%m_position_fin = 0
le_vector%m_label = label
allocate (le_vector%m_type_element, source = type_element)
End Subroutine Vector_create
!--------------------
! Vector_add : ajoute une copie d'un element a la fin du vecteur
!--------------------
Subroutine Vector_add(le_vector, l_element)
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
Class(Uef_Vector_element), intent(in) :: l_element
! parametres locaux
type(Uef_Pointeur_element) :: le_ptr_element
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
! write (*,*) "ajout:", le_vector%m_label
if ( .not. allocated(le_vector%m_les_pointeur_element) ) Then
Call Vector_create(le_vector, label= UEF_PAR_CHAINE_NON_RENSEIGNEE, type_element = l_element)
End if
if ( .not. same_type_as (l_element,le_vector%m_type_element).and. .not. le_vector%m_polymorphe) then
Call Uef_assert(.false., "Vector_add : element de type incorrect pour :"// le_vector%m_label)
End if
if ( le_vector%m_position_fin >= size(le_vector%m_les_pointeur_element) ) then
call vector_increase_size( le_vector, le_vector%m_position_fin+1 )
endif
le_vector%m_position_fin = le_vector%m_position_fin + 1
allocate (le_ptr_element%m_ptr_element, source = l_element)
le_vector%m_les_pointeur_element(le_vector%m_position_fin) = le_ptr_element
End Subroutine Vector_add
!--------------------
! vector_size : retourne le nombre d'elements effectifs du vector
!--------------------
Pure Integer Function vector_size(le_vector)
! parametres en entree
Class(Uef_Vector), intent (in) :: le_vector
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
vector_size = le_vector%m_position_fin
End Function vector_size
!--------------------
! Vector_pointer : pointe sur une valeur
!--------------------
Function Vector_pointer( le_vector, position_element )
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
integer,intent (in) :: position_element
! parametres en sortie
Class(Uef_Vector_element), Pointer :: Vector_pointer
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
if ( position_element < 1 .or. position_element > le_vector%m_position_fin ) then
write (*,*) "Vector_pointer : pointage impossible de ", le_vector%m_label, " position_element:",&
position_element," size:",le_vector%m_position_fin
Call Uef_assert(.false., "Vector_pointer : pointage impossible dans "// le_vector%m_label)
else
le_vector%m_les_pointeur_element(position_element)%m_ptr_element%m_Element_pointe =.true.
Vector_pointer => le_vector%m_les_pointeur_element(position_element)%m_ptr_element
endif
End Function Vector_pointer
!--------------------
! vector_increase_size : augmente la taille du vector
!--------------------
Subroutine vector_increase_size( le_vector, taille_demandee )
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
integer,intent(in) :: taille_demandee
! Parametres en locaux
integer :: Nouvelle_taille, taille_actuelle
type(Uef_Pointeur_element),dimension (:), allocatable:: tmp_vector
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
taille_actuelle = size(le_vector%m_les_pointeur_element)
Nouvelle_taille = max(taille_demandee, nint( UEF_par_vector_progression_ratio * taille_actuelle))
if (Nouvelle_taille > taille_actuelle) then
allocate(tmp_vector(1:Nouvelle_taille))
tmp_vector(1:taille_actuelle) = le_vector%m_les_pointeur_element(1:le_vector%m_position_fin)
call move_alloc(from = tmp_vector , to = le_vector%m_les_pointeur_element)
endif
End Subroutine vector_increase_size
!------------------------
Subroutine Uef_Assert (assertion, message)
!--------------------
! traitement des assertions
!--------------------
! Parametres en entree
Logical, Intent(in) :: assertion
Character (len = *) , intent(in):: message
!-------------------------------------------------------------------------------------------------
if (.not. assertion ) Then
write(*,*) message
write(*,*) " ARRET PREMATURE : PREVENIR LE GESTIONNAIRE"
stop
End if
End Subroutine Uef_Assert
End Module Uef_Classe_Vector
Program Cds_Principal
Use Uef_Classe_vector
!
!--------------------------------------------------------------------------------------------------
TYPE, extends(Uef_Vector_element), abstract :: Cds_Materiau
Character (len=8) :: m_Nom_materiau = "12345678"
Type(Uef_Vector) :: m_Les_situations
END TYPE Cds_Materiau
Type, extends (Cds_Materiau) :: Cds_Materiau_Acier_EC
Double precision :: m_Fyk = 0.00
End type Cds_Materiau_Acier_EC
Type(Uef_Vector) :: Cds_Mod_Les_materiaux
Type (Cds_Materiau_Acier_EC) :: acier_ec
Class (Cds_Materiau), pointer :: pt_materiau
Character *(8) :: nom_materiau
!-------------------------------------------------------------------------------------------------
CaLL Cds_Mod_Les_materiaux%Add (acier_ec)
nom_materiau = "12345678"
pt_materiau => Get_pt_materiau_nom (Cds_Mod_Les_materiaux, nom_materiau)
contains
Function Get_Pt_Materiau_nom (vecteur, nom_materiau)
!--------------------
! Fonction :
!--------------------
! Parametres en entree
Character *(8), Intent (in) :: nom_materiau
Type (Uef_Vector) , Intent (inout) :: vecteur
! Parametres en sortie
Class (Cds_Materiau),pointer :: Get_Pt_Materiau_nom
! Parametres locaux
Integer :: no_materiau
Class (Uef_Vector_element),pointer :: pt_vector_element
!--------------------
do no_materiau = 1 , vecteur%size()
pt_vector_element => vecteur%Pointer(no_materiau)
! this instruction did not work
Get_Pt_Materiau_nom => Cds_pt_materiau(pt_vector_element)
if (trim (Get_Pt_Materiau_nom%m_Nom_materiau) /= '12345678') stop 1
if (Get_Pt_Materiau_nom%m_Nom_materiau == nom_materiau) Then
return
End if
End do
Get_Pt_Materiau_nom => null()
End Function Get_Pt_Materiau_nom
!
!--------------------
function Cds_Pt_Materiau(vector_element)
!--------------------
! Fonction : pointage de la valeur
!--------------------
! Parametres en entree
Class (Uef_Vector_element),intent(in),target :: vector_element
! Parametres en sortie
Class(Cds_Materiau), pointer :: Cds_Pt_Materiau
!-----------------------------------------------------------------------------------------------
select type(vector_element)
Class is (Cds_Materiau)
Cds_Pt_Materiau => vector_element
class default
stop 2
end select
End Function Cds_Pt_Materiau
End Program Cds_Principal