| ! { 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 |