New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mod_field_group.f90 in vendors/XMLIO_SERVER/current/src/XMLIO – NEMO

source: vendors/XMLIO_SERVER/current/src/XMLIO/mod_field_group.f90 @ 1897

Last change on this file since 1897 was 1897, checked in by flavoni, 14 years ago

importing XMLIO_SERVER vendor
File size: 7.9 KB
Line 
1MODULE mod_field_group
2
3  USE mod_field
4  USE mod_xmlio_parameters
5
6  IMPLICIT NONE
7
8  TYPE field_group
9    CHARACTER(LEN=str_len)                    :: id
10    LOGICAL                                   :: has_id
11    TYPE(vector_field_group), POINTER         :: groups
12    TYPE(vector_field),POINTER                :: fields     
13    TYPE(field), POINTER                      :: default_attribut
14  END TYPE field_group
15
16  INCLUDE "vector_field_group_def.inc" 
17
18  TYPE(vector_field_group),SAVE,POINTER      :: field_group_Ids
19  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 
20
21  INTERFACE field_group__set_attribut
22    MODULE PROCEDURE field_group__set_attribut_id,field_group__set_attribut_pt
23  END INTERFACE
24
25CONTAINS
26
27  INCLUDE "vector_field_group_contains.inc"
28
29
30  SUBROUTINE field_group__swap_context(saved_field_group_ids, saved_ids)
31  IMPLICIT NONE
32    TYPE(vector_field_group),POINTER   :: saved_field_group_Ids
33    TYPE(sorted_list),POINTER          :: saved_Ids
34   
35    field_group_ids=>saved_field_group_ids 
36    ids=>saved_ids
37   
38  END SUBROUTINE field_group__swap_context
39
40  SUBROUTINE field_group__init
41  IMPLICIT NONE
42   
43    CALL vector_field_group__new(field_group_Ids)
44    CALL sorted_list__new(Ids)
45   
46  END SUBROUTINE field_group__init
47
48  SUBROUTINE field_group__get(Id,Pt_fg)
49  USE string_function
50  IMPLICIT NONE
51    CHARACTER(LEN=*),INTENT(IN)     :: Id
52    TYPE(field_group),POINTER       :: Pt_fg
53
54    INTEGER                         :: Pos
55    LOGICAL                         :: success
56   
57    CALL sorted_list__find(Ids,hash(Id),Pos,success)
58    IF (success) THEN
59      Pt_fg=>field_group_ids%at(Pos)%Pt
60    ELSE
61      Pt_fg=>NULL()
62    ENDIF
63   
64  END SUBROUTINE field_group__get
65
66  SUBROUTINE field_group__set_attribut_id(id,attrib,Ok)
67  USE mod_attribut
68  USE error_msg
69  IMPLICIT NONE
70    CHARACTER(LEN=*),INTENT(IN) :: id
71    TYPE(attribut),INTENT(IN) :: attrib
72    LOGICAL,OPTIONAL,INTENT(out)  :: Ok
73   
74    TYPE(field_group),POINTER             :: Pt_fg
75    INTEGER                         :: Pos
76    LOGICAL                         :: success
77   
78    CALL sorted_list__find(Ids,hash(Id),Pos,success)
79    IF (success) THEN
80      Pt_fg=>field_group_ids%at(Pos)%Pt
81      CALL field_group__set_attribut(Pt_fg,attrib)
82      IF (PRESENT(OK)) ok=.TRUE.
83    ELSE
84      IF (.NOT.PRESENT(OK)) THEN
85        WRITE(message,*) 'Field group id :',id,'is undefined'
86        CALL error('mod_field_group::field_group__set_attribut')
87      ELSE
88        OK=.FALSE.
89      ENDIF
90    ENDIF
91   
92  END SUBROUTINE field_group__set_attribut_id
93 
94  SUBROUTINE field_group__set_attribut_pt(pt_fg,attrib)
95  USE mod_attribut
96  USE mod_object
97  IMPLICIT NONE
98    TYPE(field_group),POINTER :: Pt_fg
99    TYPE(attribut),INTENT(IN) :: attrib
100     
101    IF (attrib%object==field_object) THEN
102      CALL field__set_attribut(Pt_fg%default_attribut,attrib)
103    ENDIF
104   
105  END SUBROUTINE field_group__set_attribut_pt
106   
107     
108  RECURSIVE SUBROUTINE field_group__new(Pt_fg,Id)
109  USE string_function
110  IMPLICIT NONE
111    TYPE(field_group),POINTER                :: Pt_fg
112    CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: Id
113   
114    INTEGER :: Pos
115   
116    ALLOCATE(Pt_fg%groups)
117    ALLOCATE(Pt_fg%fields)
118    ALLOCATE(Pt_fg%default_attribut)
119   
120    CALL vector_field_group__new(Pt_fg%groups)
121    CALL vector_field__new(Pt_fg%fields)
122    CALL field__new(Pt_fg%default_attribut)
123    Pt_fg%has_id=.FALSE.
124     
125    IF (PRESENT(Id)) THEN
126      Pt_fg%id=TRIM(Id)
127      Pt_fg%has_id=.TRUE.
128      CALL vector_field_group__set_new(field_group_Ids,Pt_fg,Pos)
129      CALL sorted_list__Add(Ids,hash(id),Pos)
130    ENDIF
131
132  END SUBROUTINE field_group__new
133
134     
135  SUBROUTINE field_group__get_new_group(Pt_fg,Pt_fg_out,Id)
136  IMPLICIT NONE
137    TYPE(field_group),POINTER            :: Pt_fg
138    TYPE(field_group),POINTER            :: Pt_fg_out
139    CHARACTER(LEN=*),OPTIONAL      :: Id
140   
141    CALL vector_field_group__get_new(Pt_fg%groups,Pt_fg_out)
142 
143    IF (PRESENT(id)) THEN
144      CALL field_group__new(Pt_fg_out,Id)
145    ELSE
146      CALL field_group__new(Pt_fg_out)
147    ENDIF
148   
149  END SUBROUTINE field_group__get_new_group
150
151 
152  SUBROUTINE field_group__get_new_field(Pt_fg,Pt_f_out,Id)
153  IMPLICIT NONE
154    TYPE(field_group),POINTER            :: Pt_fg
155    TYPE(field),POINTER                  :: Pt_f_out
156    CHARACTER(LEN=*),OPTIONAL      :: Id
157   
158    CALL vector_field__get_new(Pt_fg%fields,Pt_f_out)
159   
160    IF (PRESENT(id)) THEN
161      CALL field__new(Pt_f_out,Id)
162    ELSE
163      CALL field__new(Pt_f_out)
164    ENDIF
165   
166  END SUBROUTINE field_group__get_new_field
167 
168 
169  SUBROUTINE field_group__get_default_attrib(Pt_fg,Pt_f)
170  IMPLICIT NONE
171    TYPE(field_group),POINTER  :: Pt_fg
172    TYPE(field),POINTER        :: Pt_f
173   
174    Pt_f=>Pt_fg%default_attribut
175  END SUBROUTINE field_group__get_default_attrib
176
177 
178  RECURSIVE SUBROUTINE field_group__apply_default(Pt_fg,default)
179  IMPLICIT NONE
180    TYPE(field_group),POINTER           :: Pt_fg
181    TYPE(field),POINTER,OPTIONAL        :: default
182   
183    INTEGER :: i
184   
185    IF (PRESENT(default)) THEN
186      CALL field__apply_default(default,Pt_fg%default_attribut,Pt_fg%default_attribut)
187    ENDIF
188     
189    DO i=1,Pt_fg%groups%size
190      CALL field_group__apply_default(Pt_fg%groups%at(i)%pt,Pt_fg%default_attribut)
191    ENDDO
192   
193    DO i=1,Pt_fg%fields%size
194      CALL field__apply_default(Pt_fg%default_attribut,Pt_fg%fields%at(i)%pt,Pt_fg%fields%at(i)%pt)
195    ENDDO
196 
197  END SUBROUTINE field_group__apply_default
198 
199  SUBROUTINE field_group__solve_ref(pt_fg)
200  IMPLICIT NONE
201    TYPE(field_group),POINTER  :: Pt_fg
202
203    CALL field_group__solve_field_ref(Pt_fg)
204    CALL field_group__solve_axis_ref(Pt_fg)
205    CALL field_group__solve_grid_ref(Pt_fg)
206    CALL field_group__solve_zoom_ref(Pt_fg)
207
208  END SUBROUTINE  field_group__solve_ref
209     
210  RECURSIVE SUBROUTINE field_group__solve_field_ref(Pt_fg)
211  IMPLICIT NONE
212    TYPE(field_group),POINTER  :: Pt_fg
213   
214    INTEGER :: i
215
216    DO i=1,Pt_fg%groups%size
217      CALL field_group__solve_field_ref(Pt_fg%groups%at(i)%pt)
218    ENDDO
219   
220    DO i=1,Pt_fg%fields%size
221      CALL field__solve_field_ref(Pt_fg%fields%at(i)%pt)
222    ENDDO
223 
224  END SUBROUTINE field_group__solve_field_ref
225
226  RECURSIVE SUBROUTINE field_group__solve_axis_ref(Pt_fg)
227  IMPLICIT NONE
228    TYPE(field_group),POINTER  :: Pt_fg
229   
230    INTEGER :: i
231
232    DO i=1,Pt_fg%groups%size
233      CALL field_group__solve_axis_ref(Pt_fg%groups%at(i)%pt)
234    ENDDO
235   
236    DO i=1,Pt_fg%fields%size
237      CALL field__solve_axis_ref(Pt_fg%fields%at(i)%pt)
238    ENDDO
239 
240  END SUBROUTINE field_group__solve_axis_ref
241
242  RECURSIVE SUBROUTINE field_group__solve_grid_ref(Pt_fg)
243  IMPLICIT NONE
244    TYPE(field_group),POINTER  :: Pt_fg
245     
246    INTEGER :: i
247 
248    DO i=1,Pt_fg%groups%size
249      CALL field_group__solve_grid_ref(Pt_fg%groups%at(i)%pt)
250    ENDDO
251       
252    DO i=1,Pt_fg%fields%size
253      CALL field__solve_grid_ref(Pt_fg%fields%at(i)%pt)
254    ENDDO
255 
256  END SUBROUTINE field_group__solve_grid_ref
257
258  RECURSIVE SUBROUTINE field_group__solve_zoom_ref(Pt_fg)
259  IMPLICIT NONE
260    TYPE(field_group),POINTER  :: Pt_fg
261     
262    INTEGER :: i
263 
264    DO i=1,Pt_fg%groups%size
265      CALL field_group__solve_zoom_ref(Pt_fg%groups%at(i)%pt)
266    ENDDO
267       
268    DO i=1,Pt_fg%fields%size
269      CALL field__solve_zoom_ref(Pt_fg%fields%at(i)%pt)
270    ENDDO
271 
272  END SUBROUTINE field_group__solve_zoom_ref
273 
274  RECURSIVE SUBROUTINE field_group__print(Pt_fg)
275  IMPLICIT NONE
276    TYPE(field_group),POINTER  :: Pt_fg
277   
278    INTEGER :: i
279   
280    PRINT *,"--- FIELD GROUP ---"
281    IF (Pt_fg%has_id) THEN
282      PRINT *,"id :",TRIM(Pt_fg%id)
283    ELSE
284      PRINT *,"id undefined"
285    ENDIF
286   
287    PRINT *,"field default attribut :"
288    CALL field__print(Pt_fg%default_attribut)   
289
290    PRINT *,"owned field groups :",Pt_fg%groups%size     
291    DO i=1,Pt_fg%groups%size
292      CALL field_group__print(Pt_fg%groups%at(i)%pt)
293    ENDDO
294
295    PRINT *,"owned field :",Pt_fg%fields%size     
296    DO i=1,Pt_fg%fields%size
297      CALL field__print(Pt_fg%fields%at(i)%pt)
298    ENDDO
299   
300    PRINT *,"------------"
301   
302  END SUBROUTINE field_group__print     
303
304END MODULE mod_field_group
Note: See TracBrowser for help on using the repository browser.