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.
iom_rstdimg.f90 in branches/UKMO/dev_r5518_v3.6_asm_nemovar_community/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/UKMO/dev_r5518_v3.6_asm_nemovar_community/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90 @ 7731

Last change on this file since 7731 was 7731, checked in by dford, 7 years ago

Merge in revisions 6625:7726 of dev_r5518_v3.4_asm_nemovar_community, so this branch will be identical to revison 7726 of dev_r5518_v3.6_asm_nemovar_community.

File size: 63.6 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! MODULE: iom_rstdimg
6!
7! DESCRIPTION:
8!> @brief
9!> This module is a library to read/write dimg file.
10!>
11!> @details
12!>    to open dimg file (create file structure):<br/>
13!> @code
14!>    CALL iom_rstdimg_open(td_file)
15!> @endcode
16!>       - td_file is file structure (see file.f90)
17!>
18!>    to write in dimg file:<br/>
19!> @code
20!>    CALL  iom_rstdimg_write_file(td_file)
21!> @endcode
22!>
23!>    to close dimg file:<br/>
24!> @code
25!>    CALL iom_rstdimg_close(tl_file)
26!> @endcode
27!>
28!>    to read one dimension in dimg file:<br/>
29!> @code
30!>    tl_dim = iom_rstdimg_read_dim(tl_file, id_dimid)
31!> @endcode
32!>    or
33!> @code
34!>    tl_dim = iom_rstdimg_read_dim(tl_file, cd_name)
35!> @endcode
36!>       - id_dimid is dimension id<br/>
37!>       - cd_name is dimension name
38!>
39!>    to read one variable in dimg file:<br/>
40!> @code
41!>    tl_var = iom_rstdimg_read_var(td_file, id_varid, [id_start, id_count])
42!> @endcode
43!>    or
44!> @code
45!>    tl_var = iom_rstdimg_read_var(td_file, cd_name, [id_start, [id_count]])
46!> @endcode
47!>       - id_varid is variabale id
48!>       - cd_name is variabale name or standard name
49!>       - id_start is a integer(4) 1D array of index from which the data
50!>          values will be read [optional]
51!>       - id_count is a integer(4) 1D array of the number of indices selected
52!>          along each dimension [optional]
53!>
54!>    to get sub domain decomppistion in a dimg file:<br/>
55!> @code
56!>    CALL iom_rstdimg_get_mpp(td_file)
57!> @endcode
58!>
59!> @author
60!> J.Paul
61! REVISION HISTORY:
62!> @date November, 2013 - Initial Version
63!
64!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
65!----------------------------------------------------------------------
66MODULE iom_rstdimg
67   USE netcdf                          ! nf90 library
68   USE global                          ! global parameter
69   USE kind                            ! F90 kind parameter
70   USE fct                             ! basic useful function
71   USE logger                          ! log file manager
72   USE att                             ! attribute manager
73   USE dim                             ! dimension manager
74   USE var                             ! variable manager
75   USE file                            ! file manager
76   IMPLICIT NONE
77   ! NOTE_avoid_public_variables_if_possible
78
79   ! type and variable
80   PRIVATE ::  im_vnl !< variable name length
81
82   ! function and subroutine
83   PUBLIC :: iom_rstdimg_open        !< open or create dimg file, return file structure
84   PUBLIC :: iom_rstdimg_close       !< close dimg file
85   PUBLIC :: iom_rstdimg_read_dim    !< read one dimension in an opened dimg file, return variable structure
86   PUBLIC :: iom_rstdimg_read_var    !< read one variable  in an opened dimg file, return dimension structure
87   PUBLIC :: iom_rstdimg_write_file  !< write file structure contents in an opened dimg file
88   PUBLIC :: iom_rstdimg_get_mpp     !< get sub domain decomppistion in a dimg file
89
90   PRIVATE :: iom_rstdimg__get_info        ! get global information in an opened dimg file
91   PRIVATE :: iom_rstdimg__get_file_var    ! read information about variable on an opened dimg file.
92   PRIVATE :: iom_rstdimg__get_file_var_0d ! put information about scalar variable in file structure
93   PRIVATE :: iom_rstdimg__get_file_var_1d ! put information about variable 1D in file structure
94   PRIVATE :: iom_rstdimg__get_file_var_2d ! put information about variable 2D in file structure
95   PRIVATE :: iom_rstdimg__get_file_var_3d ! put information about variable 3D in file structure
96   PRIVATE :: iom_rstdimg__read_dim_id     ! read dimension structure in an opened dimg file, given variable id.
97   PRIVATE :: iom_rstdimg__read_dim_name   ! read dimension structure in an opened dimg file, given variable name or standard name.
98   PRIVATE :: iom_rstdimg__read_var_id     ! read variable value in an opened dimg file, given variable id.
99   PRIVATE :: iom_rstdimg__read_var_name   ! read variable value in an opened dimg file, given variable name or standard name.
100   PRIVATE :: iom_rstdimg__read_var_value  ! read variable value in an opened dimg file, for variable 1,2,3d
101   PRIVATE :: iom_rstdimg__get_rec         ! compute record number before writing file
102   PRIVATE :: iom_rstdimg__write_header    ! write header in an opened dimg file
103   PRIVATE :: iom_rstdimg__write_var       ! write variables in an opened dimg file
104
105   ! module variable
106   INTEGER(i4), PARAMETER :: im_vnl = 32 ! variable name length
107
108   INTERFACE iom_rstdimg_read_dim
109      MODULE PROCEDURE iom_rstdimg__read_dim_id
110      MODULE PROCEDURE iom_rstdimg__read_dim_name
111   END INTERFACE iom_rstdimg_read_dim
112
113   INTERFACE iom_rstdimg_read_var
114      MODULE PROCEDURE iom_rstdimg__read_var_id
115      MODULE PROCEDURE iom_rstdimg__read_var_name
116   END INTERFACE iom_rstdimg_read_var
117
118CONTAINS
119   !-------------------------------------------------------------------
120   !> @brief This subroutine open a dimg file in read or write mode.
121   !> @details
122   !> if try to open a file in write mode that did not exist, create it.<br/>
123   !> if file already exist, get information about:
124   !> - the number of variables
125   !> - the number of dimensions
126   !> - the number of global attributes
127   !> - the ID of the unlimited dimension
128   !> - the file format
129   !> Finally it read dimensions, and 'longitude' variable to compute East-West
130   !> overlap.
131   !>
132   !> @author J.Paul
133   !> @date November, 2013 - Initial Version
134   !
135   !> @param[inout] td_file   file structure
136   !-------------------------------------------------------------------
137   SUBROUTINE iom_rstdimg_open(td_file)
138      IMPLICIT NONE
139      ! Argument     
140      TYPE(TFILE), INTENT(INOUT)  :: td_file
141
142      ! local variable
143      LOGICAL           :: ll_exist
144      LOGICAL           :: ll_open
145
146      INTEGER(i4)       :: il_status
147      !----------------------------------------------------------------
148
149      ! check file existence
150      ! WARNING may be some issue with dimg file !!!
151      INQUIRE(FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open)
152      IF( .NOT. ll_exist .OR. TRIM(td_file%c_type) /= 'dimg' )THEN
153
154         IF( .NOT. td_file%l_wrt )THEN
155
156            CALL logger_fatal( " OPEN: can not open dimg file "//&
157            &               TRIM(td_file%c_name) )
158         
159         ELSE
160
161            CALL logger_info( " CREATE: dimg file "//TRIM(td_file%c_name) )
162
163            ! get free unit
164            td_file%i_id=fct_getunit()
165
166            OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
167            &                         FORM='UNFORMATTED',              &
168            &                         ACCESS='DIRECT',                 &
169            &                         STATUS='NEW',                    &
170            &                         ACTION='WRITE',                  &
171            &                         RECL=8,                          &
172            &                         IOSTAT=il_status)
173            CALL fct_err(il_status)
174            IF( il_status /= 0 )THEN
175               CALL logger_error("CREATE: dimg file "//&
176               &              TRIM(td_file%c_name))
177            ENDIF
178
179         ENDIF
180
181      ELSE
182
183         IF( ll_open )THEN
184
185            CALL logger_error( " OPEN: dimg file "//&
186            &                TRIM(td_file%c_name)//" already opened")
187
188         ELSE
189
190            ! get free unit
191            td_file%i_id=fct_getunit()
192
193            ! open temporary in read only mode
194            OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
195            &                         FORM='UNFORMATTED',              &
196            &                         ACCESS='DIRECT',                 &
197            &                         STATUS='OLD',                    &
198            &                         ACTION='READ',                   &
199            &                         RECL=8,                          &
200            &                         IOSTAT=il_status)
201            CALL fct_err(il_status)
202            IF( il_status /= 0 )THEN
203               CALL logger_error("OPEN: file "//TRIM(td_file%c_name))
204            ENDIF
205
206            ! get record length
207            READ( td_file%i_id, IOSTAT=il_status, &
208            &                         REC=1) td_file%i_recl
209            CALL fct_err(il_status)
210            IF( il_status /= 0 )THEN
211               CALL logger_error("OPEN: read record length : "//&
212               &    TRIM(fct_str(td_file%i_recl))//" in file "//&
213               &    TRIM(td_file%c_name) )
214            ENDIF
215
216            CLOSE( td_file%i_id, IOSTAT=il_status )
217            CALL fct_err(il_status)
218            IF( il_status /= 0 )THEN
219               CALL logger_error("OPEN: close file "//TRIM(td_file%c_name))
220            ENDIF
221
222            IF( .NOT. td_file%l_wrt )THEN
223
224               CALL logger_info( " OPEN: dimg file "//&
225               &              TRIM(td_file%c_name)//" in read only mode" )
226
227               ! open file in read mode
228               OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
229               &                         FORM='UNFORMATTED',              &
230               &                         ACCESS='DIRECT',                 &
231               &                         STATUS='OLD',                    &
232               &                         ACTION='READ',                   &
233               &                         RECL=td_file%i_recl,    &
234               &                         IOSTAT=il_status)
235               CALL fct_err(il_status)
236               IF( il_status /= 0 )THEN
237                  CALL logger_debug("IOM RSTDIMG OPEN: open staus "//&
238                  &  TRIM(fct_str(il_status)))
239                  CALL logger_fatal("IOM RSTDIMG OPEN: file "//&
240                  &  TRIM(td_file%c_name)&
241                  &  //" with record length "//TRIM(fct_str(td_file%i_recl)))
242               ENDIF               
243
244            ELSE
245
246               CALL logger_info( " OPEN: dimg file "//&
247               &              TRIM(td_file%c_name)//&
248               &              " in read and write mode")
249
250               ! open file in read mode
251               OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
252               &                         FORM='UNFORMATTED',              &
253               &                         ACCESS='DIRECT',                 &
254               &                         STATUS='OLD',                    &
255               &                         ACTION='READWRITE',              &
256               &                         RECL=td_file%i_recl,    &
257               &                         IOSTAT=il_status)
258               CALL fct_err(il_status)
259               IF( il_status /= 0 )THEN
260                  CALL logger_debug("IOM RSTDIMG OPEN: open staus "//&
261                  &  TRIM(fct_str(il_status)))
262                  CALL logger_error("IOM RSTDIMG  OPEN: file "//&
263                  & TRIM(td_file%c_name))
264               ENDIF       
265
266            ENDIF
267
268            ! get general information about file
269            CALL iom_rstdimg__get_info(td_file)
270
271            ! get domain decomposition in file
272            CALL iom_rstdimg_get_mpp(td_file)
273
274            ! get information about variables in file
275            CALL iom_rstdimg__get_file_var(td_file)
276
277         ENDIF
278
279      ENDIF
280
281   END SUBROUTINE iom_rstdimg_open
282   !-------------------------------------------------------------------
283   !> @brief This subroutine close dimg file.
284   !>
285   !> @author J.Paul
286   !> @date November, 2013 - Initial Version
287   !
288   !> @param[inout] td_file   file structure
289   !-------------------------------------------------------------------
290   SUBROUTINE iom_rstdimg_close(td_file)
291      IMPLICIT NONE
292      ! Argument     
293      TYPE(TFILE), INTENT(INOUT) :: td_file
294
295      ! local variable
296      INTEGER(i4) :: il_status
297      !----------------------------------------------------------------
298
299      ! check if file opened
300      IF( td_file%i_id == 0 )THEN
301
302         CALL logger_error( &
303         &  " CLOSE: no id associated to file "//TRIM(td_file%c_name))
304
305      ELSE     
306         CALL logger_info( &
307         &  " CLOSE: file "//TRIM(td_file%c_name))
308
309         CLOSE( td_file%i_id, IOSTAT=il_status )
310         CALL fct_err(il_status)
311         IF( il_status /= 0 )THEN
312            CALL logger_error("CLOSE "//TRIM(td_file%c_name))
313         ENDIF
314
315         td_file%i_id = 0 
316
317      ENDIF
318
319   END SUBROUTINE iom_rstdimg_close
320   !-------------------------------------------------------------------
321   !> @brief This subroutine get global information in an opened dimg
322   !> file.
323   !> @details
324   !> It gets the number of variables, the  domain decompistion,
325   !> the record of the header.<br/>
326   !> It read dimensions, and add it to dimension structure inside
327   !> file structure.
328   !>
329   !> @author J.Paul
330   !> @date November, 2013 - Initial Version
331   !
332   !> @param[inout] td_file   file structure
333   !-------------------------------------------------------------------
334   SUBROUTINE iom_rstdimg__get_info(td_file)
335      IMPLICIT NONE
336      ! Argument     
337      TYPE(TFILE), INTENT(INOUT) :: td_file
338
339      ! local variable
340      INTEGER(i4) :: il_status
341      INTEGER(i4) :: il_recl                          ! record length
342      INTEGER(i4) :: il_nx, il_ny, il_nz              ! x,y,z dimension
343      INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d   ! number of 0/1/2/3D variables
344      INTEGER(i4) :: il_rhd                           ! record of the header infos
345
346      TYPE(TDIM)  :: tl_dim ! dimension structure
347      !----------------------------------------------------------------
348
349      CALL logger_debug( &
350      &  " IOM RSTDIMG GET INFO: about dimg file "//TRIM(td_file%c_name))
351
352      ! read first record
353      READ( td_file%i_id, IOSTAT=il_status, REC=1 )& 
354      &     il_recl,                         &
355      &     il_nx, il_ny, il_nz,             &
356      &     il_n0d, il_n1d, il_n2d, il_n3d,  &
357      &     il_rhd
358      CALL fct_err(il_status)
359      IF( il_status /= 0 )THEN
360         CALL logger_debug(" READ status: "//TRIM(fct_str(il_status)))
361         CALL logger_fatal("IOM RSTDIMG GET INFO: read first line of "//&
362         &  TRIM(td_file%c_name))
363      ENDIF
364
365      td_file%c_type='dimg'
366
367      ! add dimension to file structure
368      tl_dim=dim_init('X', il_nx)
369      CALL file_move_dim(td_file, tl_dim)
370      tl_dim=dim_init('Y', il_ny)
371      CALL file_move_dim(td_file, tl_dim)
372      tl_dim=dim_init('Z', il_nz)
373      CALL file_move_dim(td_file, tl_dim)
374
375      ! reorder dimension to ('x','y','z','t')
376      ! actually fill unused dimension
377      CALL dim_reorder(td_file%t_dim)
378
379      ! save total number of variable
380      td_file%i_n0d=il_n0d
381      td_file%i_n1d=il_n1d
382      td_file%i_n2d=il_n2d
383      td_file%i_n3d=il_n3d
384      td_file%i_nvar=il_n0d+il_n1d+il_n2d+il_n3d
385
386      ! record header infos
387      td_file%i_rhd=il_rhd
388
389   END SUBROUTINE iom_rstdimg__get_info
390   !-------------------------------------------------------------------
391   !> @brief This subroutine get sub domain decomposition in a dimg file.
392   !> @details
393   !> domain decomposition informations are saved in attributes.
394   !>
395   !> @author J.Paul
396   !> @date November, 2013 - Initial Version
397   !
398   !> @param[inout] td_file   file structure
399   !-------------------------------------------------------------------
400   SUBROUTINE iom_rstdimg_get_mpp(td_file)
401      IMPLICIT NONE
402      ! Argument     
403      TYPE(TFILE), INTENT(INOUT) :: td_file
404
405      ! local variable
406      TYPE(TATT)  :: tl_att
407      INTEGER(i4) :: il_status
408      INTEGER(i4) :: il_recl                          ! record length
409      INTEGER(i4) :: il_nx, il_ny, il_nz              ! x,y,z dimension
410      INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d   ! number of 0/1/2/3D variables
411      INTEGER(i4) :: il_iglo, il_jglo                 ! domain global size
412      INTEGER(i4) :: il_rhd                           ! record of the header infos
413      INTEGER(i4) :: il_niproc, il_njproc, il_nproc   ! domain decomposition
414      INTEGER(i4) :: il_area                          ! domain index
415
416      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp
417      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp
418      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci
419      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj
420      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi
421      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj
422      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei
423      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej
424      !----------------------------------------------------------------
425
426      CALL logger_debug( " IOM RSTDIMG GET MPP: dimg file "//&
427      &  TRIM(td_file%c_name))
428
429      ! read first record
430      READ( td_file%i_id, IOSTAT=il_status, REC=1 )& 
431      &     il_recl,                         &
432      &     il_nx, il_ny, il_nz,             &
433      &     il_n0d, il_n1d, il_n2d, il_n3d,  &
434      &     il_rhd,                          &
435      &     il_niproc, il_njproc, il_nproc,  &
436      &     il_area,                         &
437      &     il_iglo, il_jglo
438      CALL fct_err(il_status)
439      IF( il_status /= 0 )THEN
440         CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//&
441         &  TRIM(fct_str(il_status)))
442         CALL logger_error(" IOM RSTDIMG GET MPP: read first line of "//&
443         &  TRIM(td_file%c_name))
444      ENDIF
445
446      ! create attributes to save mpp value
447      tl_att=att_init( "DOMAIN_number_total", il_nproc)
448      CALL file_move_att(td_file, tl_att)
449
450      tl_att=att_init( "DOMAIN_I_number_total", il_niproc)
451      CALL file_move_att(td_file, tl_att)
452
453      tl_att=att_init( "DOMAIN_J_number_total", il_njproc)
454      CALL file_move_att(td_file, tl_att)
455
456      tl_att=att_init( "DOMAIN_number", il_area)
457      CALL file_move_att(td_file, tl_att)
458
459      tl_att=att_init( "DOMAIN_size_global", (/il_iglo, il_jglo/))
460      CALL file_move_att(td_file, tl_att)
461
462      ! allocate local variable
463      ALLOCATE( il_impp(il_nproc), il_jmpp(il_nproc),&
464      &         il_lci(il_nproc),  il_lcj(il_nproc), &
465      &         il_ldi(il_nproc),  il_ldj(il_nproc), &
466      &         il_lei(il_nproc),  il_lej(il_nproc), &
467      &         stat=il_status)
468      IF(il_status /= 0 )THEN
469
470         CALL logger_error( " IOM RSTDIMG GET MPP: not enough space to put "//&
471         &  "domain decomposition in file "//TRIM(td_file%c_name) )
472
473      ENDIF
474
475      ! read first record
476      READ( td_file%i_id, IOSTAT=il_status, REC=1 )& 
477      &     il_recl,                         &
478      &     il_nx, il_ny, il_nz,             &
479      &     il_n0d, il_n1d, il_n2d, il_n3d,  &
480      &     il_rhd,                          &
481      &     il_niproc, il_njproc, il_nproc,  &
482      &     il_area,                         &
483      &     il_iglo, il_jglo,                &
484      &     il_lci(:), il_lcj(:),            &
485      &     il_ldi(:), il_ldj(:),            &
486      &     il_lei(:), il_lej(:),            &
487      &     il_impp(:),il_jmpp(:)
488      CALL fct_err(il_status)
489      IF( il_status /= 0 )THEN
490         CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//&
491         &  TRIM(fct_str(il_status)))
492         CALL logger_fatal("IOM RSTDIMG GET MPP: read domain decomposition "//&
493         &           "on first line of "//TRIM(td_file%c_name))
494      ENDIF
495
496      tl_att=att_init( "DOMAIN_position_first", (/il_impp(il_area), il_jmpp(il_area)/))
497      CALL file_move_att(td_file, tl_att)
498
499      tl_att=att_init( "DOMAIN_position_last", (/il_lci(il_area), il_lcj(il_area)/))
500      CALL file_move_att(td_file, tl_att)
501
502      tl_att=att_init( "DOMAIN_halo_size_start", (/il_ldi(il_area), il_ldj(il_area)/))
503      CALL file_move_att(td_file, tl_att)
504
505      tl_att=att_init( "DOMAIN_halo_size_end", (/il_lei(il_area), il_lej(il_area)/))
506      CALL file_move_att(td_file, tl_att)
507
508      tl_att=att_init( "DOMAIN_I_position_first", il_impp(:) )
509      CALL file_move_att(td_file, tl_att)
510      tl_att=att_init( "DOMAIN_J_position_first", il_jmpp(:) )
511      CALL file_move_att(td_file, tl_att)
512
513      tl_att=att_init( "DOMAIN_I_position_last", il_lci(:) )
514      CALL file_move_att(td_file, tl_att)
515      tl_att=att_init( "DOMAIN_J_position_last", il_lcj(:) )
516      CALL file_move_att(td_file, tl_att)
517
518      tl_att=att_init( "DOMAIN_I_halo_size_start", il_ldi(:) )
519      CALL file_move_att(td_file, tl_att)
520      tl_att=att_init( "DOMAIN_J_halo_size_start", il_ldj(:) )
521      CALL file_move_att(td_file, tl_att)
522
523      tl_att=att_init( "DOMAIN_I_halo_size_end", il_lei(:) )
524      CALL file_move_att(td_file, tl_att)
525      tl_att=att_init( "DOMAIN_J_halo_size_end", il_lej(:) )
526      CALL file_move_att(td_file, tl_att)
527
528      ! clean
529      CALL att_clean(tl_att)
530
531      DEALLOCATE( il_impp, il_jmpp,&
532      &           il_lci,  il_lcj, &
533      &           il_ldi,  il_ldj, &
534      &           il_lei,  il_lej  )
535
536   END SUBROUTINE iom_rstdimg_get_mpp
537   !-------------------------------------------------------------------
538   !> @brief This subroutine read information about variable on an
539   !> opened dimg file.
540   !> @details
541   !> The variables structures inside file structure are then completed.
542   !> Variables no0d, no1d, no2d, no3d are deleted from file strucutre.
543   !> @note variable value are read only for scalar variable (0d).
544   !
545   !> @author J.Paul
546   !> @date November, 2013 - Initial Version
547   !
548   !> @param[inout] td_file   file structure
549   !-------------------------------------------------------------------
550   SUBROUTINE iom_rstdimg__get_file_var(td_file)
551      IMPLICIT NONE
552      ! Argument     
553      TYPE(TFILE), INTENT(INOUT) :: td_file
554
555      ! local variable
556      CHARACTER(LEN=im_vnl), DIMENSION(:), ALLOCATABLE :: cl_name
557
558      REAL(dp)             , DIMENSION(:), ALLOCATABLE :: dl_value
559
560      INTEGER(i4)                                      :: il_status
561      INTEGER(i4)          , DIMENSION(:), ALLOCATABLE :: il_start
562      INTEGER(i4)          , DIMENSION(:), ALLOCATABLE :: il_count
563
564      !----------------------------------------------------------------
565
566      IF( td_file%i_nvar > 0 )THEN
567
568         ALLOCATE( il_start(4), il_count(4) )
569
570         il_start(1) = 1
571         il_count(1) = td_file%i_n0d
572         
573         il_start(2) = 1 + il_count(1)
574         il_count(2) = il_start(2) - 1 + td_file%i_n1d
575         
576         il_start(3) = 1 + il_count(2)
577         il_count(3) = il_start(3) - 1 + td_file%i_n2d
578         
579         il_start(4) = 1 + il_count(3)
580         il_count(4) = il_start(4) - 1 + td_file%i_n3d
581         
582         ALLOCATE( cl_name(td_file%i_nvar), dl_value(td_file%i_nvar) )
583
584         ! read first record
585         READ( td_file%i_id, IOSTAT=il_status, REC=td_file%i_rhd )& 
586         & cl_name(il_start(1):il_count(1)), dl_value(il_start(1):il_count(1)),&
587         & cl_name(il_start(2):il_count(2)), dl_value(il_start(2):il_count(2)),&
588         & cl_name(il_start(3):il_count(3)), dl_value(il_start(3):il_count(3)),&
589         & cl_name(il_start(4):il_count(4)), dl_value(il_start(4):il_count(4))
590         CALL fct_err(il_status)
591         IF( il_status /= 0 )THEN
592            CALL logger_error("GET FILE: reading headers in file "//&
593            &   TRIM(td_file%c_name))
594         ENDIF
595
596         DEALLOCATE( il_start, il_count )
597
598         IF(ASSOCIATED(td_file%t_var))THEN
599            CALL var_clean(td_file%t_var(:))
600            DEALLOCATE(td_file%t_var)
601         ENDIF
602         ALLOCATE(td_file%t_var(td_file%i_nvar))
603
604         ! put information about variable 0D inside file structure
605         CALL iom_rstdimg__get_file_var_0d(td_file, cl_name(:), dl_value(:))
606
607         ! put information about variable 1D inside file structure
608         CALL iom_rstdimg__get_file_var_1d(td_file, cl_name(:), dl_value(:))
609
610         ! put information about variable 2D inside file structure
611         CALL iom_rstdimg__get_file_var_2d(td_file, cl_name(:), dl_value(:))
612
613         ! put information about variable 3D inside file structure
614         CALL iom_rstdimg__get_file_var_3d(td_file, cl_name(:), dl_value(:))
615
616         DEALLOCATE( cl_name, dl_value )
617
618         ! delete dummy variable
619         CALL file_del_var( td_file, 'no0d' )
620         CALL file_del_var( td_file, 'no1d' )
621         CALL file_del_var( td_file, 'no2d' )
622         CALL file_del_var( td_file, 'no3d' )
623
624      ELSE
625
626         CALL logger_debug( &
627         &  " GET FILE VAR: there is no variable in file "//&
628         &  TRIM(td_file%c_name))
629
630      ENDIF
631
632   END SUBROUTINE iom_rstdimg__get_file_var
633   !-------------------------------------------------------------------
634   !> @brief This subroutine put informations about scalar variable
635   !> inside file structure.
636   !
637   !> @author J.Paul
638   !> @date November, 2013 - Initial Version
639   !
640   !> @param[inout] td_file   file structure
641   !> @param[in] cd_name      array of variable name
642   !> @param[in] dd_value     array of variable value
643   !-------------------------------------------------------------------
644   SUBROUTINE iom_rstdimg__get_file_var_0d(td_file, cd_name, dd_value)
645      IMPLICIT NONE
646      ! Argument     
647      TYPE(TFILE),                         INTENT(INOUT) :: td_file
648      CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN)    :: cd_name
649      REAL(dp),              DIMENSION(:), INTENT(IN)    :: dd_value
650
651      ! local variable
652      TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
653
654      ! loop indices
655      INTEGER(i4) :: ji
656      !----------------------------------------------------------------
657
658      ! define same dimension as in file
659      tl_dim(:)=dim_copy(td_file%t_dim(:))
660      ! do not use any dimension
661      tl_dim(:)%l_use=.FALSE.
662      tl_dim(:)%i_len=1
663     
664      ! case scalar variable
665      DO ji = 1, td_file%i_n0d
666   
667         td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
668         &                           tl_dim(:), dd_fill=0._dp,       &
669         &                           id_id=ji, id_rec=1 )
670
671         ! get value of scalar
672         IF( ASSOCIATED(td_file%t_var(ji)%d_value) )THEN
673            DEALLOCATE(td_file%t_var(ji)%d_value)
674         ENDIF
675         ALLOCATE(td_file%t_var(ji)%d_value(1,1,1,1))
676
677         td_file%t_var(ji)%d_value(1,1,1,1)=dd_value(ji)
678
679      ENDDO
680
681      ! clean
682      CALL dim_clean(tl_dim(:))
683
684   END SUBROUTINE iom_rstdimg__get_file_var_0d
685   !-------------------------------------------------------------------
686   !> @brief This subroutine put informations about variable 1D
687   !> inside file structure.
688   !
689   !> @author J.Paul
690   !> @date November, 2013 - Initial Version
691   !
692   !> @param[inout] td_file   file structure
693   !> @param[in] cd_name      array of variable name
694   !> @param[in] dd_value     array of variable record
695   !-------------------------------------------------------------------
696   SUBROUTINE iom_rstdimg__get_file_var_1d(td_file, cd_name, dd_value)
697      IMPLICIT NONE
698      ! Argument     
699      TYPE(TFILE),                         INTENT(INOUT) :: td_file
700      CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN)    :: cd_name
701      REAL(dp),              DIMENSION(:), INTENT(IN)    :: dd_value
702
703      ! local variable
704      TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
705
706      ! loop indices
707      INTEGER(i4) :: ji
708      !----------------------------------------------------------------
709
710      ! case variable 1D
711      DO ji = td_file%i_n0d + 1, &
712      &       td_file%i_n0d + td_file%i_n1d
713
714         ! define same dimension as in file
715         tl_dim(:)=dim_copy(td_file%t_dim(:))
716         ! do not use X and Y dimension
717         td_file%t_var(ji)%t_dim(1:2)%l_use=.FALSE.
718         td_file%t_var(ji)%t_dim(1:2)%i_len=1
719     
720         td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
721         &                           tl_dim(:), dd_fill=0._dp,       &
722         &                           id_id=ji, id_rec=INT(dd_value(ji),i4) )
723
724         ! clean
725         CALL dim_clean(tl_dim(:))
726
727      ENDDO
728
729   END SUBROUTINE iom_rstdimg__get_file_var_1d
730   !-------------------------------------------------------------------
731   !> @brief This subroutine put informations about variable 2D
732   !> inside file structure.
733   !
734   !> @author J.Paul
735   !> @date November, 2013 - Initial Version
736   !
737   !> @param[inout] td_file   file structure
738   !> @param[in] cd_name      array of variable name
739   !> @param[in] dd_value     array of variable record
740   !-------------------------------------------------------------------
741   SUBROUTINE iom_rstdimg__get_file_var_2d(td_file, cd_name, dd_value)
742      IMPLICIT NONE
743      ! Argument     
744      TYPE(TFILE),                         INTENT(INOUT) :: td_file
745      CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN)    :: cd_name
746      REAL(dp),              DIMENSION(:), INTENT(IN)    :: dd_value
747
748      ! local variable
749      TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
750
751      ! loop indices
752      INTEGER(i4) :: ji
753      !----------------------------------------------------------------
754
755      ! case variable 2D (X,Y)
756      DO ji = td_file%i_n0d + td_file%i_n1d + 1 , &
757      &       td_file%i_n0d + td_file%i_n1d + td_file%i_n2d
758
759         ! define same dimension as in file
760         tl_dim(:)=dim_copy(td_file%t_dim(:))
761         ! do not use Z dimension
762         tl_dim(3)%l_use=.FALSE.
763         tl_dim(3)%i_len=1       
764
765         td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
766         &                           tl_dim(:), dd_fill=0._dp,       &
767         &                           id_id=ji, id_rec=INT(dd_value(ji),i4) )
768
769         ! clean
770         CALL dim_clean(tl_dim(:))
771
772      ENDDO
773
774   END SUBROUTINE iom_rstdimg__get_file_var_2d
775   !-------------------------------------------------------------------
776   !> @brief This subroutine put informations about variable 3D
777   !> inside file structure.
778   !
779   !> @author J.Paul
780   !> @date November, 2013 - Initial Version
781   !
782   !> @param[inout] td_file   file structure
783   !> @param[in] cd_name      array of variable name
784   !> @param[in] dd_value     array of variable record
785   !-------------------------------------------------------------------
786   SUBROUTINE iom_rstdimg__get_file_var_3d(td_file, cd_name, dd_value)
787      IMPLICIT NONE
788      ! Argument     
789      TYPE(TFILE),                         INTENT(INOUT) :: td_file
790      CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN)    :: cd_name
791      REAL(dp),              DIMENSION(:), INTENT(IN)    :: dd_value
792
793      ! local variable
794      TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
795
796      ! loop indices
797      INTEGER(i4) :: ji
798      !----------------------------------------------------------------
799
800      ! case variable 3D (X,Y,Z)
801      DO ji = td_file%i_n0d + td_file%i_n1d + td_file%i_n2d +1 , &
802      &       td_file%i_n0d + td_file%i_n1d + td_file%i_n2d + td_file%i_n3d
803
804         ! define same dimension as in file
805         tl_dim(:)=dim_copy(td_file%t_dim(:)) 
806
807         td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
808         &                           tl_dim(:), dd_fill=0._dp,       &
809         &                           id_id=ji, id_rec=INT(dd_value(ji),i4) )
810
811         ! clean
812         CALL dim_clean(tl_dim(:))
813
814      ENDDO
815
816   END SUBROUTINE iom_rstdimg__get_file_var_3d
817   !-------------------------------------------------------------------
818   !> @brief This function read one dimension in an opened netcdf file,
819   !> given dimension id.
820   !
821   !> @author J.Paul
822   !> @date November, 2013 - Initial Version
823   !
824   !> @param[in] td_file   file structure
825   !> @param[in] id_dimid  dimension id
826   !> @return  dimension structure
827   !-------------------------------------------------------------------
828   TYPE(TDIM) FUNCTION iom_rstdimg__read_dim_id(td_file, id_dimid)
829      IMPLICIT NONE
830      ! Argument     
831      TYPE(TFILE), INTENT(IN) :: td_file
832      INTEGER(i4), INTENT(IN) :: id_dimid
833      !----------------------------------------------------------------
834
835      ! check if file opened
836      IF( td_file%i_id == 0 )THEN
837
838         CALL logger_error( &
839         &  " READ DIM: no id associated to dimg file "//TRIM(td_file%c_name))
840
841      ELSE     
842
843         iom_rstdimg__read_dim_id%i_id=id_dimid
844
845         CALL logger_debug( &
846         &  " READ DIM: dimension "//TRIM(fct_str(id_dimid))//&
847         &  " in file "//TRIM(td_file%c_name))
848
849         IF( id_dimid <= 4 )THEN
850            iom_rstdimg__read_dim_id=td_file%t_dim(id_dimid)
851         ELSE
852            CALL logger_error( &
853            &  " READ DIM: no dimension with id "//TRIM(fct_str(id_dimid))//&
854            &  " in file "//TRIM(td_file%c_name))
855         ENDIF
856
857      ENDIF
858
859   END FUNCTION iom_rstdimg__read_dim_id
860   !-------------------------------------------------------------------
861   !> @brief This function read one dimension in an opened netcdf file,
862   !> given dimension name.
863   !
864   !> @author J.Paul
865   !> @date November, 2013 - Initial Version
866   !
867   !> @param[in] td_file   file structure
868   !> @param[in] cd_name   dimension name
869   !> @return  dimension structure
870   !-------------------------------------------------------------------
871   TYPE(TDIM) FUNCTION iom_rstdimg__read_dim_name(td_file, cd_name)
872      IMPLICIT NONE
873      ! Argument     
874      TYPE(TFILE),      INTENT(IN) :: td_file
875      CHARACTER(LEN=*), INTENT(IN) :: cd_name
876
877      ! local variable
878      INTEGER(i4) :: il_dimid
879      !----------------------------------------------------------------
880
881      ! check if file opened
882      IF( td_file%i_id == 0 )THEN
883
884         CALL logger_error( &
885         &  " READ DIM: no id associated to dimg file "//TRIM(td_file%c_name))
886
887      ELSE     
888
889         il_dimid=dim_get_id(td_file%t_dim(:), TRIM(cd_name))
890         IF( il_dimid /= 0 )THEN
891            iom_rstdimg__read_dim_name=iom_rstdimg_read_dim(td_file, il_dimid)
892         ELSE
893            CALL logger_error( &
894            &  " READ DIM: no dimension "//TRIM(cd_name)//&
895            &  " in file "//TRIM(td_file%c_name))
896         ENDIF
897
898      ENDIF
899
900   END FUNCTION iom_rstdimg__read_dim_name
901   !-------------------------------------------------------------------
902   !> @brief This function read variable value in an opened
903   !> dimg file, given variable id.
904   !> @details
905   !> Optionaly, start indices and number of indices selected along each dimension
906   !> could be specify in a 4 dimension array (/'x','y','z','t'/)
907   !
908   !> @author J.Paul
909   !> @date November, 2013 - Initial Version
910   !
911   !> @param[in] td_file   file structure
912   !> @param[in] id_varid  variable id
913   !> @param[in] id_start  index in the variable from which the data values
914   !> will be read
915   !> @param[in] id_count  number of indices selected along each dimension
916   !> @return  variable structure
917   !-------------------------------------------------------------------
918   TYPE(TVAR) FUNCTION iom_rstdimg__read_var_id(td_file, id_varid,&
919   &                                            id_start, id_count)
920      IMPLICIT NONE
921      ! Argument     
922      TYPE(TFILE),               INTENT(IN) :: td_file
923      INTEGER(i4),               INTENT(IN) :: id_varid
924      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
925      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
926
927      ! local variable
928      INTEGER(i4), DIMENSION(1) :: il_varid
929      !----------------------------------------------------------------
930      ! check if file opened
931      IF( td_file%i_id == 0 )THEN
932
933         CALL logger_error( &
934         &  " READ VAR: no id associated to file "//TRIM(td_file%c_name))
935
936      ELSE
937
938         ! look for variable id
939         il_varid(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid))
940         IF( il_varid(1) /= 0 )THEN
941
942            iom_rstdimg__read_var_id=var_copy(td_file%t_var(il_varid(1)))
943
944            IF( iom_rstdimg__read_var_id%i_ndim /= 0 )THEN
945               !!! read variable value
946               CALL iom_rstdimg__read_var_value( td_file, &
947               &                                 iom_rstdimg__read_var_id, &
948               &                                 id_start, id_count)
949            ELSE
950               CALL logger_debug( " READ VAR: variable 0d "//&
951               &               TRIM(td_file%t_var(il_varid(1))%c_name)//&
952               &               " should be already read ")
953            ENDIF           
954
955         ELSE
956            CALL logger_error( &
957            &  " READ VAR: there is no variable with id "//&
958            &  TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name))
959         ENDIF
960
961      ENDIF
962   END FUNCTION iom_rstdimg__read_var_id
963   !-------------------------------------------------------------------
964   !> @brief This function read variable value in an opened
965   !> dimg file, given variable name or standard name.
966   !> @details
967   !> Optionaly, start indices and number of indices selected along each dimension
968   !> could be specify in a 4 dimension array (/'x','y','z','t'/)
969   !
970   !> look first for variable name. If it doesn't
971   !> exist in file, look for variable standard name.<br/>
972   !
973   !> @author J.Paul
974   !> @date November, 2013 - Initial Version
975   !
976   !> @param[in] td_file   file structure
977   !> @param[in] cd_name   variable name or standard name
978   !> @param[in] id_start  index in the variable from which the data values
979   !> will be read
980   !> @param[in] id_count  number of indices selected along each dimension
981   !> @return  variable structure
982   !-------------------------------------------------------------------
983   TYPE(TVAR) FUNCTION iom_rstdimg__read_var_name(td_file, cd_name,   &
984   &                                              id_start, id_count  )
985      IMPLICIT NONE
986      ! Argument
987      TYPE(TFILE),                     INTENT(IN) :: td_file
988      CHARACTER(LEN=*),                INTENT(IN) :: cd_name
989      INTEGER(i4),      DIMENSION(:),  INTENT(IN), OPTIONAL :: id_start
990      INTEGER(i4),      DIMENSION(:),  INTENT(IN), OPTIONAL :: id_count
991
992      ! local variable
993      INTEGER(i4)       :: il_varid
994      !----------------------------------------------------------------
995      ! check if file opened
996      IF( td_file%i_id == 0 )THEN
997
998         CALL logger_error( &
999         &  " READ VAR: no id associated to file "//TRIM(td_file%c_name))
1000
1001      ELSE
1002
1003         il_varid=var_get_index(td_file%t_var(:), cd_name)
1004         IF( il_varid /= 0 )THEN
1005
1006            iom_rstdimg__read_var_name=var_copy(td_file%t_var(il_varid))
1007
1008            IF( td_file%t_var(il_varid)%i_ndim /= 0 )THEN
1009               !!! read variable value
1010               CALL iom_rstdimg__read_var_value( td_file, &
1011               &                                 iom_rstdimg__read_var_name, &
1012               &                                 id_start, id_count)
1013            ELSE
1014               CALL logger_debug( " READ VAR: variable 0d "//&
1015               &               TRIM(td_file%t_var(il_varid)%c_name)//&
1016               &               " should have been already read ")
1017            ENDIF
1018
1019         ELSE
1020
1021            CALL logger_error( &
1022            &  " READ VAR NAME: there is no variable with "//&
1023            &  " name or standard name "//TRIM(cd_name)//&
1024            &  " in file "//TRIM(td_file%c_name) )
1025
1026         ENDIF
1027
1028      ENDIF
1029     
1030   END FUNCTION iom_rstdimg__read_var_name
1031   !-------------------------------------------------------------------
1032   !> @brief This subroutine read variable value in an opened dimg file, for
1033   !> variable 1,2,3d.
1034   !> @details
1035   !> Optionaly,start indices and number of indices selected along each dimension
1036   !> could be specify in a 4 dimension array (/'x','y','z','t'/)
1037   !>
1038   !> @author J.Paul
1039   !> @date November, 2013 - Initial Version
1040   !
1041   !> @param[in] td_file   file structure
1042   !> @param[inout] td_var variable structure
1043   !> @param[in] id_start  index in the variable from which the data values will be read
1044   !> @param[in] id_count  number of indices selected along each dimension
1045   !-------------------------------------------------------------------
1046   SUBROUTINE iom_rstdimg__read_var_value(td_file, td_var, &
1047   &                                      id_start, id_count )
1048      IMPLICIT NONE
1049      ! Argument     
1050      TYPE(TFILE),               INTENT(IN)    :: td_file
1051      TYPE(TVAR) ,               INTENT(INOUT) :: td_var
1052      INTEGER(i4), DIMENSION(:), INTENT(IN),  OPTIONAL :: id_start
1053      INTEGER(i4), DIMENSION(:), INTENT(IN),  OPTIONAL :: id_count
1054
1055      ! local variable
1056      INTEGER(i4)                                  :: il_status
1057      INTEGER(i4)                                  :: il_tmp1, il_tmp2
1058      INTEGER(i4), DIMENSION(ip_maxdim)            :: il_start
1059      INTEGER(i4), DIMENSION(ip_maxdim)            :: il_count
1060
1061      REAL(dp),    DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1062
1063      ! loop indices
1064      INTEGER(i4) :: ji
1065      !----------------------------------------------------------------
1066
1067      ! check id_count and id_start optionals parameters...
1068      IF( (       PRESENT(id_start)  .AND. (.NOT. PRESENT(id_count))) .OR. &
1069          ((.NOT. PRESENT(id_start)) .AND.        PRESENT(id_count) ) )THEN
1070         CALL logger_warn( &
1071         &  " READ VAR VALUE: id_start and id_count should be both specify")
1072      ENDIF
1073
1074      IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN
1075
1076         IF( SIZE(id_start(:)) /= ip_maxdim .OR. &
1077         &   SIZE(id_count(:)) /= ip_maxdim )THEN
1078            CALL logger_error("READ VAR: dimension of array start or count "//&
1079            &      " are invalid to read variable "//TRIM(td_var%c_name)//&
1080            &      " in file "//TRIM(td_file%c_name) )
1081         ENDIF
1082
1083         ! dimension order assume to be ('x','y','z','t')
1084         il_start(:)=id_start(:)
1085         il_count(:)=id_count(:)
1086
1087      ELSE
1088
1089         ! dimension order assume to be ('x','y','z','t')
1090         il_start(:)=(/1,1,1,1/)
1091         il_count(:)=td_var%t_dim(:)%i_len
1092
1093      ENDIF
1094
1095      ! check dimension
1096      IF( .NOT. ALL(il_start(:)>=(/1,1,1,1/)) )THEN
1097
1098         CALL logger_error( " READ VAR VALUE: "//&
1099         &               " start indices should be greater than or equal to 1")
1100
1101      ENDIF
1102
1103      IF(.NOT.ALL(il_start(:)+il_count(:)-1<=(/td_var%t_dim(1)%i_len,&
1104         &                                     td_var%t_dim(2)%i_len,&
1105         &                                     td_var%t_dim(3)%i_len,&
1106         &                                     td_var%t_dim(4)%i_len &
1107         &                                    /)) )THEN
1108
1109         CALL logger_error( " READ VAR VALUE: "//&
1110         &               "start + count exceed variable dimension" )
1111
1112         DO ji = 1, ip_maxdim
1113            il_tmp1=il_start(ji)+il_count(ji)-1
1114            il_tmp2=td_var%t_dim(ji)%i_len
1115            CALL logger_debug( &
1116            &  " READ VAR VALUE: start + count - 1 "//TRIM(fct_str(il_tmp1))//&
1117            &  " variable dimension"//TRIM(fct_str(il_tmp2)))
1118         ENDDO
1119
1120      ELSE
1121
1122         ! Allocate space to hold variable value
1123         ALLOCATE(dl_value( td_var%t_dim(1)%i_len, &
1124         &                  td_var%t_dim(2)%i_len, &
1125         &                  td_var%t_dim(3)%i_len, &
1126         &                  td_var%t_dim(4)%i_len),&
1127         &        stat=il_status)
1128         IF(il_status /= 0 )THEN
1129
1130           CALL logger_error( &
1131            &  " READ VAR VALUE: not enough space to put variable "//&
1132            &  TRIM(td_var%c_name)//&
1133            &  " in temporary array")
1134
1135         ENDIF
1136
1137         ! read values
1138         CALL logger_trace( &
1139         &  " READ VAR VALUE: get variable "//TRIM(td_var%c_name)//&
1140         &  " in file "//TRIM(td_file%c_name))     
1141
1142         IF( ALL(td_var%t_dim(1:3)%l_use) )THEN
1143            ! 3D variable (X,Y,Z)
1144            DO ji=1,td_var%t_dim(3)%i_len
1145               READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec +ji-1) &
1146               &  dl_value(:,:,ji,:)
1147               CALL fct_err(il_status)
1148               IF( il_status /= 0 )THEN
1149                  CALL logger_error("READ VAR VALUE: reading 3D variable "//&
1150                  &              TRIM(td_var%c_name))
1151               ENDIF
1152            ENDDO
1153         ELSEIF( ALL(td_var%t_dim(1:2)%l_use) )THEN
1154            ! 2D variable (X,Y)
1155            READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec ) &
1156            &  dl_value(:,:,:,:)
1157            CALL fct_err(il_status)
1158            IF( il_status /= 0 )THEN
1159               CALL logger_error("READ VAR VALUE: reading 2D variable "//&
1160                  &            TRIM(td_var%c_name))
1161            ENDIF
1162         ELSEIF( td_var%t_dim(3)%l_use )THEN
1163            ! 1D variable (Z)
1164            READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec ) &
1165            &  dl_value(:,:,:,:)
1166            CALL fct_err(il_status)
1167            IF( il_status /= 0 )THEN
1168               CALL logger_error("READ VAR VALUE: reading 1D variable "//&
1169                  &            TRIM(td_var%c_name))
1170            ENDIF
1171         ENDIF
1172 
1173         ! Allocate space to hold variable value in structure
1174         IF( ASSOCIATED(td_var%d_value) )THEN
1175            DEALLOCATE(td_var%d_value)   
1176         ENDIF
1177
1178         ALLOCATE(td_var%d_value( il_count(1), &
1179         &                        il_count(2), &
1180         &                        il_count(3), &
1181         &                        il_count(4)),&
1182         &        stat=il_status)
1183         IF(il_status /= 0 )THEN
1184
1185           CALL logger_error( &
1186            &  " READ VAR VALUE: not enough space to put variable "//&
1187            &  TRIM(td_var%c_name)//&
1188            &  " in variable structure")
1189
1190         ENDIF
1191         ! FillValue by default
1192         td_var%d_value(:,:,:,:)=td_var%d_fill
1193
1194         ! new dimension length
1195         td_var%t_dim(:)%i_len=il_count(:)
1196
1197         ! extract value
1198         td_var%d_value(:,:,:,:) = dl_value(il_start(1):il_start(1)+il_count(1)-1,&
1199         &                                  il_start(2):il_start(2)+il_count(2)-1,&
1200         &                                  il_start(3):il_start(3)+il_count(3)-1,&
1201         &                                  il_start(4):il_start(4)+il_count(4)-1)
1202
1203         DEALLOCATE(dl_value)
1204
1205      ENDIF
1206
1207      ! force to change _FillValue to avoid mistake
1208      ! with dummy zero _FillValue
1209      IF( td_var%d_fill == 0._dp )THEN
1210         CALL var_chg_FillValue(td_var)
1211      ENDIF
1212
1213      ! use scale factor and offset
1214      WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill )
1215         td_var%d_value(:,:,:,:) = &
1216         &  td_var%d_value(:,:,:,:)*td_var%d_scf + td_var%d_ofs
1217      END WHERE
1218
1219   END SUBROUTINE iom_rstdimg__read_var_value
1220   !-------------------------------------------------------------------
1221   !> @brief This subroutine write dimg file from file structure.
1222   !
1223   !> @details
1224   !> dimg file have to be already opened in write mode.
1225   !>
1226   !> @author J.Paul
1227   !> @date November, 2013 - Initial Version
1228   !> @date September, 2014
1229   !> - use iom_rstdimg__get_rec
1230   !
1231   !> @param[inout] td_file   file structure
1232   !-------------------------------------------------------------------
1233   SUBROUTINE iom_rstdimg_write_file(td_file)
1234      IMPLICIT NONE
1235      ! Argument     
1236      TYPE(TFILE), INTENT(INOUT) :: td_file
1237
1238      ! local variable
1239      INTEGER(i4)           :: il_status
1240      INTEGER(i4)           :: il_ind
1241      !----------------------------------------------------------------
1242      ! check if file opened
1243      IF( td_file%i_id == 0 )THEN
1244
1245         CALL logger_error( &
1246         &  " WRITE FILE: no id associated to file "//TRIM(td_file%c_name))
1247
1248      ELSE
1249         IF( td_file%l_wrt )THEN
1250
1251            ! check dimension
1252            IF( td_file%t_dim(jp_L)%l_use .AND. &
1253            &   td_file%t_dim(jp_L)%i_len /= 1 )THEN
1254               CALL logger_fatal("WRITE FILE: can not write dimg file with "//&
1255               &  " several time step.")
1256            ENDIF
1257
1258            ! close and open file with right record length
1259            CALL iom_rstdimg_close(td_file)
1260
1261            ! compute record number to be used
1262            ! and add variable no0d, no1d,.. if need be
1263            CALL iom_rstdimg__get_rec(td_file)
1264
1265            ! compute record length
1266            il_ind=att_get_index(td_file%t_att(:),"DOMAIN_number_total")
1267            IF( il_ind /= 0 )THEN
1268               td_file%i_recl = MAX( &
1269               &     td_file%t_dim(1)%i_len * td_file%t_dim(2)%i_len * 8, &
1270               &     ( 8 * INT(td_file%t_att(il_ind)%d_value(1)) + 15 ) * 4 )
1271            ELSE
1272               td_file%i_recl = td_file%t_dim(1)%i_len * &
1273               &                td_file%t_dim(2)%i_len * 8
1274            ENDIF
1275            ! check record length
1276            IF( td_file%i_nvar*(im_vnl+dp) > td_file%i_recl )THEN
1277               CALL logger_fatal("WRITE FILE: record length is too small. "//&
1278               &  " Try to reduce the output number of processor.")
1279            ENDIF
1280
1281            ! get free unit
1282            td_file%i_id=fct_getunit()
1283
1284            OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
1285            &                         FORM='UNFORMATTED',              &
1286            &                         ACCESS='DIRECT',                 &
1287            &                         STATUS='REPLACE',                &
1288            &                         ACTION='WRITE',                  &
1289            &                         RECL=td_file%i_recl,             &
1290            &                         IOSTAT=il_status)
1291            CALL fct_err(il_status)
1292            IF( il_status /= 0 )THEN
1293               CALL logger_error("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//&
1294               &  " with record length "//TRIM(fct_str(td_file%i_recl)))
1295            ELSE
1296               CALL logger_debug("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//&
1297               &  " with record length "//TRIM(fct_str(td_file%i_recl)))
1298            ENDIF
1299
1300            ! write header
1301            CALL iom_rstdimg__write_header(td_file)
1302
1303            ! write variable in file
1304            CALL iom_rstdimg__write_var(td_file) 
1305
1306         ELSE
1307
1308            CALL logger_error( &
1309            &  " WRITE FILE: try to write in file "//TRIM(td_file%c_name)//&
1310            &  ", not opened in write mode")
1311
1312         ENDIF
1313      ENDIF
1314
1315   END SUBROUTINE iom_rstdimg_write_file
1316   !-------------------------------------------------------------------
1317   !> @brief This subroutine compute record number to be used.
1318   !>
1319   !> @details
1320   !> Moreover it adds variable no0d, no1d, no2d and no3d if need be.
1321   !>
1322   !> @author J.Paul
1323   !> @date September, 2014 - Initial Version
1324   !
1325   !> @param[inout] td_file   file structure
1326   !-------------------------------------------------------------------
1327   SUBROUTINE iom_rstdimg__get_rec(td_file)
1328      IMPLICIT NONE
1329      ! Argument     
1330      TYPE(TFILE), INTENT(INOUT) :: td_file
1331
1332      ! local variable
1333      INTEGER(i4) :: il_rec
1334      TYPE(TVAR)  :: tl_var
1335
1336      INTEGER(i4), DIMENSION(:)    , ALLOCATABLE :: il_tmp1d
1337      INTEGER(i4), DIMENSION(:,:)  , ALLOCATABLE :: il_tmp2d
1338      INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_tmp3d
1339
1340      ! loop indices
1341      INTEGER(i4) :: ji
1342      !----------------------------------------------------------------
1343
1344      ! add dummy variable if necessary
1345      IF( td_file%i_n0d == 0 )THEN
1346         ! create var
1347         tl_var=var_init('no0d')
1348
1349         CALL file_add_var( td_file, tl_var )
1350      ENDIF
1351
1352      IF( td_file%i_n1d == 0 )THEN
1353         ! create var
1354         ALLOCATE( il_tmp1d( td_file%t_dim(3)%i_len ) )
1355         il_tmp1d(:)=-1
1356
1357         tl_var=var_init( 'no1d', il_tmp1d(:)) 
1358
1359         DEALLOCATE( il_tmp1d )
1360
1361         CALL file_add_var( td_file, tl_var ) 
1362      ENDIF
1363 
1364      IF( td_file%i_n2d == 0 )THEN
1365         ! create var
1366         ALLOCATE( il_tmp2d( td_file%t_dim(1)%i_len, &
1367         &                   td_file%t_dim(2)%i_len ) )
1368         il_tmp2d(:,:)=-1
1369
1370         tl_var=var_init('no2d', il_tmp2d(:,:) )
1371
1372         DEALLOCATE( il_tmp2d )
1373
1374         CALL file_add_var( td_file, tl_var ) 
1375
1376      ENDIF
1377 
1378      IF( td_file%i_n3d == 0 )THEN
1379         ! create var
1380         ALLOCATE( il_tmp3d( td_file%t_dim(1)%i_len, &
1381         &                   td_file%t_dim(2)%i_len, &
1382         &                   td_file%t_dim(3)%i_len ) )
1383         il_tmp3d(:,:,:)=-1
1384
1385         tl_var=var_init('no3d', il_tmp3d(:,:,:) )
1386
1387         DEALLOCATE( il_tmp3d )
1388
1389         CALL file_add_var( td_file, tl_var ) 
1390      ENDIF
1391
1392      ! clean
1393      CALL var_clean(tl_var)
1394
1395      il_rec=2
1396      DO ji=1,td_file%i_nvar
1397         SELECT CASE(td_file%t_var(ji)%i_ndim)
1398            CASE(0)
1399               IF( INDEX(td_file%t_var(ji)%c_name, 'no0d' ) == 0 )THEN
1400                  td_file%t_var(ji)%i_rec=il_rec
1401                  il_rec = il_rec  + 0
1402               ENDIF
1403            CASE(1)
1404               IF( INDEX(td_file%t_var(ji)%c_name, 'no1d' ) == 0 )THEN
1405                  td_file%t_var(ji)%i_rec=il_rec
1406                  il_rec = il_rec  + 1
1407               ENDIF
1408            CASE(2)
1409               IF( INDEX(td_file%t_var(ji)%c_name, 'no2d' ) == 0 )THEN
1410                  td_file%t_var(ji)%i_rec=il_rec
1411                  il_rec = il_rec  + 1
1412               ENDIF
1413            CASE(3)
1414               IF( INDEX(td_file%t_var(ji)%c_name, 'no3d' ) == 0 )THEN
1415                  td_file%t_var(ji)%i_rec=il_rec
1416                  il_rec = il_rec  + td_file%t_dim(3)%i_len
1417               ENDIF
1418         END SELECT
1419      ENDDO
1420      td_file%i_rhd  = il_rec
1421
1422      END SUBROUTINE iom_rstdimg__get_rec
1423   !-------------------------------------------------------------------
1424   !> @brief This subroutine write header in an opened dimg
1425   !> file in write mode.
1426   !
1427   !> @author J.Paul
1428   !> @date November, 2013 - Initial Version
1429   !
1430   !> @param[inout] td_file   file structure
1431   !-------------------------------------------------------------------
1432   SUBROUTINE iom_rstdimg__write_header(td_file)
1433      IMPLICIT NONE
1434      ! Argument     
1435      TYPE(TFILE), INTENT(INOUT) :: td_file
1436
1437      ! local variable
1438      INTEGER(i4) :: il_status
1439      INTEGER(i4) :: il_ind
1440      INTEGER(i4) :: il_nproc
1441      INTEGER(i4) :: il_niproc
1442      INTEGER(i4) :: il_njproc
1443      INTEGER(i4) :: il_area
1444      INTEGER(i4) :: il_iglo
1445      INTEGER(i4) :: il_jglo
1446
1447      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp
1448      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp
1449      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci
1450      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj
1451      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi
1452      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj
1453      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei
1454      INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej
1455     
1456      ! loop indices
1457      INTEGER(i4) :: ji
1458      !----------------------------------------------------------------
1459      ! check record length
1460      IF( td_file%i_recl <= 8 )THEN
1461         CALL logger_warn(" WRITE FILE: record length seems to be tiny!! &
1462         & ("//TRIM(fct_str(td_file%i_recl))//")")
1463      ENDIF
1464
1465      ! check dimension
1466      IF( ANY(td_file%t_dim(1:3)%i_len <= 0 ) )THEN
1467         CALL logger_error(" WRITE FILE: at least one dimension size is less &
1468         &                than or equal to zero !! ")
1469         DO ji=1,3
1470            CALL logger_debug(" WRITE FILE: dimension "//&
1471            &               TRIM(td_file%t_dim(ji)%c_name)//" : "//&
1472            &               TRIM(fct_str(td_file%t_dim(ji)%i_len)) )
1473         ENDDO
1474      ENDIF
1475
1476      ! get domain decomposition
1477      il_ind=att_get_index( td_file%t_att, "DOMAIN_number_total" )
1478      il_nproc = 1
1479      IF( il_ind /= 0 )THEN
1480         il_nproc = INT(td_file%t_att(il_ind)%d_value(1))
1481      ENDIF
1482
1483      il_ind=att_get_index( td_file%t_att, "DOMAIN_I_number_total" )
1484      il_niproc = 0
1485      IF( il_ind /= 0 )THEN
1486         il_niproc = INT(td_file%t_att(il_ind)%d_value(1))
1487      ENDIF
1488
1489      il_ind=att_get_index( td_file%t_att, "DOMAIN_J_number_total" )
1490      il_njproc = 0
1491      IF( il_ind /= 0 )THEN
1492         il_njproc = INT(td_file%t_att(il_ind)%d_value(1))
1493      ENDIF
1494
1495      ! check domain decomposition
1496      IF( il_niproc  <= 0 .OR. &
1497      &   il_njproc  <= 0 .OR. &
1498      &   il_nproc <= 0 .OR. &
1499      &   il_nproc > il_niproc * il_njproc )THEN
1500     
1501         CALL logger_error(" WRITE FILE: invalid domain splitting ")
1502
1503         CALL logger_debug(" WRITE FILE: niproc "//TRIM(fct_str(il_niproc)) )
1504         CALL logger_debug(" WRITE FILE: njproc "//TRIM(fct_str(il_njproc)) )
1505         CALL logger_debug(" WRITE FILE: nproc "//TRIM(fct_str(il_nproc)) )
1506
1507      ENDIF
1508     
1509      ! get domain number
1510      il_ind=att_get_index( td_file%t_att, "DOMAIN_number" )
1511      il_area = 0
1512      IF( il_ind /= 0 )THEN
1513         il_area = INT(td_file%t_att(il_ind)%d_value(1))
1514      ENDIF
1515
1516      ! get domain global size
1517      il_ind=att_get_index( td_file%t_att, "DOMAIN_size_global" )
1518      il_iglo = 0
1519      il_jglo = 0
1520      IF( il_ind /= 0 )THEN
1521         il_iglo = INT(td_file%t_att(il_ind)%d_value(1))
1522         il_jglo = INT(td_file%t_att(il_ind)%d_value(2))
1523      ENDIF
1524
1525      ! check domain global size
1526      IF( il_iglo < td_file%t_dim(1)%i_len .OR. &
1527      &   il_jglo < td_file%t_dim(2)%i_len )THEN
1528         CALL logger_error(" WRITE FILE: invalid global domain ")
1529
1530         CALL logger_debug(" WRITE FILE: global domain : "//&
1531         &              TRIM(fct_str(il_iglo))//" x "//&
1532         &              TRIM(fct_str(il_jglo)) )
1533         CALL logger_debug(" WRITE FILE: local domain : "//&
1534         &              TRIM(fct_str(td_file%t_dim(1)%i_len))//" x "//&
1535         &              TRIM(fct_str(td_file%t_dim(2)%i_len)) )
1536      ENDIF
1537
1538      ! allocate local variable
1539      ALLOCATE( il_impp(il_nproc), il_jmpp(il_nproc),&
1540      &         il_lci(il_nproc),  il_lcj(il_nproc), &
1541      &         il_ldi(il_nproc),  il_ldj(il_nproc), &
1542      &         il_lei(il_nproc),  il_lej(il_nproc) )
1543
1544      ! get domain first poistion
1545      il_ind=att_get_index( td_file%t_att, "DOMAIN_I_position_first" )
1546      il_impp(:) = 0
1547      IF( il_ind /= 0 )THEN
1548         il_impp(:) = INT(td_file%t_att(il_ind)%d_value(:))
1549      ENDIF
1550
1551      il_ind=att_get_index( td_file%t_att, "DOMAIN_J_position_first" )
1552      il_jmpp(:) = 0
1553      IF( il_ind /= 0 )THEN
1554         il_jmpp(:) = INT(td_file%t_att(il_ind)%d_value(:))
1555      ENDIF
1556     
1557      ! check domain first poistion
1558      IF( ANY(il_impp(:)==0) .OR. ANY(il_jmpp(:)==0) )THEN
1559         CALL logger_warn("WRITE FILE: no data for domain first position")
1560      ENDIF
1561
1562      ! get domain last poistion
1563      il_ind=att_get_index( td_file%t_att, "DOMAIN_I_position_last" )
1564      il_lci(:) = 0
1565      IF( il_ind /= 0 )THEN
1566         il_lci(:) = INT(td_file%t_att(il_ind)%d_value(:))
1567      ENDIF
1568
1569      il_ind=att_get_index( td_file%t_att, "DOMAIN_J_position_last" )
1570      il_lcj(:) = 0
1571      IF( il_ind /= 0 )THEN
1572         il_lcj(:) = INT(td_file%t_att(il_ind)%d_value(:))
1573      ENDIF
1574
1575      ! check domain last poistion
1576      IF( ANY(il_lci(:)==0) .OR. ANY(il_lcj(:)==0) )THEN
1577         CALL logger_warn("WRITE FILE: no data for domain last position")
1578      ENDIF
1579
1580      ! get halo size start
1581      il_ind=att_get_index( td_file%t_att, "DOMAIN_I_halo_size_start" )
1582      il_ldi(:) = 0
1583      IF( il_ind /= 0 )THEN
1584         il_ldi(:) = INT(td_file%t_att(il_ind)%d_value(:))
1585      ENDIF
1586
1587      il_ind=att_get_index( td_file%t_att, "DOMAIN_J_halo_size_start" )
1588      il_ldj(:) = 0
1589      IF( il_ind /= 0 )THEN
1590         il_ldj(:) = INT(td_file%t_att(il_ind)%d_value(:))
1591      ENDIF
1592     
1593      ! check halo size start
1594      IF( ANY(il_ldi(:)==0) .OR. ANY(il_ldj(:)==0) )THEN
1595         CALL logger_warn("WRITE FILE: no data for halo size start")
1596      ENDIF
1597
1598      ! get halo size end
1599      il_ind=att_get_index( td_file%t_att, "DOMAIN_I_halo_size_end" )
1600      il_lei(:) = 0
1601      IF( il_ind /= 0 )THEN
1602         il_lei(:) = INT(td_file%t_att(il_ind)%d_value(:))
1603      ENDIF
1604
1605      il_ind=att_get_index( td_file%t_att, "DOMAIN_J_halo_size_end" )
1606      il_lej(:) = 0
1607      IF( il_ind /= 0 )THEN
1608         il_lej(:) = INT(td_file%t_att(il_ind)%d_value(:))
1609      ENDIF
1610
1611      ! check halo size end
1612      IF( ANY(il_lei(:)==0) .OR. ANY(il_lej(:)==0) )THEN
1613         CALL logger_warn("WRITE FILE: no data for halo size end")
1614      ENDIF     
1615
1616      ! write file header
1617      WRITE(td_file%i_id, IOSTAT=il_status, REC=1 )&
1618      &  td_file%i_recl, &
1619      &  td_file%t_dim(1)%i_len, &
1620      &  td_file%t_dim(2)%i_len, &
1621      &  td_file%t_dim(3)%i_len, &
1622      &  td_file%i_n0d, &
1623      &  td_file%i_n1d, &
1624      &  td_file%i_n2d, &
1625      &  td_file%i_n3d, &
1626      &  td_file%i_rhd, &
1627      &  il_niproc, il_njproc, il_nproc, &
1628      &  il_area,                &
1629      &  il_iglo, il_jglo,       &
1630      &  il_lci(:), il_lcj(:),   &
1631      &  il_ldi(:), il_ldj(:),   &
1632      &  il_lei(:), il_lej(:),   &
1633      &  il_impp(:), il_jmpp(:)
1634
1635      DEALLOCATE( il_impp, il_jmpp,&
1636      &           il_lci,  il_lcj, &
1637      &           il_ldi,  il_ldj, &
1638      &           il_lei,  il_lej  )
1639
1640      END SUBROUTINE iom_rstdimg__write_header
1641   !-------------------------------------------------------------------
1642   !> @brief This subroutine write variables in an opened dimg file.
1643   !>
1644   !> @author J.Paul
1645   !> @date November, 2013 - Initial Version
1646   !> @date July, 2015
1647   !> - bug fix: do not use scale factor an offset for case no0d, no1d...
1648   !>
1649   !> @param[in] td_file file structure
1650   !-------------------------------------------------------------------
1651   SUBROUTINE iom_rstdimg__write_var(td_file)
1652      IMPLICIT NONE
1653      ! Argument     
1654      TYPE(TFILE), INTENT(INOUT) :: td_file
1655
1656      ! local variable
1657      INTEGER(i4) :: il_status
1658      INTEGER(i4) :: il_rec
1659
1660      INTEGER(i4),            DIMENSION(:), ALLOCATABLE :: il_start
1661      INTEGER(i4),            DIMENSION(:), ALLOCATABLE :: il_count
1662      CHARACTER(LEN=im_vnl),  DIMENSION(:), ALLOCATABLE :: cl_name
1663      REAL(dp),               DIMENSION(:), ALLOCATABLE :: dl_value
1664
1665      ! loop indices
1666      INTEGER(i4) :: ji
1667      INTEGER(i4) :: jk
1668      !----------------------------------------------------------------
1669
1670      ! reform name and record
1671      ALLOCATE( cl_name(td_file%i_nvar), dl_value(td_file%i_nvar) )
1672
1673      DO ji=1,td_file%i_nvar
1674
1675         ! change FillValue to 0.
1676         CALL var_chg_FillValue(td_file%t_var(ji),0._dp)
1677
1678         cl_name(ji)  = TRIM(td_file%t_var(ji)%c_name)
1679         dl_value(ji) = REAL(td_file%t_var(ji)%i_rec,dp)
1680         
1681         SELECT CASE (TRIM(td_file%t_var(ji)%c_name))
1682            CASE('no0d','no1d','no2d','no3d')
1683            CASE DEFAULT
1684               
1685               ! use scale factor and offset
1686               WHERE( td_file%t_var(ji)%d_value(:,:,:,:) /= &
1687               &      td_file%t_var(ji)%d_fill )
1688                  td_file%t_var(ji)%d_value(:,:,:,:) = &
1689                  &   ( td_file%t_var(ji)%d_value(:,:,:,:) - &
1690                  &     td_file%t_var(ji)%d_ofs ) / &
1691                  &   td_file%t_var(ji)%d_scf
1692               END WHERE
1693
1694               DO jk=1,td_file%t_var(ji)%t_dim(3)%i_len
1695                  SELECT CASE (td_file%t_var(ji)%i_ndim)
1696                     CASE(0)
1697                        ! special case for 0d, value save in rec
1698                        dl_value(ji)=td_file%t_var(ji)%d_value(1,1,1,1)
1699                        il_rec = td_file%t_var(ji)%i_rec
1700                     CASE(1,2)
1701                        il_rec = td_file%t_var(ji)%i_rec
1702                     CASE(3)
1703                        il_rec = td_file%t_var(ji)%i_rec + jk -1
1704                  END SELECT
1705                  WRITE( td_file%i_id, IOSTAT=il_status, REC=il_rec ) &
1706                  &  td_file%t_var(ji)%d_value(:,:,jk,1)
1707                  CALL fct_err(il_status)
1708                  IF( il_status /= 0 )THEN
1709                     CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//&
1710                     &  "write variable "//TRIM(td_file%t_var(ji)%c_name)//&
1711                     &  " in record "//TRIM(fct_str(il_rec)))
1712                  ENDIF
1713               ENDDO
1714            END SELECT
1715
1716      ENDDO
1717
1718      ALLOCATE( il_start(4), il_count(4) )
1719
1720      il_start(1) = 1
1721      il_count(1) = td_file%i_n0d
1722     
1723      il_start(2) = 1 + il_count(1)
1724      il_count(2) = il_start(2) - 1 + td_file%i_n1d
1725     
1726      il_start(3) = 1 + il_count(2)
1727      il_count(3) = il_start(3) - 1 + td_file%i_n2d
1728     
1729      il_start(4) = 1 + il_count(3)
1730      il_count(4) = il_start(4) - 1 + td_file%i_n3d
1731
1732      WRITE(td_file%i_id, IOSTAT=il_status, REC=td_file%i_rhd )&
1733      &  cl_name(il_start(1):il_count(1)), dl_value(il_start(1):il_count(1)),&
1734      &  cl_name(il_start(2):il_count(2)), dl_value(il_start(2):il_count(2)),&
1735      &  cl_name(il_start(3):il_count(3)), dl_value(il_start(3):il_count(3)),&
1736      &  cl_name(il_start(4):il_count(4)), dl_value(il_start(4):il_count(4))
1737      CALL fct_err(il_status)
1738      IF( il_status /= 0 )THEN
1739         CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//&
1740         &  "write restart header in record "//TRIM(fct_str(td_file%i_rhd)))
1741      ENDIF
1742
1743      ! clean
1744      DEALLOCATE( cl_name, dl_value )
1745      DEALLOCATE( il_start, il_count )
1746
1747   END SUBROUTINE iom_rstdimg__write_var
1748END MODULE iom_rstdimg
Note: See TracBrowser for help on using the repository browser.