30206241592

Committed 26 Jul 2026 02:31PM UTC coverage: 92.391% (-2.2%) from 94.58%

Build # 30206241592

Build Type

Pull #79

github

Committed by

web-flow

Commit Message

Merge 79dc9ef6b into 58212d52c

Pull Request Pull Request #79: Type mods2

Coverage Stats

89 of 126 new or added lines in 17 files covered. (70.63%)

33 existing lines in 4 files now uncovered.

2732 of 2957 relevant lines covered (92.39%)

14.8 hits per line

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

81.89

/Source/FTObjects/FTMultiIndexTable.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

!
!////////////////////////////////////////////////////////////////////////
!
!      MultiIndexTableClass.f90
!      Created: July 29, 2013 10:59 AM 
!      By: David Kopriva  
!
!
!////////////////////////////////////////////////////////////////////////
!
      Module FTMultiIndexTableData 
      USE FTObjectClass
      IMPLICIT NONE
!
!     ---------------
!     Type definition
!     ---------------
!
      TYPE, EXTENDS(FTObject) :: MultiIndexMatrixData
         INTEGER        , ALLOCATABLE :: key(:)
         CLASS(FTObject), POINTER     :: object
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: initWithObjectAndKeys
         FINAL     :: destructMultiIndexMatrixData
         
      END TYPE MultiIndexMatrixData
      
      INTERFACE cast
         MODULE PROCEDURE castObjectToMultiIndexMatrixData
      END INTERFACE cast
      
!
!     ========      
      CONTAINS
!     ========
!
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE initWithObjectAndKeys(self,object,key)
!
!        ----------------------
!        Designated initializer
!        ----------------------
!
         IMPLICIT NONE
         CLASS(MultiIndexMatrixData) :: self
         CLASS(FTObject), POINTER    :: object
         INTEGER                     :: key(:)
         
         CALL self % FTObject % init()
         
         ALLOCATE(self % key(SIZE(key)))
         self % key = key
         self % object => object
         CALL self % object % retain()
         
      END SUBROUTINE initWithObjectAndKeys
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTMultiIndexMatrixData(self)  
         IMPLICIT NONE
         TYPE(MultiIndexMatrixData), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
        
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTMultiIndexMatrixData
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE destructMultiIndexMatrixData(self)
         IMPLICIT NONE  
         TYPE(MultiIndexMatrixData) :: self
         
         IF ( ASSOCIATED(self % object) ) CALL releaseFTObject(self % object )
         IF ( ALLOCATED(self % key) )     DEALLOCATE(self % key) 

      END SUBROUTINE destructMultiIndexMatrixData
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE castObjectToMultiIndexMatrixData(obj,cast)  
         IMPLICIT NONE  
!
!        -----------------------------------------------------
!        Cast the base class FTObject to the FTException class
!        -----------------------------------------------------
!
         CLASS(FTObject)  , POINTER :: obj
         CLASS(MultiIndexMatrixData), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (MultiIndexMatrixData)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END SUBROUTINE castObjectToMultiIndexMatrixData
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION MultiIndexMatrixDataCast(obj)  RESULT(cast)
         IMPLICIT NONE  
!
!        -----------------------------------------------------
!        Cast the base class FTObject to the FTException class
!        -----------------------------------------------------
!
         CLASS(FTObject)  , POINTER :: obj
         CLASS(MultiIndexMatrixData), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (MultiIndexMatrixData)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END FUNCTION MultiIndexMatrixDataCast
      
      END Module FTMultiIndexTableData
!@mark -
!>The MultiIndexTable stores an FTObject pointer associated
!>with any number of integer keys(:) as a hash table. 
!>
!>#Usage
!>## Definition (Subclass of FTObject)
!>
!>         TYPE(FTMultiIndexTable) :: multiIndexTable
!>
!>##Initialization
!>
!>         CALL MultiIndexTable % initWithSize(N)
!>
!>The size, N = the maximum value of all of the keys.
!>
!>## Destruction
!>
!>         CALL releaseFTMultiIndexTable(MultiIndexTable)     [Pointers]
!>
!>##Adding an object
!>
!>         CLASS(FTObject), POINTER :: obj
!>         INTEGER, DIMENSION(dim)  :: keys
!>         CALL MultiIndexTable % addObjectForKeys(obj,keys)
!>
!>##Retrieving an object
!>
!>         CLASS(FTObject), POINTER :: obj
!>         INTEGER, DIMENSION(dim)  :: keys
!>         obj => MultiIndexTable % objectForKeys(keys)
!>
!>Be sure to retain the object if you want it to live
!>      beyond the life of the table.
!>
!>##Testing the presence of keys
!>
!>         LOGICAL :: exists
!>         exists = MultiIndexTable % containsKeys(keys)
!
!////////////////////////////////////////////////////////////////////////
!
      Module FTMultiIndexTableClass
      USE FTObjectClass
      USE FTLinkedListClass
      USE FTMultiIndexTableData
      IMPLICIT NONE
!
!     ---------------------
!     Class type definition
!     ---------------------
!      
      TYPE, EXTENDS(FTObject) :: FTMultiIndexTable
         CLASS(FTLinkedList), DIMENSION(:), ALLOCATABLE :: table
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: initWithSize     => initMultiIndexTableWithSize
         FINAL     :: destructMultiIndexTable
         PROCEDURE :: containsKeys     => MultiIndexTableContainsKeys
         PROCEDURE :: addObjectForKeys => addObjectToMultiIndexTableForKeys
         PROCEDURE :: objectForKeys    => objectInMultiIndexTableForKeys
         PROCEDURE :: printDescription => printMultiIndexTableDescription
         PROCEDURE :: MultiIndexTableSize
         
      END TYPE FTMultiIndexTable
!
!     ========
      CONTAINS
!     ========
!
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE initMultiIndexTableWithSize(self,N)  
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMultiIndexTable) :: self
         INTEGER                  :: N
!
!        ---------------
!        Local variables
!        ---------------
!
         INTEGER :: j
         
         CALL self % FTObject % init()
         
         ALLOCATE(self % table(N))
         DO j = 1, N
            CALL self % table(j) % init()
         END DO
         
      END SUBROUTINE initMultiIndexTableWithSize
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTMultiIndexTable(self)  
         IMPLICIT NONE
         TYPE(FTMultiIndexTable), POINTER :: self
         CLASS(FTObject)        , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
        
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTMultiIndexTable
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTMultiIndexTableClass(self)  
         IMPLICIT NONE
         CLASS(FTMultiIndexTable), POINTER :: self
         CLASS(FTObject)         , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
        
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTMultiIndexTableClass
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE destructMultiIndexTable(self)
         IMPLICIT NONE  
!
!        ---------
!        Arguments
!        ---------
!
         TYPE(FTMultiIndexTable) :: self
!
!        ---------------
!        Local variables
!        ---------------
!         
         IF(ALLOCATED(self % table))   THEN
            DEALLOCATE(self % table)
         END IF
         
      END SUBROUTINE destructMultiIndexTable
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE addObjectToMultiIndexTableForKeys(self,obj,keys)
         IMPLICIT NONE  
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMultiIndexTable) :: self
         CLASS(FTObject), POINTER :: obj
         INTEGER                  :: keys(:)
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(MultiIndexMatrixData), POINTER :: mData
         CLASS(FTObject)            , POINTER :: ptr
         INTEGER                              :: i
         INTEGER                              :: orderedKeys(SIZE(keys))
         
         orderedKeys = keys
         CALL sortKeysAscending(orderedKeys)
         
         i = orderedKeys(1)
         IF ( .NOT.self % containsKeys(orderedKeys) )     THEN
            ALLOCATE(mData)
            CALL mData % initWithObjectAndKeys(obj,orderedKeys)
            ptr => mData
            
            CALL self % table(i) % add(ptr)
            CALL releaseFTObject(ptr)
         END IF 
         
      END SUBROUTINE addObjectToMultiIndexTableForKeys
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION objectInMultiIndexTableForKeys(self,keys) RESULT(r)
!
!     ---------------------------------------------------------------
!     Returns the stored FTObject for the keys (i,j). Returns NULL()
!     if the object isn't in the table. Retain the object if it needs
!     a strong reference by the caller.
!     ---------------------------------------------------------------
!
         IMPLICIT NONE  
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMultiIndexTable) :: self
         INTEGER                  :: keys(:)
         CLASS(FTObject), POINTER :: r
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(MultiIndexMatrixData)  , POINTER :: mData
         CLASS(FTObject)              , POINTER :: obj
         CLASS(FTLinkedListRecord)    , POINTER :: currentRecord
         INTEGER                                :: i
         INTEGER                                :: orderedKeys(SIZE(keys))
  
         orderedKeys = keys
         CALL sortKeysAscending(orderedKeys)
         
         r => NULL()
         i = orderedKeys(1)
         IF(.NOT.ALLOCATED(self % table))        RETURN 
         IF (  self % table(i) % COUNT() == 0 )  RETURN
!
!        ----------------------------
!        Step through the linked list
!        ----------------------------
!
         r => NULL()
         
         currentRecord => self % table(i) % head
         DO WHILE (ASSOCIATED(currentRecord))
         
            obj => currentRecord % recordObject
            CALL cast(obj,mData)
            IF ( keysMatch(key1 = mData % key,key2 = orderedKeys) )     THEN
               r => mData % object
               EXIT 
            END IF 
            
            currentRecord => currentRecord % next
         END DO

      END FUNCTION objectInMultiIndexTableForKeys
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION MultiIndexTableContainsKeys(self,keys)  RESULT(r)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTMultiIndexTable) :: self
         INTEGER                  :: keys(:)
         LOGICAL                  :: r
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTObject)              , POINTER :: obj
         CLASS(MultiIndexMatrixData)  , POINTER :: mData
         CLASS(FTLinkedListRecord)    , POINTER :: currentRecord
         INTEGER                                :: i
         INTEGER                                :: orderedKeys(SIZE(keys))

         orderedKeys = keys
         CALL sortKeysAscending(orderedKeys)
         
         r = .FALSE.
         i = orderedKeys(1)
         IF(.NOT.ALLOCATED(self % table))         RETURN 
         IF ( self % table(i) % COUNT() == 0 )    RETURN 
!
!        ----------------------------
!        Step through the linked list
!        ----------------------------
!
         currentRecord => self % table(i) % head
         DO WHILE (ASSOCIATED(currentRecord))
         
            obj => currentRecord % recordObject
            CALL cast(obj,mData)
            IF ( keysMatch(key1 = mData % key,key2 = orderedKeys))     THEN
               r = .TRUE.
               EXIT   
            END IF 
            
            currentRecord => currentRecord % next
         END DO
         
      END FUNCTION MultiIndexTableContainsKeys
!
!//////////////////////////////////////////////////////////////////////// 
! 
      INTEGER FUNCTION MultiIndexTableSize(self)  
         IMPLICIT NONE  
         CLASS(FTMultiIndexTable) :: self
         IF ( ALLOCATED(self % table) )     THEN
            MultiIndexTableSize =  SIZE(self % table)
         ELSE
            MultiIndexTableSize = 0
         END IF 
      END FUNCTION MultiIndexTableSize
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION MultiIndexTableFromObject(obj) RESULT(cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the FTException class
!     -----------------------------------------------------
!
         IMPLICIT NONE  
         CLASS(FTObject)         , POINTER :: obj
         CLASS(FTMultiIndexTable), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTMultiIndexTable)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END FUNCTION MultiIndexTableFromObject
!
!//////////////////////////////////////////////////////////////////////// 
! 
      LOGICAL FUNCTION keysMatch(key1,key2)  
         IMPLICIT NONE  
         INTEGER, DIMENSION(:) :: key1, key2
         INTEGER               :: match
         
         keysMatch = .FALSE.
         
         match = MAXVAL(ABS(key1 - key2))
         IF(match == 0) keysMatch = .TRUE.
         
      END FUNCTION keysMatch
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE sortKeysAscending(keys)
!
!     ----------------------------------------------------
!     Use an insertion sort for the keys, since the number
!     of them should be small
!     ----------------------------------------------------
!
         IMPLICIT NONE
         INTEGER, DIMENSION(:) :: keys
         INTEGER               :: i, j, N, t
         
         N = SIZE(keys)
         
         SELECT CASE ( N )
            CASE( 1 )
               return
            CASE( 2 ) 
               IF ( keys(1) > keys(2) )     THEN
                  t = keys(1)
                  keys(1) = keys(2)
                  keys(2) = t 
               END IF
            CASE DEFAULT 
               DO i = 2, N
                  t = keys(i)
                  j = i
                  DO WHILE( j > 1 .AND. keys(j-1) > t )
                     keys(j) = keys(j-1)
                     j = j - 1 
                     IF(j == 1) EXIT 
                  END DO 
                  keys(j) = t
               END DO  
         END SELECT 
          
      END SUBROUTINE sortKeysAscending
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE printMultiIndexTableDescription(self, iUnit)  
         IMPLICIT NONE  
         CLASS(FTMultiIndexTable) :: self
         INTEGER                  :: iUnit
         INTEGER                  :: i
         
         DO i = 1, SIZE(self % table)
            CALL self % table(i) % printDescription(iUnit) 
         END DO 
          
      END SUBROUTINE printMultiIndexTableDescription

      END Module FTMultiIndexTableClass

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	! MultiIndexTableClass.f90
34	! Created: July 29, 2013 10:59 AM
35	! By: David Kopriva
36	!
37	!
38	!////////////////////////////////////////////////////////////////////////
39	!
40	Module FTMultiIndexTableData
41	USE FTObjectClass
42	IMPLICIT NONE
43	!
44	! ---------------
45	! Type definition
46	! ---------------
47	!
48	TYPE, EXTENDS(FTObject) :: MultiIndexMatrixData
49	INTEGER , ALLOCATABLE :: key(:)
50	CLASS(FTObject), POINTER :: object
51	!
52	! ========
53	CONTAINS
54	! ========
55	!
56	PROCEDURE :: initWithObjectAndKeys
57	FINAL :: destructMultiIndexMatrixData
58
59	END TYPE MultiIndexMatrixData
60
61	INTERFACE cast
62	MODULE PROCEDURE castObjectToMultiIndexMatrixData
63	END INTERFACE cast
64
65	!
66	! ========
67	CONTAINS
68	! ========
69	!
70	!
71	!////////////////////////////////////////////////////////////////////////
72	!
73	SUBROUTINE initWithObjectAndKeys(self,object,key)	4✔
74	!
75	! ----------------------
76	! Designated initializer
77	! ----------------------
78	!
79	IMPLICIT NONE
80	CLASS(MultiIndexMatrixData) :: self
81	CLASS(FTObject), POINTER :: object
82	INTEGER :: key(:)
83
84	CALL self % FTObject % init()	4✔
85
86	ALLOCATE(self % key(SIZE(key)))	4✔
87	self % key = key	24✔
88	self % object => object	4✔
89	CALL self % object % retain()	4✔
90
91	END SUBROUTINE initWithObjectAndKeys	4✔
92	!
93	!////////////////////////////////////////////////////////////////////////
94	!
95	SUBROUTINE releaseFTMultiIndexMatrixData(self)	×
96	IMPLICIT NONE
97	TYPE(MultiIndexMatrixData), POINTER :: self
98	CLASS(FTObject) , POINTER :: obj
99
100	IF(.NOT. ASSOCIATED(self)) RETURN	×
101
102	obj => self	×
103	CALL release(obj)	×
104	IF(.NOT.ASSOCIATED(obj)) self => NULL()	×
105	END SUBROUTINE releaseFTMultiIndexMatrixData
106	!
107	!////////////////////////////////////////////////////////////////////////
108	!
109	SUBROUTINE destructMultiIndexMatrixData(self)	×
110	IMPLICIT NONE
111	TYPE(MultiIndexMatrixData) :: self
112
113	IF ( ASSOCIATED(self % object) ) CALL releaseFTObject(self % object )	×
114	IF ( ALLOCATED(self % key) ) DEALLOCATE(self % key)	×
115
116	END SUBROUTINE destructMultiIndexMatrixData	×
117	!
118	!////////////////////////////////////////////////////////////////////////
119	!
120	SUBROUTINE castObjectToMultiIndexMatrixData(obj,cast)	11✔
121	IMPLICIT NONE
122	!
123	! -----------------------------------------------------
124	! Cast the base class FTObject to the FTException class
125	! -----------------------------------------------------
126	!
127	CLASS(FTObject) , POINTER :: obj
128	CLASS(MultiIndexMatrixData), POINTER :: cast
129
130	cast => NULL()	11✔
131	SELECT TYPE (e => obj)
132	TYPE is (MultiIndexMatrixData)
133	cast => e	11✔
134	CLASS DEFAULT
135
136	END SELECT
137
138	END SUBROUTINE castObjectToMultiIndexMatrixData	11✔
139	!
140	!////////////////////////////////////////////////////////////////////////
141	!
142	FUNCTION MultiIndexMatrixDataCast(obj) RESULT(cast)	×
143	IMPLICIT NONE
144	!
145	! -----------------------------------------------------
146	! Cast the base class FTObject to the FTException class
147	! -----------------------------------------------------
148	!
149	CLASS(FTObject) , POINTER :: obj
150	CLASS(MultiIndexMatrixData), POINTER :: cast
151
152	cast => NULL()	×
153	SELECT TYPE (e => obj)
154	TYPE is (MultiIndexMatrixData)
155	cast => e	×
156	CLASS DEFAULT
157
158	END SELECT
159
160	END FUNCTION MultiIndexMatrixDataCast	×
161
162	END Module FTMultiIndexTableData	15✔
163	!@mark -
164	!>The MultiIndexTable stores an FTObject pointer associated
165	!>with any number of integer keys(:) as a hash table.
166	!>
167	!>#Usage
168	!>## Definition (Subclass of FTObject)
169	!>
170	!> TYPE(FTMultiIndexTable) :: multiIndexTable
171	!>
172	!>##Initialization
173	!>
174	!> CALL MultiIndexTable % initWithSize(N)
175	!>
176	!>The size, N = the maximum value of all of the keys.
177	!>
178	!>## Destruction
179	!>
180	!> CALL releaseFTMultiIndexTable(MultiIndexTable) [Pointers]
181	!>
182	!>##Adding an object
183	!>
184	!> CLASS(FTObject), POINTER :: obj
185	!> INTEGER, DIMENSION(dim) :: keys
186	!> CALL MultiIndexTable % addObjectForKeys(obj,keys)
187	!>
188	!>##Retrieving an object
189	!>
190	!> CLASS(FTObject), POINTER :: obj
191	!> INTEGER, DIMENSION(dim) :: keys
192	!> obj => MultiIndexTable % objectForKeys(keys)
193	!>
194	!>Be sure to retain the object if you want it to live
195	!> beyond the life of the table.
196	!>
197	!>##Testing the presence of keys
198	!>
199	!> LOGICAL :: exists
200	!> exists = MultiIndexTable % containsKeys(keys)
201	!
202	!////////////////////////////////////////////////////////////////////////
203	!
204	Module FTMultiIndexTableClass
205	USE FTObjectClass
206	USE FTLinkedListClass
207	USE FTMultiIndexTableData
208	IMPLICIT NONE
209	!
210	! ---------------------
211	! Class type definition
212	! ---------------------
213	!
214	TYPE, EXTENDS(FTObject) :: FTMultiIndexTable
215	CLASS(FTLinkedList), DIMENSION(:), ALLOCATABLE :: table
216	!
217	! ========
218	CONTAINS
219	! ========
220	!
221	PROCEDURE :: initWithSize => initMultiIndexTableWithSize
222	FINAL :: destructMultiIndexTable
223	PROCEDURE :: containsKeys => MultiIndexTableContainsKeys
224	PROCEDURE :: addObjectForKeys => addObjectToMultiIndexTableForKeys
225	PROCEDURE :: objectForKeys => objectInMultiIndexTableForKeys
226	PROCEDURE :: printDescription => printMultiIndexTableDescription
227	PROCEDURE :: MultiIndexTableSize
228
229	END TYPE FTMultiIndexTable
230	!
231	! ========
232	CONTAINS
233	! ========
234	!
235	!
236	!////////////////////////////////////////////////////////////////////////
237	!
238	SUBROUTINE initMultiIndexTableWithSize(self,N)	1✔
239	IMPLICIT NONE
240	!
241	! ---------
242	! Arguments
243	! ---------
244	!
245	CLASS(FTMultiIndexTable) :: self
246	INTEGER :: N
247	!
248	! ---------------
249	! Local variables
250	! ---------------
251	!
252	INTEGER :: j
253
254	CALL self % FTObject % init()	1✔
255
256	ALLOCATE(self % table(N))	11✔
257	DO j = 1, N	11✔
258	CALL self % table(j) % init()	11✔
259	END DO
260
261	END SUBROUTINE initMultiIndexTableWithSize	1✔
262	!
263	!////////////////////////////////////////////////////////////////////////
264	!
265	SUBROUTINE releaseFTMultiIndexTable(self)	1✔
266	IMPLICIT NONE
267	TYPE(FTMultiIndexTable), POINTER :: self
268	CLASS(FTObject) , POINTER :: obj
269
270	IF(.NOT. ASSOCIATED(self)) RETURN	1✔
271
272	obj => self	1✔
273	CALL release(obj)	1✔
274	IF(.NOT.ASSOCIATED(obj)) self => NULL()	1✔
275	END SUBROUTINE releaseFTMultiIndexTable
276	!
277	!////////////////////////////////////////////////////////////////////////
278	!
NEW 279	SUBROUTINE releaseFTMultiIndexTableClass(self)	×
280	IMPLICIT NONE
281	CLASS(FTMultiIndexTable), POINTER :: self
282	CLASS(FTObject) , POINTER :: obj
283
NEW 284	IF(.NOT. ASSOCIATED(self)) RETURN	×
285
NEW 286	obj => self	×
NEW 287	CALL release(obj)	×
NEW 288	IF(.NOT.ASSOCIATED(obj)) self => NULL()	×
289	END SUBROUTINE releaseFTMultiIndexTableClass
290	!
291	!////////////////////////////////////////////////////////////////////////
292	!
293	SUBROUTINE destructMultiIndexTable(self)	1✔
294	IMPLICIT NONE
295	!
296	! ---------
297	! Arguments
298	! ---------
299	!
300	TYPE(FTMultiIndexTable) :: self
301	!
302	! ---------------
303	! Local variables
304	! ---------------
305	!
306	IF(ALLOCATED(self % table)) THEN	1✔
307	DEALLOCATE(self % table)	1✔
308	END IF
309
310	END SUBROUTINE destructMultiIndexTable	1✔
311	!
312	!////////////////////////////////////////////////////////////////////////
313	!
314	SUBROUTINE addObjectToMultiIndexTableForKeys(self,obj,keys)	4✔
315	IMPLICIT NONE
316	!
317	! ---------
318	! Arguments
319	! ---------
320	!
321	CLASS(FTMultiIndexTable) :: self
322	CLASS(FTObject), POINTER :: obj
323	INTEGER :: keys(:)
324	!
325	! ---------------
326	! Local variables
327	! ---------------
328	!
329	CLASS(MultiIndexMatrixData), POINTER :: mData
330	CLASS(FTObject) , POINTER :: ptr
331	INTEGER :: i
332	INTEGER :: orderedKeys(SIZE(keys))	8✔
333
334	orderedKeys = keys	20✔
335	CALL sortKeysAscending(orderedKeys)	4✔
336
337	i = orderedKeys(1)	4✔
338	IF ( .NOT.self % containsKeys(orderedKeys) ) THEN	4✔
339	ALLOCATE(mData)	4✔
340	CALL mData % initWithObjectAndKeys(obj,orderedKeys)	4✔
341	ptr => mData	4✔
342
343	CALL self % table(i) % add(ptr)	4✔
344	CALL releaseFTObject(ptr)	4✔
345	END IF
346
347	END SUBROUTINE addObjectToMultiIndexTableForKeys	4✔
348	!
349	!////////////////////////////////////////////////////////////////////////
350	!
351	FUNCTION objectInMultiIndexTableForKeys(self,keys) RESULT(r)	4✔
352	!
353	! ---------------------------------------------------------------
354	! Returns the stored FTObject for the keys (i,j). Returns NULL()
355	! if the object isn't in the table. Retain the object if it needs
356	! a strong reference by the caller.
357	! ---------------------------------------------------------------
358	!
359	IMPLICIT NONE
360	!
361	! ---------
362	! Arguments
363	! ---------
364	!
365	CLASS(FTMultiIndexTable) :: self
366	INTEGER :: keys(:)
367	CLASS(FTObject), POINTER :: r
368	!
369	! ---------------
370	! Local variables
371	! ---------------
372	!
373	CLASS(MultiIndexMatrixData) , POINTER :: mData
374	CLASS(FTObject) , POINTER :: obj
375	CLASS(FTLinkedListRecord) , POINTER :: currentRecord
376	INTEGER :: i
377	INTEGER :: orderedKeys(SIZE(keys))	4✔
378
379	orderedKeys = keys	20✔
380	CALL sortKeysAscending(orderedKeys)	4✔
381
382	r => NULL()	4✔
383	i = orderedKeys(1)	4✔
384	IF(.NOT.ALLOCATED(self % table)) RETURN	4✔
385	IF ( self % table(i) % COUNT() == 0 ) RETURN	4✔
386	!
387	! ----------------------------
388	! Step through the linked list
389	! ----------------------------
390	!
391	r => NULL()	4✔
392
393	currentRecord => self % table(i) % head	4✔
394	DO WHILE (ASSOCIATED(currentRecord))	5✔
395
396	obj => currentRecord % recordObject	5✔
397	CALL cast(obj,mData)	5✔
398	IF ( keysMatch(key1 = mData % key,key2 = orderedKeys) ) THEN	5✔
399	r => mData % object	4✔
400	EXIT	4✔
401	END IF
402
403	currentRecord => currentRecord % next	1✔
404	END DO
405
406	END FUNCTION objectInMultiIndexTableForKeys	4✔
407	!
408	!////////////////////////////////////////////////////////////////////////
409	!
410	FUNCTION MultiIndexTableContainsKeys(self,keys) RESULT(r)	8✔
411	IMPLICIT NONE
412	!
413	! ---------
414	! Arguments
415	! ---------
416	!
417	CLASS(FTMultiIndexTable) :: self
418	INTEGER :: keys(:)
419	LOGICAL :: r
420	!
421	! ---------------
422	! Local variables
423	! ---------------
424	!
425	CLASS(FTObject) , POINTER :: obj
426	CLASS(MultiIndexMatrixData) , POINTER :: mData
427	CLASS(FTLinkedListRecord) , POINTER :: currentRecord
428	INTEGER :: i
429	INTEGER :: orderedKeys(SIZE(keys))	8✔
430
431	orderedKeys = keys	40✔
432	CALL sortKeysAscending(orderedKeys)	8✔
433
434	r = .FALSE.	8✔
435	i = orderedKeys(1)	8✔
436	IF(.NOT.ALLOCATED(self % table)) RETURN	8✔
437	IF ( self % table(i) % COUNT() == 0 ) RETURN	8✔
438	!
439	! ----------------------------
440	! Step through the linked list
441	! ----------------------------
442	!
443	currentRecord => self % table(i) % head	5✔
444	DO WHILE (ASSOCIATED(currentRecord))	7✔
445
446	obj => currentRecord % recordObject	6✔
447	CALL cast(obj,mData)	6✔
448	IF ( keysMatch(key1 = mData % key,key2 = orderedKeys)) THEN	6✔
449	r = .TRUE.	4✔
450	EXIT	4✔
451	END IF
452
453	currentRecord => currentRecord % next	2✔
454	END DO
455
456	END FUNCTION MultiIndexTableContainsKeys	5✔
457	!
458	!////////////////////////////////////////////////////////////////////////
459	!
460	INTEGER FUNCTION MultiIndexTableSize(self)	1✔
461	IMPLICIT NONE
462	CLASS(FTMultiIndexTable) :: self
463	IF ( ALLOCATED(self % table) ) THEN	1✔
464	MultiIndexTableSize = SIZE(self % table)	1✔
465	ELSE
466	MultiIndexTableSize = 0	×
467	END IF
468	END FUNCTION MultiIndexTableSize	1✔
469	!
470	!////////////////////////////////////////////////////////////////////////
471	!
472	FUNCTION MultiIndexTableFromObject(obj) RESULT(cast)	1✔
473	!
474	! -----------------------------------------------------
475	! Cast the base class FTObject to the FTException class
476	! -----------------------------------------------------
477	!
478	IMPLICIT NONE
479	CLASS(FTObject) , POINTER :: obj
480	CLASS(FTMultiIndexTable), POINTER :: cast
481
482	cast => NULL()	1✔
483	SELECT TYPE (e => obj)
484	TYPE is (FTMultiIndexTable)
485	cast => e	1✔
486	CLASS DEFAULT
487
488	END SELECT
489
490	END FUNCTION MultiIndexTableFromObject	1✔
491	!
492	!////////////////////////////////////////////////////////////////////////
493	!
494	LOGICAL FUNCTION keysMatch(key1,key2)	11✔
495	IMPLICIT NONE
496	INTEGER, DIMENSION(:) :: key1, key2
497	INTEGER :: match
498
499	keysMatch = .FALSE.	11✔
500
501	match = MAXVAL(ABS(key1 - key2))	55✔
502	IF(match == 0) keysMatch = .TRUE.	11✔
503
504	END FUNCTION keysMatch	11✔
505	!
506	!////////////////////////////////////////////////////////////////////////
507	!
508	SUBROUTINE sortKeysAscending(keys)	21✔
509	!
510	! ----------------------------------------------------
511	! Use an insertion sort for the keys, since the number
512	! of them should be small
513	! ----------------------------------------------------
514	!
515	IMPLICIT NONE
516	INTEGER, DIMENSION(:) :: keys
517	INTEGER :: i, j, N, t
518
519	N = SIZE(keys)	21✔
520
521	SELECT CASE ( N )	1✔
522	CASE( 1 )
523	return	1✔
524	CASE( 2 )
525	IF ( keys(1) > keys(2) ) THEN	2✔
526	t = keys(1)	1✔
527	keys(1) = keys(2)	1✔
528	keys(2) = t	1✔
529	END IF
530	CASE DEFAULT
531	DO i = 2, N	78✔
532	t = keys(i)	57✔
533	j = i	57✔
534	DO WHILE( j > 1 .AND. keys(j-1) > t )	82✔
535	keys(j) = keys(j-1)	46✔
536	j = j - 1	46✔
537	IF(j == 1) EXIT	46✔
538	END DO
539	keys(j) = t	76✔
540	END DO
541	END SELECT
542
543	END SUBROUTINE sortKeysAscending
544	!
545	!////////////////////////////////////////////////////////////////////////
546	!
547	SUBROUTINE printMultiIndexTableDescription(self, iUnit)	×
548	IMPLICIT NONE
549	CLASS(FTMultiIndexTable) :: self
550	INTEGER :: iUnit
551	INTEGER :: i
552
553	DO i = 1, SIZE(self % table)	×
554	CALL self % table(i) % printDescription(iUnit)	×
555	END DO
556
557	END SUBROUTINE printMultiIndexTableDescription	×
558
559	END Module FTMultiIndexTableClass	3✔

trixi-framework / FTObjectLibrary / 30206241592

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