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 utils/tools/SIREN/src – NEMO

source: utils/tools/SIREN/src/iom_rstdimg.f90 @ 13369

Last change on this file since 13369 was 13369, checked in by jpaul, 4 years ago

update: cf changelog inside documentation

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