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 vendors/XMLIO_SERVER/current/src/IOSERVER – NEMO

source: vendors/XMLIO_SERVER/current/src/IOSERVER/mod_event_server.f90 @ 2765

Last change on this file since 2765 was 2765, checked in by smasson, 13 years ago

Load working_directory into vendors/XMLIO_SERVER/current.
File size: 10.1 KB
Line 
1MODULE mod_event_server
2  USE mod_pack, ONLY : unpack_data, 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_data(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_data(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_data(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_data(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_data(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_data(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_data(name)
144       CALL unpack_data(ni_glo)
145       CALL unpack_data(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_data(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_data(name)
173   
174       CALL unpack_data(ni)
175       CALL unpack_data(nj)
176       CALL unpack_data(ibegin)
177       CALL unpack_data(jbegin)
178   
179       ALLOCATE(lon(ni,nj))
180       ALLOCATE(lat(ni,nj))
181       CALL unpack_data(lon)
182       CALL unpack_data(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_data(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_data(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_data(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_data(name)
227       CALL unpack_data(nbp)
228       CALL unpack_data(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_data(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_data(name)
251      CALL unpack_data(vert_size)
252      ALLOCATE(vert_value(vert_size))
253      CALL unpack_data(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_data(itau0)
267    CALL unpack_data(zjulian)
268    CALL unpack_data(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_data(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_data(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_data(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_data(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_data(lenc)
324    CALL unpack_data(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_data(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_data(lenc)
350    CALL unpack_data(dim1)
351    CALL unpack_data(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_data(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_data(lenc)
380    CALL unpack_data(dim1)
381    CALL unpack_data(dim2)
382    CALL unpack_data(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_data(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_data(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_data(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_data(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_data(len_id)
452     CALL sub_internal
453   CONTAINS
454     
455     SUBROUTINE sub_internal
456       CHARACTER(LEN=len_id) :: id
457       
458       CALL unpack_data(id)
459       CALL unpack_data(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.