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_event_server.f90 in branches/nemo_v3_3_beta/NEMOGCM/EXTERNAL/XMLIO_SERVER/src/IOSERVER – NEMO

source: branches/nemo_v3_3_beta/NEMOGCM/EXTERNAL/XMLIO_SERVER/src/IOSERVER/mod_event_server.f90 @ 2281

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

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