1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
|
! { 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
|
