30287542962

Committed 27 Jul 2026 05:03PM UTC coverage: 93.693% (-0.9%) from 94.58%

Build # 30287542962

Build Type

Pull #79

github

Committed by

web-flow

Commit Message

Merge 8fb7e8893 into 58212d52c

Pull Request Pull Request #79: Type mods2

Coverage Stats

118 of 134 new or added lines in 18 files covered. (88.06%)

16 existing lines in 4 files now uncovered.

2778 of 2965 relevant lines covered (93.69%)

14.89 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

91.75

/Source/FTObjects/FTObjectArrayClass.f90

! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy  
! of this software and associated documentation files (the "Software"), to deal  
! in the Software without restriction, including without limitation the rights  
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell  
! copies of the Software, and to permit persons to whom the Software is  
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all  
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR  
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE  
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER  
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,  
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE  
! SOFTWARE.
!
! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend, 
! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
!
! --- End License

!
!////////////////////////////////////////////////////////////////////////
!
!      FTMutableObjectArray.f90
!      Created: February 7, 2013 3:24 PM 
!      By: David Kopriva  
!
!>FTMutableObjectArray is a mutable array class to which objects
!>can be added, removed, replaced and accessed according to their 
!>index in the array.
!>
!>Fortran has pointers to arrays, but not arrays of pointers. To do the latter, one creates
!>a wrapper derived type and creates an array of that wrapper type. Fortran arrays are great, but
!>they are of fixed length, and they don't easily implement reference counting to keep track of
!>memory. For that, we have the FTMutableObjectArray. Performance reasons dictate that you 
!>will use regular arrays for numeric types and the like, but for generic objects we would use
!>an Object Array.
!>
!>You initialize a FTMutableObjectArray with the number of objects that you expect it to hold.
!>However, it can re-size itself if necessary. To be efficient, it adds more than one entry at a time
!>given by the ``chunkSize'', which you can choose for yourself. (The default is 10.)
!>##Definition
!>           TYPE(FTMutableObjectArray) :: array
!>#Usage
!>##Initialization
!>      CLASS(FTMutableObjectArray)  :: array
!>      INTEGER                      :: N = 11
!>      CALL array % initWithSize(N)
!>#Destruction
!>           CALL array  %  destuct() [Non Pointers]
!>           call releaseFTMutableObjectArray(array) [Pointers]
!>#Adding an Object
!>           TYPE(FTObject) :: obj
!>           obj => r1
!>           CALL array % addObject(obj)
!>#Removing an Object
!>           TYPE(FTObject) :: obj
!>           CALL array % removeObjectAtIndex(i)
!>#Accessing an Object
!>           TYPE(FTObject) :: obj
!>           obj => array % objectAtIndex(i)
!>#Replacing an Object
!>           TYPE(FTObject) :: obj
!>           obj => r1
!>           CALL array % replaceObjectAtIndexWithObject(i,obj)
!>#Setting the Chunk Size
!>           CALL array % setChunkSize(size)
!>#Finding The Number Of Items In The Array
!>           n =  array % count()
!>#Finding The Actual Allocated Size Of The Array
!>           n =  array % allocatedSize()

!
!////////////////////////////////////////////////////////////////////////
!
      MODULE FTMutableObjectArrayClass
      USE FTObjectClass
      IMPLICIT NONE
      
      TYPE FTObjectPointerWrapper
         CLASS(FTObject), POINTER ::  object => NULL()
      END TYPE FTObjectPointerWrapper
      
      PRIVATE :: FTObjectPointerWrapper
      PRIVATE :: increaseArraysize
      
      TYPE, EXTENDS(FTObject) ::  FTMutableObjectArray
         INTEGER                                            , PRIVATE :: count_
         TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER, PRIVATE :: array => NULL()
         INTEGER                                            , PRIVATE :: chunkSize_ = 10
!
!        --------
         CONTAINS
!        --------
!
         PROCEDURE, PUBLIC :: initWithSize => initObjectArrayWithSize
         FINAL             :: destructObjectArray
         PROCEDURE, PUBLIC :: addObject    => addObjectToArray
         PROCEDURE, PUBLIC :: replaceObjectAtIndexWithObject
         PROCEDURE, PUBLIC :: removeObjectAtIndex
         PROCEDURE, PUBLIC :: objectAtIndex
         
         PROCEDURE, PUBLIC :: printDescription => printArray
         PROCEDURE, PUBLIC :: className        => arrayClassName
!         
         PROCEDURE, PUBLIC :: setChunkSize
         PROCEDURE, PUBLIC :: chunkSize
         PROCEDURE, PUBLIC :: COUNT => numberOfItems
         PROCEDURE, PUBLIC :: allocatedSize
         
      END TYPE 
         
      INTERFACE cast
         MODULE PROCEDURE castToMutableObjectArray
      END INTERFACE cast
!
!     ======== 
      CONTAINS  
!     ======== 
!
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Designated initializer. Initializes the amount of storage, but
!> the array remains empty.
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray)  :: array
!>       integer                      :: N = 11
!>       CALL array % initWithSize(N)
!>
      SUBROUTINE initObjectArrayWithSize( self, arraySize )    
         IMPLICIT NONE  
         CLASS( FTMutableObjectArray) :: self
         INTEGER                      :: arraySize
         INTEGER                      :: i
         
         CALL self % FTObject % init()
         
         ALLOCATE( self % array(arraySize) )
         
         DO i = 1,  arraySize
            self % array(i) %  object => NULL()
         END DO
         self % count_ = 0
         
      END SUBROUTINE initObjectArrayWithSize
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTMutableObjectArray(self)  
         IMPLICIT NONE
         TYPE(FTMutableObjectArray), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
         
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTMutableObjectArray
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTMutableObjectArrayClass(self)  
         IMPLICIT NONE
         CLASS(FTMutableObjectArray), POINTER :: self
         CLASS(FTObject)            , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
         
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTMutableObjectArrayClass
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Destructor for the class. This is called automatically when the
!> reference count reaches zero. Do not call this yourself.
!>
      RECURSIVE SUBROUTINE destructObjectArray(self)  
         IMPLICIT NONE
         TYPE( FTMutableObjectArray) :: self
         CLASS(FTObject), POINTER     :: obj     => NULL()
         INTEGER                      :: i

         DO i = 1, self % count_
            obj => self % array(i) % object 
            IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj)
         END DO
         
         DEALLOCATE(self % array)
         self % array => NULL()
         self % count_ = 0  

      END SUBROUTINE destructObjectArray
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Add an object to the end of the array
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray)      :: array
!>       CLASS(FTObject)        , POINTER :: obj
!>       CLASS(FTObjectSubclass), POINTER :: p
!>       obj => p
!>       CALL array % addObject(obj)
!>
      SUBROUTINE addObjectToArray(self,obj)
         IMPLICIT NONE  
         CLASS(FTMutableObjectArray) :: self
         CLASS(FTObject), POINTER    :: obj

         self % count_ = self % count_ + 1

         IF ( self % count_ > SIZE(self % array) )     THEN
            CALL increaseArraysize( self, self % count_ ) 
         END IF 
         
         self % array(self % count_) %  object => obj
         CALL obj % retain()
         
      END SUBROUTINE addObjectToArray
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Remove an object at the index indx
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: indx
!>       CALL array % removeObjectAtIndex(indx)
!>
      SUBROUTINE removeObjectAtIndex(self,indx)  
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMutableObjectArray) :: self
         INTEGER                     :: indx
!
!        ---------------
!        Local variables
!        ---------------
!
         INTEGER                     :: i
         CLASS(FTObject), POINTER    :: obj  => NULL()
         
         obj => self % array(indx) %  object
         
         IF ( ASSOCIATED(obj) )     THEN
            CALL releaseFTObject(self = obj)
         END IF 
         
         DO i = indx, self % count_-1
            self % array(i) % object => self % array(i+1) % object
         END DO
         self % array(self % count_) % object => NULL()
         self % count_                        = self % count_ - 1
         
      END SUBROUTINE removeObjectAtIndex
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Replace an object at the index indx
!>
!> Usage
!> -----
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: indx
!>       CALL array % replaceObjectAtIndexWithObject(indx)
!>
      SUBROUTINE replaceObjectAtIndexWithObject(self,indx,replacement)  
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMutableObjectArray) :: self
         INTEGER                     :: indx
         CLASS(FTObject), POINTER    :: replacement
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTObject), POINTER    :: obj => NULL()
         
         obj => self % array(indx) %  object
         
         CALL releaseFTObject(obj)
         
         self % array(indx) %  object => replacement
         CALL replacement % retain()
         
      END SUBROUTINE  replaceObjectAtIndexWithObject
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE printArray(self,iUnit)  
         IMPLICIT NONE  
         CLASS(FTMutableObjectArray) :: self
         INTEGER                     :: iUnit
         INTEGER                     :: i
         CLASS(FTObject), POINTER    :: obj => NULL()
         
         DO i = 1, self % count_
            obj => self % array(i) % object
            CALL obj % printDescription(iUnit)
         END DO  
      END SUBROUTINE printArray
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Access the object at the index indx
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: indx
!>       CLASS(FTObject), POINTER    :: obj
!>       obj => array % objectAtIndex(indx)
!>
      FUNCTION objectAtIndex(self,indx)  RESULT(obj)
         IMPLICIT NONE  
         CLASS(FTMutableObjectArray) :: self
         INTEGER                     :: indx
         CLASS(FTObject), POINTER    :: obj
         IF ( indx > self % count_ .OR. indx < 1)     THEN
            obj => NULL() 
         ELSE 
            obj => self % array(indx) % object
         END IF 
         
      END FUNCTION objectAtIndex
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE increaseArraySize( self, n )  
         IMPLICIT NONE 
!
!        ---------
!        Arguments
!        ---------
!
         CLASS( FTMutableObjectArray) :: self
         INTEGER                      :: n
!
!        ---------------
!        Local Variables
!        ---------------
!
         TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER :: newArray 
         INTEGER                                             :: i, m
         
         IF ( n <= SIZE(self % array) )     THEN
            RETURN 
         END IF 
         
         m = (n - SIZE(self % array))/self % chunkSize_ + 1
         ALLOCATE( newArray(SIZE(self % array) + m*self % chunkSize_) )
         
         DO i = 1,  SIZE(self % array)
            newArray(i) %  object => self % array(i) %  object
         END DO
         DO i = SIZE(self % array) + 1,  SIZE(newArray)
            newArray(i) %  object => NULL()
         END DO
         
         DEALLOCATE(self % array)
         self % array => newArray

      END SUBROUTINE increaseArraySize
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Set the number of items to be added when the array needs to be re-sized
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: sze = 42
!>       CALL array % setChunkSize(sze)
!>
      SUBROUTINE setChunkSize(self,chunkSize)  
         IMPLICIT NONE  
         CLASS( FTMutableObjectArray) :: self
         INTEGER              :: chunkSize
         
         self % chunkSize_ = chunkSize
         
      END SUBROUTINE setChunkSize
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Returns the number of items to be added when the array needs to be re-sized
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: sze
!>       sze =  array % chunkSize
!>
      INTEGER FUNCTION chunkSize(self)  
         IMPLICIT NONE  
         CLASS( FTMutableObjectArray) :: self
         chunkSize = self % chunkSize_
      END FUNCTION chunkSize
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>
!> Generic name: count
!>
!> Returns the actual number of items in the array. 
!>
!> *Usage
!>
!>       CLASS(FTMutableObjectArray) :: array
!>       INTEGER                     :: sze
!>       sze =  array % count()
!>
      INTEGER FUNCTION numberOfItems(self)  
         IMPLICIT NONE  
         CLASS( FTMutableObjectArray) :: self
         numberOfItems = self % count_
      END FUNCTION numberOfItems
!
!//////////////////////////////////////////////////////////////////////// 
! 
      INTEGER FUNCTION allocatedSize(self)  
         IMPLICIT NONE  
         CLASS( FTMutableObjectArray) :: self
         IF ( ASSOCIATED(self % array) )     THEN
            allocatedSize = SIZE(self % array)
         ELSE
            allocatedSize = 0
         END IF 
      END FUNCTION allocatedSize
!
!---------------------------------------------------------------------------
!> Generic Name: cast
!> 
!> Cast a pointer to the base class to an FTMutableObjectArray pointer 
!---------------------------------------------------------------------------
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION objectArrayFromObject(obj) RESULT(cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the FTException class
!     -----------------------------------------------------
!
         IMPLICIT NONE  
         CLASS(FTObject)            , POINTER :: obj
         CLASS(FTMutableObjectArray), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTMutableObjectArray)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END FUNCTION objectArrayFromObject
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE castToMutableObjectArray(obj,cast) 
!
!     --------------------------------------------------------------
!     Cast the base class FTObject to the FTMutableObjectArray class
!     --------------------------------------------------------------
!
         IMPLICIT NONE  
         CLASS(FTObject)            , POINTER :: obj
         CLASS(FTMutableObjectArray), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTMutableObjectArray)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END SUBROUTINE castToMutableObjectArray
!
!//////////////////////////////////////////////////////////////////////// 
! 
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTMutableObjectArray")
!>
      FUNCTION arrayClassName(self)  RESULT(s)
         IMPLICIT NONE  
         CLASS(FTMutableObjectArray)                :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
         
         IF(self % COUNT() .ge. 0) CONTINUE 
         s = "FTMutableObjectArray"
 
      END FUNCTION arrayClassName

      
      END Module  FTMutableObjectArrayClass    

1	! MIT License
2	!
3	! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
4	!
5	! Permission is hereby granted, free of charge, to any person obtaining a copy
6	! of this software and associated documentation files (the "Software"), to deal
7	! in the Software without restriction, including without limitation the rights
8	! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9	! copies of the Software, and to permit persons to whom the Software is
10	! furnished to do so, subject to the following conditions:
11	!
12	! The above copyright notice and this permission notice shall be included in all
13	! copies or substantial portions of the Software.
14	!
15	! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16	! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17	! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18	! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19	! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20	! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21	! SOFTWARE.
22	!
23	! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
24	! public domain software:
25	! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
26	! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
27	!
28	! --- End License
29
30	!
31	!////////////////////////////////////////////////////////////////////////
32	!
33	! FTMutableObjectArray.f90
34	! Created: February 7, 2013 3:24 PM
35	! By: David Kopriva
36	!
37	!>FTMutableObjectArray is a mutable array class to which objects
38	!>can be added, removed, replaced and accessed according to their
39	!>index in the array.
40	!>
41	!>Fortran has pointers to arrays, but not arrays of pointers. To do the latter, one creates
42	!>a wrapper derived type and creates an array of that wrapper type. Fortran arrays are great, but
43	!>they are of fixed length, and they don't easily implement reference counting to keep track of
44	!>memory. For that, we have the FTMutableObjectArray. Performance reasons dictate that you
45	!>will use regular arrays for numeric types and the like, but for generic objects we would use
46	!>an Object Array.
47	!>
48	!>You initialize a FTMutableObjectArray with the number of objects that you expect it to hold.
49	!>However, it can re-size itself if necessary. To be efficient, it adds more than one entry at a time
50	!>given by the ``chunkSize'', which you can choose for yourself. (The default is 10.)
51	!>##Definition
52	!> TYPE(FTMutableObjectArray) :: array
53	!>#Usage
54	!>##Initialization
55	!> CLASS(FTMutableObjectArray) :: array
56	!> INTEGER :: N = 11
57	!> CALL array % initWithSize(N)
58	!>#Destruction
59	!> CALL array % destuct() [Non Pointers]
60	!> call releaseFTMutableObjectArray(array) [Pointers]
61	!>#Adding an Object
62	!> TYPE(FTObject) :: obj
63	!> obj => r1
64	!> CALL array % addObject(obj)
65	!>#Removing an Object
66	!> TYPE(FTObject) :: obj
67	!> CALL array % removeObjectAtIndex(i)
68	!>#Accessing an Object
69	!> TYPE(FTObject) :: obj
70	!> obj => array % objectAtIndex(i)
71	!>#Replacing an Object
72	!> TYPE(FTObject) :: obj
73	!> obj => r1
74	!> CALL array % replaceObjectAtIndexWithObject(i,obj)
75	!>#Setting the Chunk Size
76	!> CALL array % setChunkSize(size)
77	!>#Finding The Number Of Items In The Array
78	!> n = array % count()
79	!>#Finding The Actual Allocated Size Of The Array
80	!> n = array % allocatedSize()
81
82	!
83	!////////////////////////////////////////////////////////////////////////
84	!
85	MODULE FTMutableObjectArrayClass
86	USE FTObjectClass
87	IMPLICIT NONE
88
89	TYPE FTObjectPointerWrapper
90	CLASS(FTObject), POINTER :: object => NULL()
91	END TYPE FTObjectPointerWrapper
92
93	PRIVATE :: FTObjectPointerWrapper
94	PRIVATE :: increaseArraysize
95
96	TYPE, EXTENDS(FTObject) :: FTMutableObjectArray
97	INTEGER , PRIVATE :: count_
98	TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER, PRIVATE :: array => NULL()
99	INTEGER , PRIVATE :: chunkSize_ = 10
100	!
101	! --------
102	CONTAINS
103	! --------
104	!
105	PROCEDURE, PUBLIC :: initWithSize => initObjectArrayWithSize
106	FINAL :: destructObjectArray
107	PROCEDURE, PUBLIC :: addObject => addObjectToArray
108	PROCEDURE, PUBLIC :: replaceObjectAtIndexWithObject
109	PROCEDURE, PUBLIC :: removeObjectAtIndex
110	PROCEDURE, PUBLIC :: objectAtIndex
111
112	PROCEDURE, PUBLIC :: printDescription => printArray
113	PROCEDURE, PUBLIC :: className => arrayClassName
114	!
115	PROCEDURE, PUBLIC :: setChunkSize
116	PROCEDURE, PUBLIC :: chunkSize
117	PROCEDURE, PUBLIC :: COUNT => numberOfItems
118	PROCEDURE, PUBLIC :: allocatedSize
119
120	END TYPE
121
122	INTERFACE cast
123	MODULE PROCEDURE castToMutableObjectArray
124	END INTERFACE cast
125	!
126	! ========
127	CONTAINS
128	! ========
129	!
130	!
131	!////////////////////////////////////////////////////////////////////////
132	!
133	!>
134	!> Designated initializer. Initializes the amount of storage, but
135	!> the array remains empty.
136	!>
137	!> *Usage
138	!>
139	!> CLASS(FTMutableObjectArray) :: array
140	!> integer :: N = 11
141	!> CALL array % initWithSize(N)
142	!>
143	SUBROUTINE initObjectArrayWithSize( self, arraySize )	3✔
144	IMPLICIT NONE
145	CLASS( FTMutableObjectArray) :: self
146	INTEGER :: arraySize
147	INTEGER :: i
148
149	CALL self % FTObject % init()	3✔
150
151	ALLOCATE( self % array(arraySize) )	27✔
152
153	DO i = 1, arraySize	27✔
154	self % array(i) % object => NULL()	27✔
155	END DO
156	self % count_ = 0	3✔
157
158	END SUBROUTINE initObjectArrayWithSize	3✔
159	!
160	!////////////////////////////////////////////////////////////////////////
161	!
162	SUBROUTINE releaseFTMutableObjectArray(self)	3✔
163	IMPLICIT NONE
164	TYPE(FTMutableObjectArray), POINTER :: self
165	CLASS(FTObject) , POINTER :: obj
166
167	IF(.NOT. ASSOCIATED(self)) RETURN	3✔
168
169	obj => self	3✔
170	CALL release(obj)	3✔
171	IF(.NOT.ASSOCIATED(obj)) self => NULL()	3✔
172	END SUBROUTINE releaseFTMutableObjectArray
173	!
174	!////////////////////////////////////////////////////////////////////////
175	!
NEW 176	SUBROUTINE releaseFTMutableObjectArrayClass(self)	×
177	IMPLICIT NONE
178	CLASS(FTMutableObjectArray), POINTER :: self
179	CLASS(FTObject) , POINTER :: obj
180
NEW 181	IF(.NOT. ASSOCIATED(self)) RETURN	×
182
NEW 183	obj => self	×
NEW 184	CALL release(obj)	×
NEW 185	IF(.NOT.ASSOCIATED(obj)) self => NULL()	×
186	END SUBROUTINE releaseFTMutableObjectArrayClass
187	!
188	!////////////////////////////////////////////////////////////////////////
189	!
190	!>
191	!> Destructor for the class. This is called automatically when the
192	!> reference count reaches zero. Do not call this yourself.
193	!>
194	RECURSIVE SUBROUTINE destructObjectArray(self)	3✔
195	IMPLICIT NONE
196	TYPE( FTMutableObjectArray) :: self
197	CLASS(FTObject), POINTER :: obj => NULL()
198	INTEGER :: i
199
200	DO i = 1, self % count_	27✔
201	obj => self % array(i) % object	24✔
202	IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj)	27✔
203	END DO
204
205	DEALLOCATE(self % array)	3✔
206	self % array => NULL()	3✔
207	self % count_ = 0	3✔
208
209	END SUBROUTINE destructObjectArray	3✔
210	!
211	!////////////////////////////////////////////////////////////////////////
212	!
213	!>
214	!> Add an object to the end of the array
215	!>
216	!> *Usage
217	!>
218	!> CLASS(FTMutableObjectArray) :: array
219	!> CLASS(FTObject) , POINTER :: obj
220	!> CLASS(FTObjectSubclass), POINTER :: p
221	!> obj => p
222	!> CALL array % addObject(obj)
223	!>
224	SUBROUTINE addObjectToArray(self,obj)	25✔
225	IMPLICIT NONE
226	CLASS(FTMutableObjectArray) :: self
227	CLASS(FTObject), POINTER :: obj
228
229	self % count_ = self % count_ + 1	25✔
230
231	IF ( self % count_ > SIZE(self % array) ) THEN	25✔
232	CALL increaseArraysize( self, self % count_ )	1✔
233	END IF
234
235	self % array(self % count_) % object => obj	25✔
236	CALL obj % retain()	25✔
237
238	END SUBROUTINE addObjectToArray	25✔
239	!
240	!////////////////////////////////////////////////////////////////////////
241	!
242	!>
243	!> Remove an object at the index indx
244	!>
245	!> *Usage
246	!>
247	!> CLASS(FTMutableObjectArray) :: array
248	!> INTEGER :: indx
249	!> CALL array % removeObjectAtIndex(indx)
250	!>
251	SUBROUTINE removeObjectAtIndex(self,indx)	1✔
252	IMPLICIT NONE
253	!
254	! ---------
255	! Arguments
256	! ---------
257	!
258	CLASS(FTMutableObjectArray) :: self
259	INTEGER :: indx
260	!
261	! ---------------
262	! Local variables
263	! ---------------
264	!
265	INTEGER :: i
266	CLASS(FTObject), POINTER :: obj => NULL()
267
268	obj => self % array(indx) % object	1✔
269
270	IF ( ASSOCIATED(obj) ) THEN	1✔
271	CALL releaseFTObject(self = obj)	1✔
272	END IF
273
274	DO i = indx, self % count_-1	4✔
275	self % array(i) % object => self % array(i+1) % object	4✔
276	END DO
277	self % array(self % count_) % object => NULL()	1✔
278	self % count_ = self % count_ - 1	1✔
279
280	END SUBROUTINE removeObjectAtIndex	1✔
281	!
282	!////////////////////////////////////////////////////////////////////////
283	!
284	!>
285	!> Replace an object at the index indx
286	!>
287	!> Usage
288	!> -----
289	!>
290	!> CLASS(FTMutableObjectArray) :: array
291	!> INTEGER :: indx
292	!> CALL array % replaceObjectAtIndexWithObject(indx)
293	!>
294	SUBROUTINE replaceObjectAtIndexWithObject(self,indx,replacement)	1✔
295	IMPLICIT NONE
296	!
297	! ---------
298	! Arguments
299	! ---------
300	!
301	CLASS(FTMutableObjectArray) :: self
302	INTEGER :: indx
303	CLASS(FTObject), POINTER :: replacement
304	!
305	! ---------------
306	! Local variables
307	! ---------------
308	!
309	CLASS(FTObject), POINTER :: obj => NULL()
310
311	obj => self % array(indx) % object	1✔
312
313	CALL releaseFTObject(obj)	1✔
314
315	self % array(indx) % object => replacement	1✔
316	CALL replacement % retain()	1✔
317
318	END SUBROUTINE replaceObjectAtIndexWithObject	1✔
319	!
320	!////////////////////////////////////////////////////////////////////////
321	!
322	SUBROUTINE printArray(self,iUnit)	1✔
323	IMPLICIT NONE
324	CLASS(FTMutableObjectArray) :: self
325	INTEGER :: iUnit
326	INTEGER :: i
327	CLASS(FTObject), POINTER :: obj => NULL()
328
329	DO i = 1, self % count_	11✔
330	obj => self % array(i) % object	10✔
331	CALL obj % printDescription(iUnit)	11✔
332	END DO
333	END SUBROUTINE printArray	1✔
334	!
335	!////////////////////////////////////////////////////////////////////////
336	!
337	!>
338	!> Access the object at the index indx
339	!>
340	!> *Usage
341	!>
342	!> CLASS(FTMutableObjectArray) :: array
343	!> INTEGER :: indx
344	!> CLASS(FTObject), POINTER :: obj
345	!> obj => array % objectAtIndex(indx)
346	!>
347	FUNCTION objectAtIndex(self,indx) RESULT(obj)	46✔
348	IMPLICIT NONE
349	CLASS(FTMutableObjectArray) :: self
350	INTEGER :: indx
351	CLASS(FTObject), POINTER :: obj
352	IF ( indx > self % count_ .OR. indx < 1) THEN	46✔
353	obj => NULL()	×
354	ELSE
355	obj => self % array(indx) % object	46✔
356	END IF
357
358	END FUNCTION objectAtIndex	46✔
359	!
360	!////////////////////////////////////////////////////////////////////////
361	!
362	SUBROUTINE increaseArraySize( self, n )	1✔
363	IMPLICIT NONE
364	!
365	! ---------
366	! Arguments
367	! ---------
368	!
369	CLASS( FTMutableObjectArray) :: self
370	INTEGER :: n
371	!
372	! ---------------
373	! Local Variables
374	! ---------------
375	!
376	TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER :: newArray	1✔
377	INTEGER :: i, m
378
379	IF ( n <= SIZE(self % array) ) THEN	1✔
380	RETURN	×
381	END IF
382
383	m = (n - SIZE(self % array))/self % chunkSize_ + 1	1✔
384	ALLOCATE( newArray(SIZE(self % array) + m*self % chunkSize_) )	21✔
385
386	DO i = 1, SIZE(self % array)	11✔
387	newArray(i) % object => self % array(i) % object	11✔
388	END DO
389	DO i = SIZE(self % array) + 1, SIZE(newArray)	11✔
390	newArray(i) % object => NULL()	11✔
391	END DO
392
393	DEALLOCATE(self % array)	1✔
394	self % array => newArray	1✔
395
396	END SUBROUTINE increaseArraySize	1✔
397	!
398	!////////////////////////////////////////////////////////////////////////
399	!
400	!>
401	!> Set the number of items to be added when the array needs to be re-sized
402	!>
403	!> *Usage
404	!>
405	!> CLASS(FTMutableObjectArray) :: array
406	!> INTEGER :: sze = 42
407	!> CALL array % setChunkSize(sze)
408	!>
409	SUBROUTINE setChunkSize(self,chunkSize)	2✔
410	IMPLICIT NONE
411	CLASS( FTMutableObjectArray) :: self
412	INTEGER :: chunkSize
413
414	self % chunkSize_ = chunkSize	2✔
415
416	END SUBROUTINE setChunkSize	2✔
417	!
418	!////////////////////////////////////////////////////////////////////////
419	!
420	!>
421	!> Returns the number of items to be added when the array needs to be re-sized
422	!>
423	!> *Usage
424	!>
425	!> CLASS(FTMutableObjectArray) :: array
426	!> INTEGER :: sze
427	!> sze = array % chunkSize
428	!>
429	INTEGER FUNCTION chunkSize(self)	1✔
430	IMPLICIT NONE
431	CLASS( FTMutableObjectArray) :: self
432	chunkSize = self % chunkSize_	1✔
433	END FUNCTION chunkSize	1✔
434	!
435	!////////////////////////////////////////////////////////////////////////
436	!
437	!>
438	!> Generic name: count
439	!>
440	!> Returns the actual number of items in the array.
441	!>
442	!> *Usage
443	!>
444	!> CLASS(FTMutableObjectArray) :: array
445	!> INTEGER :: sze
446	!> sze = array % count()
447	!>
448	INTEGER FUNCTION numberOfItems(self)	10✔
449	IMPLICIT NONE
450	CLASS( FTMutableObjectArray) :: self
451	numberOfItems = self % count_	10✔
452	END FUNCTION numberOfItems	10✔
453	!
454	!////////////////////////////////////////////////////////////////////////
455	!
456	INTEGER FUNCTION allocatedSize(self)	1✔
457	IMPLICIT NONE
458	CLASS( FTMutableObjectArray) :: self
459	IF ( ASSOCIATED(self % array) ) THEN	1✔
460	allocatedSize = SIZE(self % array)	1✔
461	ELSE
462	allocatedSize = 0	×
463	END IF
464	END FUNCTION allocatedSize	1✔
465	!
466	!---------------------------------------------------------------------------
467	!> Generic Name: cast
468	!>
469	!> Cast a pointer to the base class to an FTMutableObjectArray pointer
470	!---------------------------------------------------------------------------
471	!
472	!////////////////////////////////////////////////////////////////////////
473	!
474	FUNCTION objectArrayFromObject(obj) RESULT(cast)	1✔
475	!
476	! -----------------------------------------------------
477	! Cast the base class FTObject to the FTException class
478	! -----------------------------------------------------
479	!
480	IMPLICIT NONE
481	CLASS(FTObject) , POINTER :: obj
482	CLASS(FTMutableObjectArray), POINTER :: cast
483
484	cast => NULL()	1✔
485	SELECT TYPE (e => obj)
486	TYPE is (FTMutableObjectArray)
487	cast => e	1✔
488	CLASS DEFAULT
489
490	END SELECT
491
492	END FUNCTION objectArrayFromObject	1✔
493	!
494	!////////////////////////////////////////////////////////////////////////
495	!
496	SUBROUTINE castToMutableObjectArray(obj,cast)	1✔
497	!
498	! --------------------------------------------------------------
499	! Cast the base class FTObject to the FTMutableObjectArray class
500	! --------------------------------------------------------------
501	!
502	IMPLICIT NONE
503	CLASS(FTObject) , POINTER :: obj
504	CLASS(FTMutableObjectArray), POINTER :: cast
505
506	cast => NULL()	1✔
507	SELECT TYPE (e => obj)
508	TYPE is (FTMutableObjectArray)
509	cast => e	1✔
510	CLASS DEFAULT
511
512	END SELECT
513
514	END SUBROUTINE castToMutableObjectArray	1✔
515	!
516	!////////////////////////////////////////////////////////////////////////
517	!
518	! -----------------------------------------------------------------
519	!> Class name returns a string with the name of the type of the object
520	!>
521	!> ### Usage:
522	!>
523	!> PRINT *, obj % className()
524	!> if( obj % className = "FTMutableObjectArray")
525	!>
526	FUNCTION arrayClassName(self) RESULT(s)	1✔
527	IMPLICIT NONE
528	CLASS(FTMutableObjectArray) :: self
529	CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
530
531	IF(self % COUNT() .ge. 0) CONTINUE	1✔
532	s = "FTMutableObjectArray"	1✔
533
534	END FUNCTION arrayClassName	1✔
535
536
537	END Module FTMutableObjectArrayClass	7✔

trixi-framework / FTObjectLibrary / 30287542962

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous