source: XMLIO_SERVER/trunk/src/IOSERVER/mod_event_server.f90 @ 40

Last change on this file since 40 was 40, checked in by ymipsl, 15 years ago
  • Les attributs XML peuvent désormais être passer dynamiquement à travers l'interface du server IO.
  • ajout d'un attribut name_suffix pour les fichiers

YM
File size: 9.4 KB
Line 
1MODULE mod_event_server
2  USE mod_pack, ONLY : unpack, unpack_field
3  USE mod_event_parameters
4  USE iomanager
5 
6CONTAINS
7
8  SUBROUTINE Process_event(current_rank,is_terminated)
9  IMPLICIT NONE
10    INTEGER :: event_id
11    INTEGER, INTENT(IN) :: current_rank
12    LOGICAL,INTENT(OUT) :: is_terminated
13     
14    CALL iom__set_current_rank(current_rank)
15     
16    is_terminated=.FALSE.
17   
18    CALL unpack(event_id)
19   
20    SELECT CASE (event_id)
21   
22      CASE (event_id_swap_context)
23        CALL event__swap_context
24       
25      CASE (event_id_parse_xml_file)
26        CALL event__parse_xml_file 
27
28      CASE (event_id_set_vert_axis)
29        CALL event__set_vert_axis 
30     
31      CASE (event_id_set_grid_dimension)
32        CALL event__set_grid_dimension
33     
34      CASE (event_id_set_grid_domain)
35        CALL event__set_grid_domain
36
37      CASE (event_id_set_grid_type_nemo)
38        CALL event__set_grid_type_nemo
39
40      CASE (event_id_set_grid_type_lmdz)
41        CALL event__set_grid_type_lmdz
42
43      CASE (event_id_set_time_parameters)
44        CALL event__set_time_parameters
45
46      CASE (event_id_close_io_definition)
47        CALL event__close_io_definition 
48
49      CASE (event_id_set_timestep)
50        CALL event__set_timestep
51
52      CASE (event_id_enable_field)
53        CALL event__enable_field
54     
55      CASE (event_id_disable_field)
56        CALL event__disable_field
57
58      CASE (event_id_write_Field1d)
59        CALL event__write_Field1d
60
61      CASE (event_id_write_Field2d)
62        CALL event__write_Field2d
63
64      CASE (event_id_write_Field3d)
65        CALL event__write_Field3d
66
67      CASE (event_id_set_attribut)
68        CALL event__set_attribut
69
70      CASE (event_id_stop_ioserver)
71        is_terminated=.TRUE. 
72        PRINT *,"TERMINATE_EVENT RECEIVED"
73
74      CASE DEFAULT 
75        STOP 'UNDEFINED EVENT'
76     
77     END SELECT
78     
79   END SUBROUTINE Process_event
80   
81  SUBROUTINE event__swap_context
82  IMPLICIT NONE
83    INTEGER :: id_size
84   
85    CALL unpack(id_size)
86    CALL sub_internal(id_size)
87     
88  CONTAINS
89   
90    SUBROUTINE sub_internal(id_size)
91      INTEGER :: id_size
92      CHARACTER(LEN=id_size) :: id     
93     
94       CALL unpack(id)
95     
96       CALL iom__swap_context(id)
97       
98     END SUBROUTINE sub_internal
99 
100  END SUBROUTINE event__swap_context
101 
102
103  SUBROUTINE event__parse_xml_file
104  IMPLICIT NONE
105    INTEGER :: name_size
106   
107    CALL unpack(name_size)
108    CALL sub_internal(name_size)
109     
110  CONTAINS
111   
112    SUBROUTINE sub_internal(name_size)
113      INTEGER :: name_size
114      CHARACTER(LEN=name_size) :: filename     
115     
116       CALL unpack(filename)
117     
118       CALL iom__parse_xml_file(filename)
119     END SUBROUTINE sub_internal
120 
121  END SUBROUTINE event__parse_xml_file
122 
123 
124  SUBROUTINE event__set_grid_dimension
125  IMPLICIT NONE   
126    INTEGER :: name_size
127    INTEGER :: ni_glo
128    INTEGER :: nj_glo
129   
130    CALL unpack(name_size)
131    CALL sub_internal(name_size)
132     
133  CONTAINS
134   
135    SUBROUTINE sub_internal(name_size)
136      INTEGER :: name_size
137      CHARACTER(LEN=name_size) :: name     
138     
139       CALL unpack(name)
140       CALL unpack(ni_glo)
141       CALL unpack(nj_glo)
142     
143       CALL iom__set_grid_dimension(name,ni_glo,nj_glo)
144     END SUBROUTINE sub_internal
145   
146   END SUBROUTINE event__set_grid_dimension
147
148
149  SUBROUTINE event__set_grid_domain 
150  IMPLICIT NONE   
151    INTEGER :: name_size
152    INTEGER :: ni
153    INTEGER :: nj
154    INTEGER :: ibegin
155    INTEGER :: jbegin
156    REAL,ALLOCATABLE :: lon(:,:)
157    REAL,ALLOCATABLE :: lat(:,:)
158
159    CALL unpack(name_size)
160    CALL sub_internal(name_size)
161     
162  CONTAINS
163   
164    SUBROUTINE sub_internal(name_size)
165      INTEGER :: name_size
166      CHARACTER(LEN=name_size) :: name     
167     
168       CALL unpack(name)
169   
170       CALL unpack(ni)
171       CALL unpack(nj)
172       CALL unpack(ibegin)
173       CALL unpack(jbegin)
174   
175       ALLOCATE(lon(ni,nj))
176       ALLOCATE(lat(ni,nj))
177       CALL unpack(lon)
178       CALL unpack(lat)
179   
180       CALL iom__set_grid_domain(name,ni,nj,ibegin,jbegin,lon,lat)
181
182     END SUBROUTINE sub_internal
183   
184  END SUBROUTINE event__set_grid_domain   
185
186
187  SUBROUTINE event__set_grid_type_nemo 
188  IMPLICIT NONE   
189    INTEGER :: name_size
190
191    CALL unpack(name_size)
192    CALL sub_internal(name_size)
193     
194  CONTAINS
195   
196    SUBROUTINE sub_internal(name_size)
197      INTEGER :: name_size
198      CHARACTER(LEN=name_size) :: name     
199     
200       CALL unpack(name)
201       CALL iom__set_grid_type_nemo(name)
202
203     END SUBROUTINE sub_internal
204   
205  END SUBROUTINE event__set_grid_type_nemo   
206
207  SUBROUTINE event__set_grid_type_lmdz 
208  IMPLICIT NONE   
209    INTEGER :: name_size
210
211    CALL unpack(name_size)
212    CALL sub_internal(name_size)
213     
214  CONTAINS
215   
216    SUBROUTINE sub_internal(name_size)
217      INTEGER :: name_size
218      CHARACTER(LEN=name_size) :: name     
219      INTEGER                  :: nbp
220      INTEGER                  :: offset
221     
222       CALL unpack(name)
223       CALL unpack(nbp)
224       CALL unpack(offset)
225       CALL iom__set_grid_type_lmdz(name,nbp,offset)
226
227     END SUBROUTINE sub_internal
228   
229  END SUBROUTINE event__set_grid_type_lmdz   
230
231  SUBROUTINE event__set_vert_axis
232  IMPLICIT NONE
233    INTEGER :: name_size
234    INTEGER :: vert_size 
235    REAL,ALLOCATABLE :: vert_value(:)
236   
237    CALL unpack(name_size)
238    CALL sub_internal(name_size)
239
240  CONTAINS
241   
242    SUBROUTINE sub_internal(name_size)
243      INTEGER :: name_size
244      CHARACTER(LEN=name_size) :: name
245   
246      CALL unpack(name)
247      CALL unpack(vert_size)
248      ALLOCATE(vert_value(vert_size))
249      CALL unpack(vert_value) 
250     
251      CALL iom__set_vert_axis(name,vert_value)
252     
253    END SUBROUTINE sub_internal
254  END SUBROUTINE event__set_vert_axis
255
256  SUBROUTINE event__set_time_parameters
257  IMPLICIT NONE
258    INTEGER   :: itau0
259    REAL      :: zjulian
260    REAL      :: zdt
261     
262    CALL unpack(itau0)
263    CALL unpack(zjulian)
264    CALL unpack(zdt)
265   
266    CALL iom__set_time_parameters(itau0,zjulian,zdt)
267     
268  END SUBROUTINE event__set_time_parameters
269 
270
271  SUBROUTINE event__enable_field
272  IMPLICIT NONE
273    INTEGER :: lenc
274     
275    CALL unpack(lenc)
276    CALL sub_internal(lenc)
277 
278  CONTAINS
279    SUBROUTINE sub_internal(lenc)
280    IMPLICIT NONE
281      INTEGER :: lenc
282      CHARACTER(len=lenc) :: varname
283     
284      CALL unpack(varname)
285     
286      CALL iom__enable_field(varname)
287
288    END SUBROUTINE sub_internal
289  END SUBROUTINE event__enable_field
290 
291
292  SUBROUTINE event__disable_field
293  IMPLICIT NONE
294    INTEGER :: lenc
295     
296    CALL unpack(lenc)
297    CALL sub_internal(lenc)
298 
299  CONTAINS
300    SUBROUTINE sub_internal(lenc)
301    IMPLICIT NONE
302      INTEGER :: lenc
303      CHARACTER(len=lenc) :: varname
304     
305      CALL unpack(varname)
306     
307      CALL iom__disable_field(varname)
308
309    END SUBROUTINE sub_internal
310   
311  END SUBROUTINE event__disable_field
312 
313     
314  SUBROUTINE event__write_field1D
315  IMPLICIT NONE
316    INTEGER :: lenc
317    INTEGER :: dim1
318     
319    CALL unpack(lenc)
320    CALL unpack(dim1)
321    CALL sub_internal(lenc,dim1)
322 
323  CONTAINS
324    SUBROUTINE sub_internal(lenc,dim1)
325    IMPLICIT NONE
326      INTEGER :: lenc
327      INTEGER :: dim1
328      CHARACTER(len=lenc) :: varname
329      REAL                :: var(dim1)
330     
331      CALL unpack(varname)
332      CALL unpack_field(var)
333     
334      CALL iom__write_Field1d(varname,var)
335
336    END SUBROUTINE sub_internal
337  END SUBROUTINE event__write_field1d
338
339  SUBROUTINE event__write_field2D
340  IMPLICIT NONE
341    INTEGER :: lenc
342    INTEGER :: dim1
343    INTEGER :: dim2
344     
345    CALL unpack(lenc)
346    CALL unpack(dim1)
347    CALL unpack(dim2)
348    CALL sub_internal(lenc,dim1,dim2)
349 
350  CONTAINS
351    SUBROUTINE sub_internal(lenc,dim1,dim2)
352    IMPLICIT NONE
353      INTEGER :: lenc
354      INTEGER :: dim1
355      INTEGER :: dim2
356      CHARACTER(len=lenc) :: varname
357      REAL                :: var(dim1,dim2)
358     
359      CALL unpack(varname)
360      CALL unpack_field(var)
361     
362      CALL iom__write_Field2d(varname,var)
363
364    END SUBROUTINE sub_internal
365  END SUBROUTINE event__write_field2d
366   
367   
368  SUBROUTINE event__write_field3d
369  IMPLICIT NONE
370    INTEGER :: lenc
371    INTEGER :: dim1
372    INTEGER :: dim2
373    INTEGER :: dim3
374   
375    CALL unpack(lenc)
376    CALL unpack(dim1)
377    CALL unpack(dim2)
378    CALL unpack(dim3)
379    CALL sub_internal(lenc,dim1,dim2,dim3)
380 
381  CONTAINS
382 
383    SUBROUTINE sub_internal(lenc,dim1,dim2,dim3)
384    IMPLICIT NONE
385      INTEGER :: lenc
386      INTEGER :: dim1
387      INTEGER :: dim2
388      INTEGER :: dim3
389 
390      CHARACTER(len=lenc) :: varname
391      REAL                :: var(dim1,dim2,dim3)
392       
393      CALL unpack(varname)
394      CALL unpack_field(var)
395       
396      CALL iom__write_field3d(varname,var)
397         
398    END SUBROUTINE sub_internal
399
400  END SUBROUTINE event__write_field3d
401   
402   
403  SUBROUTINE event__set_timestep
404  IMPLICIT NONE
405    INTEGER :: timestep
406     
407    CALL unpack(timestep)
408    CALL iom__set_timestep(timestep)
409   
410  END SUBROUTINE event__set_timestep
411   
412   
413  SUBROUTINE event__close_io_definition
414  IMPLICIT NONE
415   
416    CALL iom__close_io_definition
417   
418  END SUBROUTINE event__close_io_definition
419 
420  SUBROUTINE event__set_attribut
421   USE mod_attribut
422   IMPLICIT NONE
423     TYPE(attribut) :: attrib
424     INTEGER        :: len_id
425     
426     CALL unpack(len_id)
427     CALL sub_internal
428   CONTAINS
429     
430     SUBROUTINE sub_internal
431       CHARACTER(LEN=len_id) :: id
432       
433       CALL unpack(id)
434       CALL unpack(attrib)
435       CALL iom__set_attribut(id,attrib)
436       CALL attr_deallocate(attrib)
437     END SUBROUTINE sub_internal
438  END SUBROUTINE event__set_attribut   
439
440END MODULE mod_event_server   
Note: See TracBrowser for help on using the repository browser.