30618293163

Committed 31 Jul 2026 08:59AM UTC coverage: 93.676% (-0.9%) from 94.58%

Build # 30618293163

Build Type

push

github

Committed by

web-flow

Commit Message

Type mods2 (#79)

* Add Class Releases

Distinguish between type and class dummy arguments

* Linked List mods

Allow either a class or type to be added to a linked list iterator,

* LinkedList Coverage

Increase coverage on linked list class

* Increase Coverage

Remove asn unneeded class version in FTDictionaryClass. Add test for class version of release in MultiIndexTable

* Update LinkedListTests.f90

cover unused add null to iterator

* Update FTObjectArrayClass.f90

Make a change to test HOHQMesh ifx error

* Update FTObjectArrayClass.f90

Put deallocation back in

* Update FTObjectArrayClass.f90

Add TODO on location of problem with ifx compiler.

* Restore ObjectArray plus bug fix

Restore FTMultableObjectArray deallocation procedure. Plus, found a bug where if a linked list didn't have any items in it, it's status as circular or not could be changed.

* Update UsersGuide.md

Now distinguishes between objects defined by TYPE and those defined by CLASS

* attempt to add ifx to CI

* deactiavte coverage in all but one Ubuntu test

* add valgrind tests and adjust coverage reporting

* Update News.md

Add news about Class/type distinction

* fix valgrind tests

* gate regular versus valgrind jobs

* typo fix

---------

Co-authored-by: Andrew Winters <andrew.ross.winters@liu.se>

Coverage Stats

123 of 141 new or added lines in 18 files covered. (87.23%)

16 existing lines in 4 files now uncovered.

2770 of 2957 relevant lines covered (93.68%)

14.8 hits per line

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

91.67

/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(obj)
         END DO
         
         IF(ASSOCIATED(self % array)) 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	obj => self	3✔
169	CALL release(obj)	3✔
170	IF(.NOT.ASSOCIATED(obj)) self => NULL()	3✔
171	END SUBROUTINE releaseFTMutableObjectArray
172	!
173	!////////////////////////////////////////////////////////////////////////
174	!
NEW 175	SUBROUTINE releaseFTMutableObjectArrayClass(self)	×
176	IMPLICIT NONE
177	CLASS(FTMutableObjectArray), POINTER :: self
178	CLASS(FTObject) , POINTER :: obj
179
NEW 180	IF(.NOT. ASSOCIATED(self)) RETURN	×
181
NEW 182	obj => self	×
NEW 183	CALL release(obj)	×
NEW 184	IF(.NOT.ASSOCIATED(obj)) self => NULL()	×
185	END SUBROUTINE releaseFTMutableObjectArrayClass
186	!
187	!////////////////////////////////////////////////////////////////////////
188	!
189	!>
190	!> Destructor for the class. This is called automatically when the
191	!> reference count reaches zero. Do not call this yourself.
192	!>
193	RECURSIVE SUBROUTINE destructObjectArray(self)	3✔
194	IMPLICIT NONE
195	TYPE( FTMutableObjectArray) :: self
196	CLASS(FTObject), POINTER :: obj => NULL()
197	INTEGER :: i
198
199	DO i = 1, self % count_	27✔
200	obj => self % array(i) % object	24✔
201	IF ( ASSOCIATED(obj) ) CALL releaseFTObject(obj)	27✔
202	END DO
203
204	IF(ASSOCIATED(self % array)) DEALLOCATE(self % array)	3✔
205	self % array => NULL()	3✔
206	self % count_ = 0	3✔
207
208	END SUBROUTINE destructObjectArray	3✔
209	!
210	!////////////////////////////////////////////////////////////////////////
211	!
212	!>
213	!> Add an object to the end of the array
214	!>
215	!> *Usage
216	!>
217	!> CLASS(FTMutableObjectArray) :: array
218	!> CLASS(FTObject) , POINTER :: obj
219	!> CLASS(FTObjectSubclass), POINTER :: p
220	!> obj => p
221	!> CALL array % addObject(obj)
222	!>
223	SUBROUTINE addObjectToArray(self,obj)	25✔
224	IMPLICIT NONE
225	CLASS(FTMutableObjectArray) :: self
226	CLASS(FTObject), POINTER :: obj
227
228	self % count_ = self % count_ + 1	25✔
229
230	IF ( self % count_ > SIZE(self % array) ) THEN	25✔
231	CALL increaseArraysize( self, self % count_ )	1✔
232	END IF
233
234	self % array(self % count_) % object => obj	25✔
235	CALL obj % retain()	25✔
236
237	END SUBROUTINE addObjectToArray	25✔
238	!
239	!////////////////////////////////////////////////////////////////////////
240	!
241	!>
242	!> Remove an object at the index indx
243	!>
244	!> *Usage
245	!>
246	!> CLASS(FTMutableObjectArray) :: array
247	!> INTEGER :: indx
248	!> CALL array % removeObjectAtIndex(indx)
249	!>
250	SUBROUTINE removeObjectAtIndex(self,indx)	1✔
251	IMPLICIT NONE
252	!
253	! ---------
254	! Arguments
255	! ---------
256	!
257	CLASS(FTMutableObjectArray) :: self
258	INTEGER :: indx
259	!
260	! ---------------
261	! Local variables
262	! ---------------
263	!
264	INTEGER :: i
265	CLASS(FTObject), POINTER :: obj => NULL()
266
267	obj => self % array(indx) % object	1✔
268
269	IF ( ASSOCIATED(obj) ) THEN	1✔
270	CALL releaseFTObject(self = obj)	1✔
271	END IF
272
273	DO i = indx, self % count_-1	4✔
274	self % array(i) % object => self % array(i+1) % object	4✔
275	END DO
276	self % array(self % count_) % object => NULL()	1✔
277	self % count_ = self % count_ - 1	1✔
278
279	END SUBROUTINE removeObjectAtIndex	1✔
280	!
281	!////////////////////////////////////////////////////////////////////////
282	!
283	!>
284	!> Replace an object at the index indx
285	!>
286	!> Usage
287	!> -----
288	!>
289	!> CLASS(FTMutableObjectArray) :: array
290	!> INTEGER :: indx
291	!> CALL array % replaceObjectAtIndexWithObject(indx)
292	!>
293	SUBROUTINE replaceObjectAtIndexWithObject(self,indx,replacement)	1✔
294	IMPLICIT NONE
295	!
296	! ---------
297	! Arguments
298	! ---------
299	!
300	CLASS(FTMutableObjectArray) :: self
301	INTEGER :: indx
302	CLASS(FTObject), POINTER :: replacement
303	!
304	! ---------------
305	! Local variables
306	! ---------------
307	!
308	CLASS(FTObject), POINTER :: obj => NULL()
309
310	obj => self % array(indx) % object	1✔
311
312	CALL releaseFTObject(obj)	1✔
313
314	self % array(indx) % object => replacement	1✔
315	CALL replacement % retain()	1✔
316
317	END SUBROUTINE replaceObjectAtIndexWithObject	1✔
318	!
319	!////////////////////////////////////////////////////////////////////////
320	!
321	SUBROUTINE printArray(self,iUnit)	1✔
322	IMPLICIT NONE
323	CLASS(FTMutableObjectArray) :: self
324	INTEGER :: iUnit
325	INTEGER :: i
326	CLASS(FTObject), POINTER :: obj => NULL()
327
328	DO i = 1, self % count_	11✔
329	obj => self % array(i) % object	10✔
330	CALL obj % printDescription(iUnit)	11✔
331	END DO
332	END SUBROUTINE printArray	1✔
333	!
334	!////////////////////////////////////////////////////////////////////////
335	!
336	!>
337	!> Access the object at the index indx
338	!>
339	!> *Usage
340	!>
341	!> CLASS(FTMutableObjectArray) :: array
342	!> INTEGER :: indx
343	!> CLASS(FTObject), POINTER :: obj
344	!> obj => array % objectAtIndex(indx)
345	!>
346	FUNCTION objectAtIndex(self,indx) RESULT(obj)	46✔
347	IMPLICIT NONE
348	CLASS(FTMutableObjectArray) :: self
349	INTEGER :: indx
350	CLASS(FTObject), POINTER :: obj
351	IF ( indx > self % count_ .OR. indx < 1) THEN	46✔
352	obj => NULL()	×
353	ELSE
354	obj => self % array(indx) % object	46✔
355	END IF
356
357	END FUNCTION objectAtIndex	46✔
358	!
359	!////////////////////////////////////////////////////////////////////////
360	!
361	SUBROUTINE increaseArraySize( self, n )	1✔
362	IMPLICIT NONE
363	!
364	! ---------
365	! Arguments
366	! ---------
367	!
368	CLASS( FTMutableObjectArray) :: self
369	INTEGER :: n
370	!
371	! ---------------
372	! Local Variables
373	! ---------------
374	!
375	TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER :: newArray
376	INTEGER :: i, m
377
378	IF ( n <= SIZE(self % array) ) THEN	1✔
379	RETURN	×
380	END IF
381
382	m = (n - SIZE(self % array))/self % chunkSize_ + 1	1✔
383	ALLOCATE( newArray(SIZE(self % array) + m*self % chunkSize_) )	21✔
384
385	DO i = 1, SIZE(self % array)	11✔
386	newArray(i) % object => self % array(i) % object	11✔
387	END DO
388	DO i = SIZE(self % array) + 1, SIZE(newArray)	11✔
389	newArray(i) % object => NULL()	11✔
390	END DO
391
392	DEALLOCATE(self % array)	1✔
393	self % array => newArray	1✔
394
395	END SUBROUTINE increaseArraySize	1✔
396	!
397	!////////////////////////////////////////////////////////////////////////
398	!
399	!>
400	!> Set the number of items to be added when the array needs to be re-sized
401	!>
402	!> *Usage
403	!>
404	!> CLASS(FTMutableObjectArray) :: array
405	!> INTEGER :: sze = 42
406	!> CALL array % setChunkSize(sze)
407	!>
408	SUBROUTINE setChunkSize(self,chunkSize)	2✔
409	IMPLICIT NONE
410	CLASS( FTMutableObjectArray) :: self
411	INTEGER :: chunkSize
412
413	self % chunkSize_ = chunkSize	2✔
414
415	END SUBROUTINE setChunkSize	2✔
416	!
417	!////////////////////////////////////////////////////////////////////////
418	!
419	!>
420	!> Returns the number of items to be added when the array needs to be re-sized
421	!>
422	!> *Usage
423	!>
424	!> CLASS(FTMutableObjectArray) :: array
425	!> INTEGER :: sze
426	!> sze = array % chunkSize
427	!>
428	INTEGER FUNCTION chunkSize(self)	1✔
429	IMPLICIT NONE
430	CLASS( FTMutableObjectArray) :: self
431	chunkSize = self % chunkSize_	1✔
432	END FUNCTION chunkSize	1✔
433	!
434	!////////////////////////////////////////////////////////////////////////
435	!
436	!>
437	!> Generic name: count
438	!>
439	!> Returns the actual number of items in the array.
440	!>
441	!> *Usage
442	!>
443	!> CLASS(FTMutableObjectArray) :: array
444	!> INTEGER :: sze
445	!> sze = array % count()
446	!>
447	INTEGER FUNCTION numberOfItems(self)	10✔
448	IMPLICIT NONE
449	CLASS( FTMutableObjectArray) :: self
450	numberOfItems = self % count_	10✔
451	END FUNCTION numberOfItems	10✔
452	!
453	!////////////////////////////////////////////////////////////////////////
454	!
455	INTEGER FUNCTION allocatedSize(self)	1✔
456	IMPLICIT NONE
457	CLASS( FTMutableObjectArray) :: self
458	IF ( ASSOCIATED(self % array) ) THEN	1✔
459	allocatedSize = SIZE(self % array)	1✔
460	ELSE
461	allocatedSize = 0	×
462	END IF
463	END FUNCTION allocatedSize	1✔
464	!
465	!---------------------------------------------------------------------------
466	!> Generic Name: cast
467	!>
468	!> Cast a pointer to the base class to an FTMutableObjectArray pointer
469	!---------------------------------------------------------------------------
470	!
471	!////////////////////////////////////////////////////////////////////////
472	!
473	FUNCTION objectArrayFromObject(obj) RESULT(cast)	1✔
474	!
475	! -----------------------------------------------------
476	! Cast the base class FTObject to the FTException class
477	! -----------------------------------------------------
478	!
479	IMPLICIT NONE
480	CLASS(FTObject) , POINTER :: obj
481	CLASS(FTMutableObjectArray), POINTER :: cast
482
483	cast => NULL()	1✔
484	SELECT TYPE (e => obj)
485	TYPE is (FTMutableObjectArray)
486	cast => e	1✔
487	CLASS DEFAULT
488
489	END SELECT
490
491	END FUNCTION objectArrayFromObject	1✔
492	!
493	!////////////////////////////////////////////////////////////////////////
494	!
495	SUBROUTINE castToMutableObjectArray(obj,cast)	1✔
496	!
497	! --------------------------------------------------------------
498	! Cast the base class FTObject to the FTMutableObjectArray class
499	! --------------------------------------------------------------
500	!
501	IMPLICIT NONE
502	CLASS(FTObject) , POINTER :: obj
503	CLASS(FTMutableObjectArray), POINTER :: cast
504
505	cast => NULL()	1✔
506	SELECT TYPE (e => obj)
507	TYPE is (FTMutableObjectArray)
508	cast => e	1✔
509	CLASS DEFAULT
510
511	END SELECT
512
513	END SUBROUTINE castToMutableObjectArray	1✔
514	!
515	!////////////////////////////////////////////////////////////////////////
516	!
517	! -----------------------------------------------------------------
518	!> Class name returns a string with the name of the type of the object
519	!>
520	!> ### Usage:
521	!>
522	!> PRINT *, obj % className()
523	!> if( obj % className = "FTMutableObjectArray")
524	!>
525	FUNCTION arrayClassName(self) RESULT(s)	1✔
526	IMPLICIT NONE
527	CLASS(FTMutableObjectArray) :: self
528	CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
529
530	IF(self % COUNT() .ge. 0) CONTINUE	1✔
531	s = "FTMutableObjectArray"	1✔
532
533	END FUNCTION arrayClassName	1✔
534
535
536	END Module FTMutableObjectArrayClass	2✔

trixi-framework / FTObjectLibrary / 30618293163

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