source: XMLIO_SERVER/trunk/src/IOSERVER/mod_pack.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: 15.0 KB
Line 
1  MODULE mod_pack
2    INTEGER,PARAMETER :: integer_size=4
3    INTEGER,PARAMETER :: pack_buffer_max_size=integer_size*1024*1024
4    INTEGER(kind=8),POINTER,SAVE      :: pack_buffer(:)
5    INTEGER,SAVE      :: pack_pos
6   
7    INTERFACE pack
8      MODULE PROCEDURE pack_r,pack_r1,pack_r2,pack_r3,pack_r4,                 &
9                       pack_i,pack_i1,pack_i2,pack_i3,pack_i4,                 &
10                       pack_l,pack_l1,pack_l2,pack_l3,pack_l4,                 &
11                       pack_c,pack_c1,pack_c2,pack_c3,pack_c4,                 &
12                       pack_attr
13    END INTERFACE pack
14
15    INTERFACE unpack
16      MODULE PROCEDURE unpack_r,unpack_r1,unpack_r2,unpack_r3,unpack_r4,       &
17                       unpack_i,unpack_i1,unpack_i2,unpack_i3,unpack_i4,       &
18                       unpack_l,unpack_l1,unpack_l2,unpack_l3,unpack_l4,       &
19                       unpack_c,unpack_c1,unpack_c2,unpack_c3,unpack_c4,       &
20                       unpack_attr
21    END INTERFACE unpack
22
23    INTERFACE pack_field
24      MODULE PROCEDURE pack_field1,pack_field2,pack_field3,pack_field4       
25    END INTERFACE pack_field
26
27    INTERFACE unpack_field
28      MODULE PROCEDURE unpack_field1,unpack_field2,unpack_field3,unpack_field4 
29    END INTERFACE unpack_field
30           
31  CONTAINS
32 
33    SUBROUTINE set_pack_buffer(pack_buffer0,pack_pos0)
34    IMPLICIT NONE
35    INTEGER(kind=8),POINTER  :: pack_buffer0(:)
36    INTEGER                  :: pack_pos0
37   
38      pack_buffer=>pack_buffer0
39      pack_pos=pack_pos0
40
41    END SUBROUTINE set_pack_buffer
42   
43   
44    SUBROUTINE pack_r(arg)
45      IMPLICIT NONE
46        REAL :: arg
47         
48        CALL packf_r(pack_buffer(pack_pos),pack_pos,arg,1)
49     
50     END SUBROUTINE pack_r
51     
52     SUBROUTINE pack_r1(arg)
53      IMPLICIT NONE
54        REAL :: arg(:)
55       
56        CALL packf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
57       
58     END SUBROUTINE pack_r1
59
60   
61     SUBROUTINE pack_r2(arg)
62      IMPLICIT NONE
63        REAL :: arg(:,:)
64       
65        CALL packf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
66       
67     END SUBROUTINE pack_r2
68     
69     
70     SUBROUTINE pack_r3(arg)
71      IMPLICIT NONE
72        REAL :: arg(:,:,:)
73       
74        CALL packf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
75       
76     END SUBROUTINE pack_r3
77
78     
79     SUBROUTINE pack_r4(arg)
80      IMPLICIT NONE
81        REAL :: arg(:,:,:,:)
82       
83        CALL packf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
84       
85     END SUBROUTINE pack_r4
86
87
88    SUBROUTINE unpack_r(arg)
89      IMPLICIT NONE
90        REAL :: arg
91         
92        CALL unpackf_r(pack_buffer(pack_pos),pack_pos,arg,1)
93     
94     END SUBROUTINE unpack_r
95     
96     SUBROUTINE unpack_r1(arg)
97      IMPLICIT NONE
98        REAL :: arg(:)
99       
100        CALL unpackf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
101       
102     END SUBROUTINE unpack_r1
103
104   
105     SUBROUTINE unpack_r2(arg)
106      IMPLICIT NONE
107        REAL :: arg(:,:)
108       
109        CALL unpackf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
110       
111     END SUBROUTINE unpack_r2
112     
113     
114     SUBROUTINE unpack_r3(arg)
115      IMPLICIT NONE
116        REAL :: arg(:,:,:)
117       
118        CALL unpackf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
119       
120     END SUBROUTINE unpack_r3
121
122     
123     SUBROUTINE unpack_r4(arg)
124      IMPLICIT NONE
125        REAL :: arg(:,:,:,:)
126       
127        CALL unpackf_r(pack_buffer(pack_pos),pack_pos,arg,size(arg))
128       
129     END SUBROUTINE unpack_r4
130
131
132
133
134    SUBROUTINE pack_i(arg)
135      IMPLICIT NONE
136        INTEGER :: arg
137         
138        CALL packf_i(pack_buffer(pack_pos),pack_pos,arg,1)
139     
140     END SUBROUTINE pack_i
141     
142     SUBROUTINE pack_i1(arg)
143      IMPLICIT NONE
144        INTEGER :: arg(:)
145       
146        CALL packf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
147       
148     END SUBROUTINE pack_i1
149
150   
151     SUBROUTINE pack_i2(arg)
152      IMPLICIT NONE
153        INTEGER :: arg(:,:)
154       
155        CALL packf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
156       
157     END SUBROUTINE pack_i2
158     
159     
160     SUBROUTINE pack_i3(arg)
161      IMPLICIT NONE
162        INTEGER :: arg(:,:,:)
163       
164        CALL packf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
165       
166     END SUBROUTINE pack_i3
167
168     
169     SUBROUTINE pack_i4(arg)
170      IMPLICIT NONE
171        INTEGER :: arg(:,:,:,:)
172       
173        CALL packf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
174       
175     END SUBROUTINE pack_i4
176     
177
178    SUBROUTINE unpack_i(arg)
179      IMPLICIT NONE
180        INTEGER :: arg
181         
182        CALL unpackf_i(pack_buffer(pack_pos),pack_pos,arg,1)
183     
184     END SUBROUTINE unpack_i
185     
186     SUBROUTINE unpack_i1(arg)
187      IMPLICIT NONE
188        INTEGER :: arg(:)
189       
190        CALL unpackf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
191       
192     END SUBROUTINE unpack_i1
193
194   
195     SUBROUTINE unpack_i2(arg)
196      IMPLICIT NONE
197        INTEGER :: arg(:,:)
198       
199        CALL unpackf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
200       
201     END SUBROUTINE unpack_i2
202     
203     
204     SUBROUTINE unpack_i3(arg)
205      IMPLICIT NONE
206        INTEGER :: arg(:,:,:)
207       
208        CALL unpackf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
209       
210     END SUBROUTINE unpack_i3
211
212     
213     SUBROUTINE unpack_i4(arg)
214      IMPLICIT NONE
215        INTEGER :: arg(:,:,:,:)
216       
217        CALL unpackf_i(pack_buffer(pack_pos),pack_pos,arg,size(arg))
218       
219     END SUBROUTINE unpack_i4     
220
221
222
223
224
225
226
227    SUBROUTINE pack_l(arg)
228      IMPLICIT NONE
229        LOGICAL :: arg
230         
231        CALL packf_l(pack_buffer(pack_pos),pack_pos,arg,1)
232     
233     END SUBROUTINE pack_l
234     
235     SUBROUTINE pack_l1(arg)
236      IMPLICIT NONE
237        LOGICAL :: arg(:)
238       
239        CALL packf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
240       
241     END SUBROUTINE pack_l1
242
243   
244     SUBROUTINE pack_l2(arg)
245      IMPLICIT NONE
246        LOGICAL :: arg(:,:)
247       
248        CALL packf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
249       
250     END SUBROUTINE pack_l2
251     
252     
253     SUBROUTINE pack_l3(arg)
254      IMPLICIT NONE
255        LOGICAL :: arg(:,:,:)
256       
257        CALL packf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
258       
259     END SUBROUTINE pack_l3
260
261     
262     SUBROUTINE pack_l4(arg)
263      IMPLICIT NONE
264        LOGICAL :: arg(:,:,:,:)
265       
266        CALL packf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
267       
268     END SUBROUTINE pack_l4
269     
270
271    SUBROUTINE unpack_l(arg)
272      IMPLICIT NONE
273        LOGICAL :: arg
274         
275        CALL unpackf_l(pack_buffer(pack_pos),pack_pos,arg,1)
276     
277     END SUBROUTINE unpack_l
278     
279     SUBROUTINE unpack_l1(arg)
280      IMPLICIT NONE
281        LOGICAL :: arg(:)
282       
283        CALL unpackf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
284       
285     END SUBROUTINE unpack_l1
286
287   
288     SUBROUTINE unpack_l2(arg)
289      IMPLICIT NONE
290        LOGICAL :: arg(:,:)
291       
292        CALL unpackf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
293       
294     END SUBROUTINE unpack_l2
295     
296     
297     SUBROUTINE unpack_l3(arg)
298      IMPLICIT NONE
299        LOGICAL :: arg(:,:,:)
300       
301        CALL unpackf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
302       
303     END SUBROUTINE unpack_l3
304
305     
306     SUBROUTINE unpack_l4(arg)
307      IMPLICIT NONE
308        LOGICAL :: arg(:,:,:,:)
309       
310        CALL unpackf_l(pack_buffer(pack_pos),pack_pos,arg,size(arg))
311       
312     END SUBROUTINE unpack_l4     
313
314
315
316
317   
318     
319   SUBROUTINE pack_c(arg)
320      IMPLICIT NONE
321        CHARACTER(len=*) :: arg
322         
323        CALL packf_c(pack_buffer(pack_pos),pack_pos,arg,len(arg))
324     
325     END SUBROUTINE pack_c
326     
327     SUBROUTINE pack_c1(arg)
328      IMPLICIT NONE
329        CHARACTER(len=*) :: arg(:)
330       
331        CALL packf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1)))
332       
333     END SUBROUTINE pack_c1
334
335   
336     SUBROUTINE pack_c2(arg)
337      IMPLICIT NONE
338        CHARACTER(len=*) :: arg(:,:)
339       
340        CALL packf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1)))
341       
342     END SUBROUTINE pack_c2
343     
344     
345     SUBROUTINE pack_c3(arg)
346      IMPLICIT NONE
347        CHARACTER(len=*) :: arg(:,:,:)
348       
349        CALL packf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1,1)))
350       
351     END SUBROUTINE pack_c3
352
353     
354     SUBROUTINE pack_c4(arg)
355      IMPLICIT NONE
356        CHARACTER(len=*) :: arg(:,:,:,:)
357       
358        CALL packf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1,1,1)))
359       
360     END SUBROUTINE pack_c4
361     
362
363    SUBROUTINE unpack_c(arg)
364      IMPLICIT NONE
365        CHARACTER(len=*) :: arg
366         
367        CALL unpackf_c(pack_buffer(pack_pos),pack_pos,arg,len(arg))
368     
369     END SUBROUTINE unpack_c
370     
371     SUBROUTINE unpack_c1(arg)
372      IMPLICIT NONE
373        CHARACTER(len=*) :: arg(:)
374       
375        CALL unpackf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1)))
376       
377     END SUBROUTINE unpack_c1
378
379   
380     SUBROUTINE unpack_c2(arg)
381      IMPLICIT NONE
382        CHARACTER(len=*) :: arg(:,:)
383       
384        CALL unpackf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1)))
385       
386     END SUBROUTINE unpack_c2
387     
388     
389     SUBROUTINE unpack_c3(arg)
390      IMPLICIT NONE
391        CHARACTER(len=*) :: arg(:,:,:)
392       
393        CALL unpackf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1,1)))
394       
395     END SUBROUTINE unpack_c3
396
397     
398     SUBROUTINE unpack_c4(arg)
399      IMPLICIT NONE
400        CHARACTER(len=*) :: arg(:,:,:,:)
401       
402        CALL unpackf_c(pack_buffer(pack_pos),pack_pos,arg,size(arg)*len(arg(1,1,1,1)))
403       
404     END SUBROUTINE unpack_c4     
405     
406
407
408
409
410     SUBROUTINE pack_field1(arg)
411     IMPLICIT NONE
412       REAL :: arg(:)
413     
414       CALL packf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
415     END SUBROUTINE pack_field1
416
417
418     SUBROUTINE pack_field2(arg)
419     IMPLICIT NONE
420       REAL :: arg(:,:)
421       
422       CALL packf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
423     END SUBROUTINE pack_field2
424     
425     SUBROUTINE pack_field3(arg)
426     IMPLICIT NONE
427       REAL :: arg(:,:,:)
428     
429       CALL packf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
430     END SUBROUTINE pack_field3
431
432     SUBROUTINE pack_field4(arg)
433     IMPLICIT NONE
434       REAL :: arg(:,:,:,:)
435     
436       CALL packf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
437     END SUBROUTINE pack_field4
438
439
440
441     SUBROUTINE unpack_field1(arg)
442     IMPLICIT NONE
443       REAL :: arg(:)
444     
445       CALL unpackf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
446     END SUBROUTINE unpack_field1
447
448
449     SUBROUTINE unpack_field2(arg)
450     IMPLICIT NONE
451       REAL :: arg(:,:)
452     
453       CALL unpackf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
454     END SUBROUTINE unpack_field2
455     
456     SUBROUTINE unpack_field3(arg)
457     IMPLICIT NONE
458       REAL :: arg(:,:,:)
459     
460       CALL unpackf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
461     END SUBROUTINE unpack_field3
462
463     SUBROUTINE unpack_field4(arg)
464     IMPLICIT NONE
465       REAL :: arg(:,:,:,:)
466     
467       CALL unpackf_field(pack_buffer(pack_pos),pack_pos,arg,size(arg)) 
468     END SUBROUTINE unpack_field4
469     
470     SUBROUTINE pack_attr(attrib)
471     USE mod_attribut
472     USE mod_stdtype
473     IMPLICIT NONE
474       TYPE(attribut) :: attrib
475
476       CALL pack(attrib%object)
477       CALL pack(attrib%name)
478       CALL pack(attrib%type)
479       CALL pack(attrib%dim)
480       CALL pack(attrib%ndim)
481       CALL pack(attrib%string_len)
482             
483       SELECT CASE(attrib%type)
484         CASE (integer0)
485           CALL pack(attrib%integer0_ptr)
486         CASE (integer1)
487           CALL pack(attrib%integer1_ptr)
488         CASE (integer2)
489           CALL pack(attrib%integer2_ptr)
490         CASE (real0)
491           CALL pack(attrib%real0_ptr)
492         CASE (real1)
493           CALL pack(attrib%real1_ptr)
494         CASE (real2)
495           CALL pack(attrib%real2_ptr)
496         CASE (logical0)
497           CALL pack(attrib%logical0_ptr)
498         CASE (logical1)
499           CALL pack(attrib%logical1_ptr)
500         CASE (logical2)
501           CALL pack(attrib%logical2_ptr)
502         CASE (string0)
503           CALL pack_string0(attrib%string0_ptr)
504         CASE (string1)
505           CALL pack_string1(attrib%string1_ptr)
506         CASE (string2)
507           CALL pack(attrib%string2_ptr)
508       END SELECT
509
510     CONTAINS
511
512       SUBROUTINE pack_string0(str)
513         CHARACTER(LEN=attrib%string_len) ::str
514           CALL pack(str)
515       END SUBROUTINE
516
517       SUBROUTINE pack_string1(str)
518         CHARACTER(LEN=attrib%string_len) ::str(:)
519           CALL pack(str)
520       END SUBROUTINE
521       
522       SUBROUTINE pack_string2(str)
523         CHARACTER(LEN=attrib%string_len) ::str(:,:)
524           CALL pack(str)
525       END SUBROUTINE
526
527     END SUBROUTINE pack_attr 
528
529     SUBROUTINE unpack_attr(attrib)
530     USE mod_attribut
531     USE mod_stdtype
532     IMPLICIT NONE
533       TYPE(attribut) :: attrib
534
535       CALL unpack(attrib%object)
536       CALL unpack(attrib%name)
537       CALL unpack(attrib%type)
538       CALL unpack(attrib%dim)
539       CALL unpack(attrib%ndim)
540       CALL unpack(attrib%string_len)
541             
542       SELECT CASE(attrib%type)
543         CASE (integer0)
544           ALLOCATE(attrib%integer0_ptr)
545           CALL unpack(attrib%integer0_ptr)
546         CASE (integer1)
547           ALLOCATE(attrib%integer1_ptr(attrib%dim(1)))
548           CALL unpack(attrib%integer1_ptr)
549         CASE (integer2)
550           ALLOCATE(attrib%integer2_ptr(attrib%dim(1),attrib%dim(2)))
551           CALL unpack(attrib%integer2_ptr)
552         CASE (real0)
553           ALLOCATE(attrib%real0_ptr)
554           CALL unpack(attrib%real0_ptr)
555         CASE (real1)
556           ALLOCATE(attrib%real1_ptr(attrib%dim(1)))
557           CALL unpack(attrib%real1_ptr)
558         CASE (real2)
559           ALLOCATE(attrib%real2_ptr(attrib%dim(1),attrib%dim(2)))
560         CASE (logical0)
561           ALLOCATE(attrib%logical0_ptr)
562           CALL unpack(attrib%logical0_ptr)
563         CASE (logical1)
564           ALLOCATE(attrib%logical1_ptr(attrib%dim(1)))
565           CALL unpack(attrib%logical1_ptr)
566         CASE (logical2)
567           ALLOCATE(attrib%logical2_ptr(attrib%dim(1),attrib%dim(2)))
568           CALL unpack(attrib%logical2_ptr)
569         CASE (string0)
570           ALLOCATE(attrib%string0_ptr)
571           CALL unpack_string0
572         CASE (string1)
573           ALLOCATE(attrib%string1_ptr(attrib%dim(1)))
574           CALL unpack_string1
575         CASE (string2)
576           ALLOCATE(attrib%string2_ptr(attrib%dim(1),attrib%dim(2)))
577           CALL unpack_string2
578       END SELECT
579
580     CONTAINS
581
582       SUBROUTINE unpack_string0
583         CHARACTER(LEN=attrib%string_len) ::str
584           CALL unpack(str)
585           attrib%string0_ptr=str
586       END SUBROUTINE
587
588       SUBROUTINE unpack_string1
589         CHARACTER(LEN=attrib%string_len) ::str(attrib%dim(1))
590           CALL unpack(str)
591           attrib%string1_ptr=str
592       END SUBROUTINE
593       
594       SUBROUTINE unpack_string2
595         CHARACTER(LEN=attrib%string_len) ::str(attrib%dim(1),attrib%dim(2))
596           CALL unpack(str)
597           attrib%string2_ptr=str
598       END SUBROUTINE
599
600     END SUBROUTINE unpack_attr             
601
602     
603  END MODULE mod_pack
Note: See TracBrowser for help on using the repository browser.