source: trunk/NEMO/OPA_SRC/iom.F90 @ 485

Last change on this file since 485 was 485, checked in by opalod, 15 years ago

nemo_v1_bugfix_051 : SM + CT : remove bad syntax "::" when using keyword PUBLIC to allow subroutines availables out of one module

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.3 KB
Line 
1MODULE iom
2   !!=====================================================================
3   !!                    ***  MODULE  iom ***
4   !!
5   !! Input/Output manager :  Library to read input files
6   !!
7   !! Ongoing work : This code is here to help discussions about I/O
8   !!                library in the NEMO system
9   !!====================================================================
10   !!--------------------------------------------------------------------
11   !!   iom_open       : open a file read only
12   !!   iom_close      : close a file or all files opened by iom
13   !!   iom_get        : read a field : interface to several routines
14   !!   iom_varid      : get the id of a variable in a file
15   !!   iom_get_gblatt : ???
16   !!--------------------------------------------------------------------
17   !! History :  9.0  ! 05 12  (J. Belier) Original code
18   !!            9.0  ! 06 02  (S. Masson) Adaptation to NEMO
19   !!--------------------------------------------------------------------
20   !! * Modules used
21   USE in_out_manager  ! I/O manager
22   USE dom_oce         ! ocean space and time domain
23   USE lbclnk          ! ???
24   USE ioipsl          ! ???
25
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC iom_open, iom_close, iom_get, iom_varid, iom_get_gblatt
30
31   !! * Interfaces
32   INTERFACE iom_get
33      MODULE PROCEDURE iom_get_r_1d, iom_get_r_2d, iom_get_r_3d
34   END INTERFACE
35
36   !! * Share module variables
37   INTEGER, PARAMETER, PUBLIC ::        &  !:
38      jpdom_data                  = 1,  &  !: ( 1  :jpidta, 1  :jpjdta)
39      jpdom_global                = 2,  &  !: ( 1  :jpiglo, 1  :jpjglo)
40      jpdom_local                 = 3,  &  !: One of the 3 following cases
41      jpdom_local_full            = 4,  &  !: ( 1  :jpi   , 1  :jpi   )
42      jpdom_local_noextra         = 5,  &  !: ( 1  :nlci  , 1  :nlcj  )
43      jpdom_local_noovlap         = 6,  &  !: (nldi:nlei  ,nldj:nlej  )
44      jpdom_unknown               = 7      !: No dimension checking
45
46   !! * Module variables
47   INTEGER, PARAMETER ::    &
48      jpmax_vars    = 50,   &  ! maximum number of variables in one file
49      jpmax_dims    =  5,   &  ! maximum number of dimensions for one variable
50      jpmax_digits  =  5       ! maximum number of digits in the file name to reference the cpu number
51 
52!$AGRIF_DO_NOT_TREAT
53   INTEGER :: iom_init = 0
54
55   TYPE :: flio_file
56      CHARACTER(LEN=240)                        ::   name     ! name of the file
57      INTEGER                                   ::   iopen    ! 1/0 is the file is open/not open
58      INTEGER                                   ::   nvars    ! number of identified varibles in the file
59      INTEGER                                   ::   iduld    ! id of the unlimited dimension
60      CHARACTER(LEN=16), DIMENSION(jpmax_vars)  ::   cn_var   ! names of the variables
61      INTEGER, DIMENSION(jpmax_vars)            ::   ndims    ! number of dimensions of the variables
62      LOGICAL, DIMENSION(jpmax_vars)            ::   luld     ! variable including unlimited dimension
63      INTEGER, DIMENSION(jpmax_dims,jpmax_vars) ::   dimsz    ! size of the dimensions of the variables
64      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   scf      ! scale_factor of the variables
65      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   ofs      ! add_offset of the variables
66   END TYPE flio_file
67   TYPE(flio_file), DIMENSION(flio_max_files)   :: iom_file ! array containing the info for all opened files
68!$AGRIF_END_DO_NOT_TREAT
69
70   !!----------------------------------------------------------------------
71   !!  OPA 9.0 , LOCEAN-IPSL (2006)
72   !! $Header$
73   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
74   !!----------------------------------------------------------------------
75
76CONTAINS
77
78   SUBROUTINE iom_open( cdname, knumfl, ldimg )
79      !!---------------------------------------------------------------------
80      !!                   ***  SUBROUTINE  iom_open  ***
81      !!
82      !! ** Purpose :  open an input file read only (return 0 if not found)
83      !!
84      !! ** Method :
85      !!
86      !!---------------------------------------------------------------------
87      CHARACTER(len=*), INTENT(in )  ::   cdname   ! File name
88      INTEGER, INTENT(out)           ::   knumfl   ! Identifier of the opened file
89      LOGICAL, INTENT(in ), OPTIONAL ::   ldimg    ! flg to specify that we use dimg format
90
91      CHARACTER(LEN=100) :: clname   ! the name of the file based on cdname [[+clcpu]+clcpu]
92      CHARACTER(LEN=10) :: clsuffix  ! ".nc" or ".dimg"
93      CHARACTER(LEN=10) :: clcpu     ! the cpu number (max jpmax_digits digits)
94      LOGICAL :: llok                ! check the existence
95      INTEGER :: icnt                ! counter for digits in clcpu (max = jpmax_digits)
96      !---------------------------------------------------------------------
97
98      ! find the file
99      ! =============
100      clname   = trim(cdname)
101#if defined key_agrif
102      if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
103#endif               
104      clsuffix = ".nc"
105      IF( PRESENT(ldimg) ) THEN
106         IF ( ldimg ) clsuffix = ".dimg"
107      ENDIF
108      !
109      INQUIRE( FILE = clname, EXIST = llok )
110      IF( .NOT.llok ) THEN                         ! try to complete the name with the suffix only
111         clname = TRIM(cdname)//TRIM(clsuffix)
112#if defined key_agrif
113         if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
114#endif               
115         INQUIRE( FILE = clname, EXIST = llok )
116         IF( .NOT.llok ) THEN                      ! try to complete the name with both cpu number and suffix
117            WRITE(clcpu,*) narea-1
118            clcpu  = trim(adjustl(clcpu))
119            clname = trim(cdname)//"_"
120#if defined key_agrif
121            if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
122#endif               
123            icnt = 0
124            INQUIRE( FILE = trim(clname)//trim(clcpu)//trim(clsuffix), EXIST = llok ) 
125            DO WHILE( .NOT.llok .AND. icnt < jpmax_digits )   ! we try fifferent formats for the cpu number by adding 0
126               clname = trim(clname)//"0"
127               INQUIRE( FILE = trim(clname)//trim(clcpu)//trim(clsuffix), EXIST = llok )
128               icnt = icnt + 1
129            END DO
130            IF( .NOT.llok ) THEN                   ! no way to find the files...
131               CALL ctl_stop( 'iom_open: file '//trim(clname)//'... not found' )
132            ENDIF
133            clname = trim(clname)//trim(clcpu)//trim(clsuffix)
134         ENDIF
135      ENDIF
136
137      ! Open the file
138      ! =============
139      IF( llok ) THEN                         
140         IF (lwp) WRITE(numout,*) 'iom_open ~~~  open file: '//trim(clname)
141         CALL flioopfd( trim(clname), knumfl )
142         IF( iom_init == 0 ) THEN
143            iom_file(:)%iopen = 0
144            iom_init = 1
145         ENDIF
146         iom_file(knumfl)%iopen      = 1
147         iom_file(knumfl)%name       = TRIM(clname)
148         iom_file(knumfl)%nvars      = 0
149         iom_file(knumfl)%ndims(:)   = 0
150         iom_file(knumfl)%luld(:)    = .FALSE.
151         iom_file(knumfl)%dimsz(:,:) = 0
152         ! does the file contain time axis (that must be unlimitted) ?
153         CALL flioinqf( knumfl, id_uld = iom_file(knumfl)%iduld )
154      ELSE
155         knumfl = 0
156      ENDIF
157 
158   END SUBROUTINE iom_open
159
160
161   SUBROUTINE iom_close( knumfl )
162      !!--------------------------------------------------------------------
163      !!                   ***  SUBROUTINE  iom_close  ***
164      !!
165      !! ** Purpose : close an input file, or all files opened by iom
166      !!
167      !! ** Method :
168      !!
169      !!--------------------------------------------------------------------
170      INTEGER,INTENT(in), OPTIONAL ::   knumfl   ! Identifier of the file to be closed
171      !                                          ! If this argument is not present,
172      !                                          ! all the files opened by iom are closed.
173
174      INTEGER           ::   jf            ! dummy loop indices
175      INTEGER           ::   i_s, i_e      ! temporary integer
176      !---------------------------------------------------------------------
177
178      IF( PRESENT(knumfl) ) THEN
179         i_s = knumfl
180         i_e = knumfl
181      ELSE
182         i_s = 1
183         i_e = flio_max_files
184      ENDIF
185      IF ( i_s > 0 ) THEN
186         DO jf = i_s, i_e
187            IF( iom_file(jf)%iopen > 0 ) THEN
188               CALL flioclo( jf )
189               iom_file(jf)%iopen      = 0
190               iom_file(jf)%name       = 'NONE'
191               iom_file(jf)%nvars      = 0
192               iom_file(jf)%iduld      = 0
193               iom_file(jf)%ndims(:)   = 0
194               iom_file(jf)%luld(:)    = .FALSE.
195               iom_file(jf)%dimsz(:,:) = 0
196            ELSEIF( PRESENT(knumfl) ) THEN
197               WRITE(ctmp1,*) '--->',  knumfl
198               CALL ctl_stop( 'iom_close: Invalid file identifier', ctmp1 )
199            ENDIF
200         END DO
201      ENDIF
202         
203   END SUBROUTINE iom_close
204 
205
206   !!----------------------------------------------------------------------
207   !!                   INTERFACE iom_u_getv
208   !!----------------------------------------------------------------------
209   SUBROUTINE iom_get_r_1d( knumfl, kdom , cdvar , pvar  ,   &
210      &                             ktime, kstart, kcount )
211      INTEGER               , INTENT(in )           ::   knumfl    ! Identifier of the file
212      INTEGER               , INTENT(in )           ::   kdom      ! Type of domain to be read
213      CHARACTER(len=*)      , INTENT(in )           ::   cdvar     ! Name of the variable
214      REAL(wp), DIMENSION(:), INTENT(out)           ::   pvar      ! read field
215      INTEGER               , INTENT(in ) ,OPTIONAL ::   ktime     ! record number
216      INTEGER , DIMENSION(:), INTENT(in ), OPTIONAL ::   kstart    ! start position of the reading in each axis
217      INTEGER , DIMENSION(:), INTENT(in ), OPTIONAL ::   kcount    ! number of points to be read in each axis
218!
219      CHARACTER(LEN=100) :: clinfo                    ! info character
220!
221      clinfo = 'iom_get_r_1d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
222      IF( PRESENT(kstart) ) THEN
223         IF ( SIZE(kstart) /= 1 ) CALL ctl_stop( trim(clinfo), 'kstart must be a 1 element vector' )
224      ENDIF
225      IF( PRESENT(kcount) ) THEN
226         IF ( SIZE(kcount) /= 1 ) CALL ctl_stop( trim(clinfo), 'kcount must be a 1 element vector' )
227      ENDIF
228      IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom       , cdvar        , pv_r1d=pvar,   &
229           &                                     ktime=ktime, kstart=kstart, kcount=kcount )
230   END SUBROUTINE iom_get_r_1d
231   SUBROUTINE iom_get_r_2d( knumfl, kdom , cdvar , pvar  ,   &
232      &                             ktime, kstart, kcount )
233      INTEGER,INTENT(in) :: knumfl
234      INTEGER,INTENT(in) :: kdom
235      CHARACTER(len=*),INTENT(in) :: cdvar
236      REAL(wp),INTENT(out),DIMENSION(:,:) :: pvar
237      INTEGER,INTENT(in),OPTIONAL :: ktime
238      INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kstart
239      INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kcount
240!
241      CHARACTER(LEN=100) :: clinfo                    ! info character
242!
243      clinfo = 'iom_get_r_2d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
244      IF( PRESENT(kstart) ) THEN
245         IF ( size(kstart) /= 2 ) CALL ctl_stop(trim(clinfo), 'kstart must be a 2 element vector')
246      ENDIF
247      IF( PRESENT(kcount) ) THEN
248         IF ( size(kcount) /= 2 ) CALL ctl_stop(trim(clinfo), 'kcount must be a 2 element vector')
249      ENDIF
250      IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom       , cdvar        , pv_r2d=pvar,   &
251         &                                       ktime=ktime, kstart=kstart, kcount=kcount )
252   END SUBROUTINE iom_get_r_2d
253   SUBROUTINE iom_get_r_3d( knumfl, kdom , cdvar , pvar  ,   &
254      &                             ktime, kstart, kcount )
255      INTEGER,INTENT(in) :: knumfl
256      INTEGER,INTENT(in) :: kdom
257      CHARACTER(len=*),INTENT(in) :: cdvar
258      REAL(wp),INTENT(out),DIMENSION(:,:,:) :: pvar
259      INTEGER,INTENT(in),OPTIONAL :: ktime
260      INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kstart
261      INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kcount
262!
263      CHARACTER(LEN=100) :: clinfo                    ! info character
264!
265      clinfo = 'iom_get_r_3d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
266      IF ( PRESENT(kstart) ) THEN
267         IF ( size(kstart) /= 3 ) CALL ctl_stop(trim(clinfo), 'kstart must be a 3 element vector')
268      ENDIF
269      IF ( PRESENT(kcount) ) THEN
270         IF ( size(kcount) /= 3 ) CALL ctl_stop(trim(clinfo), 'kcount must be a 3 element vector')
271      ENDIF
272      IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom       , cdvar        , pv_r3d=pvar,   &
273        &                                   ktime=ktime, kstart=kstart, kcount=kcount )
274   END SUBROUTINE iom_get_r_3d
275   !!----------------------------------------------------------------------
276
277
278   SUBROUTINE iom_u_getv( knumfl, kdom  , cdvar , &
279        &                   pv_r1d, pv_r2d, pv_r3d, &
280        &                   ktime , kstart, kcount )
281     !!-----------------------------------------------------------------------
282     !!                  ***  ROUTINE  iom_u_getv  ***
283     !!
284     !! ** Purpose : read a 1D/2D/3D variable
285     !!
286     !! ** Method : read ONE time step at each CALL
287     !!
288     !!-----------------------------------------------------------------------
289     INTEGER,                      INTENT(in )           ::   knumfl     ! Identifier of the file
290     INTEGER,                      INTENT(in )           ::   kdom       ! Type of domain to be read
291     CHARACTER(len=*),             INTENT(in )           ::   cdvar      ! Name of the variable
292     REAL(wp), DIMENSION(:)      , INTENT(out), OPTIONAL ::   pv_r1d     ! read field (1D case)
293     REAL(wp), DIMENSION(:,:)    , INTENT(out), OPTIONAL ::   pv_r2d     ! read field (2D case)
294     REAL(wp), DIMENSION(:,:,:)  , INTENT(out), OPTIONAL ::   pv_r3d     ! read field (3D case)
295     INTEGER                     , INTENT(in ), OPTIONAL ::   ktime      ! record number
296     INTEGER , DIMENSION(:)      , INTENT(in ), OPTIONAL ::   kstart     ! start position of the reading in each axis
297     INTEGER , DIMENSION(:)      , INTENT(in ), OPTIONAL ::   kcount     ! number of points to be read in each axis
298
299     INTEGER                        :: jl            ! loop on number of dimension
300     INTEGER                        :: idom,    &    ! type of domain
301          &                            idvar,   &    ! id of the variable
302          &                            inbdim,  &    ! number of dimensions of the variable
303          &                            idmspc,  &    ! number of spatial dimensions
304          &                            itime,   &    ! record number
305          &                            istop         ! temporary value of nstop
306     INTEGER, DIMENSION(jpmax_dims) :: istart,  &    ! starting point to read for each axis
307          &                            icnt,    &    ! number of value to read along each axis
308          &                            idimsz        ! size of the dimensions of the variable
309     REAL(wp)                       :: zscf, zofs    ! sacle_factor and add_offset
310     INTEGER                        ::  itmp         ! temporary integer
311     CHARACTER(LEN=100)             :: clinfo        ! info character
312     !---------------------------------------------------------------------
313     clinfo = 'iom_u_getv, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
314     ! local definition of the domain ?
315     idom = kdom
316     ! check kcount and kstart optionals parameters...
317     IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) &
318          CALL ctl_stop( trim(clinfo), 'kcount present needs kstart present' )
319     IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) &
320          CALL ctl_stop( trim(clinfo), 'kstart present needs kcount present' )
321     IF( PRESENT(kstart) .AND. idom /= jpdom_unknown ) &
322          CALL ctl_stop( trim(clinfo), 'kstart present needs kdom = jpdom_unknown' )
323
324     ! Search for the variable in the data base (eventually actualize data)
325     !-
326     istop = nstop
327     idvar = iom_varid( knumfl, cdvar )
328     !
329     IF ( idvar > 0 ) THEN
330        ! to write iom_file(knumfl)%dimsz in a shorter way !
331        idimsz(:) = iom_file(knumfl)%dimsz(:, idvar) 
332        inbdim = iom_file(knumfl)%ndims(idvar)! number of dimensions in the file
333        idmspc = inbdim ! number of spatial dimensions in the file
334        IF( iom_file(knumfl)%luld(idvar) ) idmspc = inbdim - 1
335        IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions',   &
336             &                    'this case is not coded...') 
337        ! Identify the domain in case of jpdom_local definition
338        !-
339        IF( idom == jpdom_local ) THEN
340           IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
341              idom = jpdom_local_full
342           ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN
343              idom = jpdom_local_noextra
344           ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN
345              idom = jpdom_local_noovlap
346           ELSE
347              CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )
348           ENDIF
349        ENDIF
350
351        ! definition of istart and icnt
352        !-
353        ! initializations
354        istart(:) = 1
355        icnt(:) = 1
356        itime = 1
357        IF( PRESENT(ktime) ) itime = ktime
358        !
359        IF( PRESENT(pv_r1d) ) THEN
360           IF( idmspc == 1 ) THEN 
361              ! data is 1d array (+ maybe a temporal dimension)
362              IF( PRESENT(kstart) ) THEN
363                 istart(1:2) = (/ kstart(1), itime /)
364                 icnt(1) = kcount(1)
365              ELSE
366                 IF( kdom == jpdom_unknown ) THEN
367                    istart(2) = itime
368                    icnt(1) = idimsz(1)
369                 ELSE
370                    CALL ctl_stop( trim(clinfo), 'case not coded...You must use jpdom_unknown' )
371                 ENDIF
372              ENDIF
373           ELSE
374              CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 1D array,', &
375                   &         'we do not accept data with more than 1 spatial dimension',     &
376                   &         'Use ncwa -a to suppress the unnecessary dimensions')
377           ENDIF
378        ELSEIF( PRESENT(pv_r2d) ) THEN
379           SELECT CASE (idmspc)
380           CASE (1)
381              CALL ctl_stop( trim(clinfo), 'the file has only 1 spatial dimension',  &
382                   &         'it is impossible to read a 2d array from this file...')
383           CASE (2)
384              ! data is 2d array (+ maybe a temporal dimension)
385              IF ( PRESENT(kstart) ) THEN
386                 istart(1:3) = (/ kstart(1:2), itime /)
387                 icnt(1:2) = kcount(1:2)
388              ELSE
389                 IF( kdom == jpdom_unknown ) THEN
390                    istart(3) = itime
391                    icnt(1:2) = idimsz(1:2)
392                 ELSE
393                    IF( idom == jpdom_data ) THEN
394                       istart(1:3) = (/ mig(1), mjg(1), itime /)
395                    ELSEIF( idom == jpdom_global ) THEN
396                       istart(1:3) = (/ nimpp, njmpp, itime /)
397                    ENDIF
398                    ! we do not read the overlap -> we start to read at nldi, nldj
399                    IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
400                    ! we do not read the overlap and the extra-halos 
401                    ! -> from nldi to nlei and from nldj to nlej
402                    icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
403                 ENDIF
404              ENDIF
405           CASE DEFAULT
406              IF ( itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN
407                 CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...', &
408                      &         'As the size of the z dimension is 1 and as we try to read the first reacord, ',     &
409                      &         'we accept this case even if there is a possible mix-up between z and time dimension...')           
410                 IF ( PRESENT(kstart) ) THEN
411                    istart(1:2) = kstart(1:2)
412                    icnt(1:2) = kcount(1:2)
413                 ELSE
414                    IF( kdom == jpdom_unknown ) THEN
415                       icnt(1:2) = idimsz(1:2)
416                    ELSE
417                       IF( idom == jpdom_data ) THEN
418                          istart(1:2) = (/ mig(1), mjg(1) /)
419                       ELSEIF( idom == jpdom_global ) THEN
420                          istart(1:2) = (/ nimpp, njmpp /)
421                       ENDIF
422                       ! we do not read the overlap -> we start to read at nldi, nldj
423                       IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
424                       ! we do not read the overlap and the extra-halos 
425                       ! -> from nldi to nlei and from nldj to nlej
426                       icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
427                    ENDIF
428                 ENDIF
429              ELSE
430                 CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 2D array,', &
431                      &         'we do not accept data with more than 2 spatial dimension',     &
432                      &         'Use ncwa -a to suppress the unnecessary dimensions')           
433              ENDIF
434           END SELECT
435        ELSEIF( PRESENT(pv_r3d) ) THEN
436           SELECT CASE (idmspc)
437           CASE (1)
438              CALL ctl_stop(trim(clinfo), 'the file has only 1 spatial dimension',   &
439                   &        'it is impossible to read a 3d array from this file...')
440           CASE (2)
441              CALL ctl_stop(trim(clinfo), 'the file has only 2 spatial dimension',   &
442                   &        'it is impossible to read a 3d array from this file...')
443           CASE (3)
444              ! data is 3d array (+ maybe a temporal dimension)
445              IF( PRESENT(kstart) ) THEN
446                 istart(1:4) = (/ kstart(1:3), itime /)
447                 icnt(1:3) = kcount(1:3)
448              ELSE
449                 IF( kdom == jpdom_unknown ) THEN
450                    istart(4) = itime
451                    icnt(1:3) = idimsz(1:3)
452                 ELSE
453                    IF( idom == jpdom_data ) THEN
454                       istart(1:4) = (/ mig(1), mjg(1), 1, itime /)
455                    ELSEIF( idom == jpdom_global ) THEN
456                       istart(1:4) = (/ nimpp, njmpp, 1, itime /)
457                    ENDIF
458                    ! we do not read the overlap -> we start to read at nldi, nldj
459                    IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
460                    ! we do not read the overlap and the extra-halos
461                    ! -> from nldi to nlei and from nldj to nlej
462                    icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
463                    IF( idom == jpdom_data ) THEN
464                       icnt(3) = jpkdta
465                    ELSE
466                       icnt(3) = jpk
467                    ENDIF
468                 ENDIF
469              ENDIF
470           CASE DEFAULT
471              CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 3D array,', &
472                   &         'we do not accept data with more than 3 spatial dimension',     &
473                   &         'Use ncwa -a to suppress the unnecessary dimensions')           
474           END SELECT
475        ENDIF
476
477        ! check that istart and icnt can be used with this file
478        !-
479        DO jl = 1, jpmax_dims
480           itmp = istart(jl)+icnt(jl)-1
481           IF( (itmp) > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN
482              WRITE(ctmp1,*) '(istart(',jl,') + icnt(',jl,') - 1) = ', itmp
483              WRITE(ctmp2,*) ' is larger than idimsz(',jl,'): ', idimsz(jl)
484              CALL ctl_stop( trim(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 )     
485           ENDIF
486        END DO
487
488        ! check that istart and icnt match the input array
489        !-     
490        IF( PRESENT(pv_r1d) ) THEN
491           itmp = size(pv_r1d)
492           WRITE(ctmp1,*) 'size(pv_r1d): ', itmp, ' /= icnt(1): ', icnt(1)
493           IF( itmp /= icnt(1) ) CALL ctl_stop( trim(clinfo), ctmp1 )
494        ELSEIF( PRESENT(pv_r2d) ) THEN
495           DO jl = 1, 2
496              IF( idom == jpdom_unknown ) THEN
497                 itmp = size(pv_r2d, jl)
498                 WRITE(ctmp1,*) 'size(pv_r2d, ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
499              ELSE
500                 itmp = size(pv_r2d(nldi:nlei,nldj:nlej), jl)
501                 WRITE(ctmp1,*) 'size(pv_r2d(nldi:nlei,nldj:nlej), ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
502              ENDIF
503              IF( itmp /= icnt(jl) ) CALL ctl_stop( trim(clinfo), ctmp1 )
504           END DO
505        ELSEIF( PRESENT(pv_r3d) ) THEN
506           DO jl = 1, 3
507              IF( idom == jpdom_unknown ) THEN
508                 itmp = size(pv_r3d, jl)
509                 WRITE(ctmp1,*) 'size(pv_r3d, ',jl,'): ',itmp,' /= icnt(',jl,'):', icnt(jl)
510              ELSE
511                 itmp = size(pv_r3d(nldi:nlei,nldj:nlej,:), jl)
512                 WRITE(ctmp1,*) 'size(pv_r3d(nldi:nlei,nldj:nlej), ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
513              ENDIF
514              IF( itmp /= icnt(jl) ) CALL ctl_stop( trim(clinfo), ctmp1 )
515           END DO
516        ENDIF
517     ENDIF
518
519     ! read the data
520     !-     
521     IF( istop == nstop) THEN ! no additional errors until this point...
522        !
523        istop = nstop
524        !
525        zscf = iom_file(knumfl)%scf(idvar)      ! scale factor
526        zofs = iom_file(knumfl)%ofs(idvar)      ! offset
527        !
528        IF( PRESENT(pv_r1d) ) THEN
529           CALL fliogetv( knumfl, cdvar, pv_r1d(:), start=istart(1:inbdim), count=icnt(1:inbdim) )
530           !--- Apply scale_factor and offset
531           IF( zscf /= 1. ) pv_r1d(:) = pv_r1d(:) * zscf 
532           IF( zofs /= 0. ) pv_r1d(:) = pv_r1d(:) + zofs
533        ELSEIF( PRESENT(pv_r2d) ) THEN
534           IF( idom /= jpdom_unknown ) THEN
535              CALL fliogetv( knumfl, cdvar, pv_r2d(nldi:nlei,nldj:nlej), start=istart(1:inbdim), count=icnt(1:inbdim) )
536              !--- Apply scale_factor and offset
537              IF (zscf /= 1.) pv_r2d(nldi:nlei, nldj:nlej) = pv_r2d(nldi:nlei,nldj:nlej) * zscf
538              IF (zofs /= 0.) pv_r2d(nldi:nlei, nldj:nlej) = pv_r2d(nldi:nlei,nldj:nlej) + zofs
539              !--- Fill the overlap areas and extra hallows (mpp)
540              CALL lbc_lnk (pv_r2d,'Z',-999.,'no0')
541           ELSE
542              CALL fliogetv( knumfl, cdvar, pv_r2d(:,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
543              !--- Apply scale_factor and offset
544              IF (zscf /= 1.) pv_r2d(:,:) = pv_r2d(:,:) * zscf
545              IF (zofs /= 0.) pv_r2d(:,:) = pv_r2d(:,:) + zofs
546           ENDIF
547        ELSEIF( PRESENT(pv_r3d) ) THEN
548           IF( idom /= jpdom_unknown ) THEN
549              CALL fliogetv( knumfl, cdvar, pv_r3d(nldi:nlei,nldj:nlej,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
550              !--- Apply scale_factor and offset
551              IF( zscf /= 1. ) pv_r3d(nldi:nlei,nldj:nlej,:) = pv_r3d(nldi:nlei,nldj:nlej,:) * zscf
552              IF( zofs /= 0. ) pv_r3d(nldi:nlei,nldj:nlej,:) = pv_r3d(nldi:nlei,nldj:nlej,:) + zofs
553              !--- Fill the overlap areas and extra hallows (mpp)
554              IF( icnt(3) == jpk )   CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) ! this if could be removed with the new lbc_lnk ...
555           ELSE
556              CALL fliogetv( knumfl, cdvar, pv_r3d(:,:,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
557              !--- Apply scale_factor and offset
558              IF (zscf /= 1.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf
559              IF (zofs /= 0.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs
560           ENDIF
561        ENDIF
562        !
563        IF( istop == nstop .AND. lwp )  &
564             &  WRITE(numout,*) ' read '//trim(cdvar)//' in '//trim(iom_file(knumfl)%name)//' ok'
565     ENDIF
566     !
567   END SUBROUTINE iom_u_getv
568
569   
570   SUBROUTINE iom_gettime( knumfl, cdvar, ptime )
571     !!--------------------------------------------------------------------
572     !!                   ***  SUBROUTINE  iom_close  ***
573     !!
574     !! ** Purpose : read the time axis cdvar in the file
575     !!
576     !! ** Method :
577     !!
578     !!--------------------------------------------------------------------
579     INTEGER               , INTENT(in)  ::   knumfl   ! Identifier of the file to be closed
580     CHARACTER(len=*)      , INTENT(in)  ::   cdvar    ! time axis name
581     REAL(wp), DIMENSION(:), INTENT(out) ::   ptime    ! the time axis
582
583     INTEGER           :: idvar    ! id of the variable
584     CHARACTER(LEN=100) :: clinfo                    ! info character
585     !---------------------------------------------------------------------
586     clinfo = 'iom_gettime, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
587     idvar = iom_varid( knumfl, cdvar )
588     !
589     ptime(:) = 0. ! default definition
590     IF ( idvar > 0 ) THEN
591        IF ( iom_file(knumfl)%ndims(idvar) == 1 ) THEN
592           IF ( iom_file(knumfl)%luld(idvar) ) THEN
593              IF ( iom_file(knumfl)%dimsz(1,idvar) == size(ptime) ) THEN
594                 CALL fliogetv( knumfl, cdvar, ptime(:), start=(/ 1 /), &
595                      &                                   count=(/ iom_file(knumfl)%dimsz(1,idvar) /) )
596              ELSE
597                 WRITE(ctmp1,*) 'error with the size of ptime ',size(ptime),iom_file(knumfl)%dimsz(1,idvar)
598                 CALL ctl_stop( trim(clinfo), trim(ctmp1) )
599              ENDIF
600           ELSE
601              CALL ctl_stop( trim(clinfo), 'variable dimension is not unlimited... use iom_get' )
602           ENDIF
603        ELSE
604           CALL ctl_stop( trim(clinfo), 'the variable has more than 1 dimension' )
605        ENDIF
606     ELSE
607        CALL ctl_stop( trim(clinfo), 'variable not found in '//iom_file(knumfl)%name )
608     ENDIF
609
610   END SUBROUTINE iom_gettime
611   
612   
613   
614   FUNCTION iom_varid ( knumfl, cdvar, kdimsz ) 
615     !!-----------------------------------------------------------------------
616     !!                  ***  FUNCTION  iom_varid  ***
617     !!
618     !! ** Purpose : get the id of a variable in a file (return 0 if not found)
619     !!
620     !! ** Method : ???
621     !!
622     !!-----------------------------------------------------------------------
623     INTEGER              , INTENT(in)            ::   knumfl   ! file Identifier
624     CHARACTER(len=*)     , INTENT(in)            ::   cdvar    ! name of the variable
625     INTEGER, DIMENSION(:), INTENT(out), OPTIONAL ::   kdimsz   ! size of the dimensions
626     !
627     INTEGER                        :: iom_varid, idvar, i_nvd, ji
628     INTEGER, DIMENSION(jpmax_dims) :: idimid
629     LOGICAL                        :: ll_fnd
630     CHARACTER(LEN=100)             :: clinfo                   ! info character
631     !!-----------------------------------------------------------------------
632     clinfo = 'iom_varid, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
633     iom_varid = 0                         ! default definition
634     IF ( PRESENT(kdimsz) ) kdimsz(:) = 0  ! default definition
635     !
636     IF ( knumfl > 0 ) THEN
637        IF( iom_file(knumfl)%iopen == 0 ) THEN
638           CALL ctl_stop( trim(clinfo), 'the file is not open' )
639        ELSE
640           !
641           ll_fnd  = .FALSE.
642           idvar = 0
643           !
644           DO WHILE ( .NOT.ll_fnd .AND. idvar < iom_file(knumfl)%nvars )
645              idvar = idvar + 1
646              ll_fnd  = ( TRIM(cdvar) == TRIM(iom_file(knumfl)%cn_var(idvar)) )
647           END DO
648           !
649           IF( .NOT.ll_fnd ) THEN
650              idvar = idvar + 1
651              IF( idvar <= jpmax_vars ) THEN
652                 CALL flioinqv( knumfl, cdvar, ll_fnd, nb_dims = i_nvd )
653                 IF( ll_fnd ) THEN
654                    IF( i_nvd <= jpmax_dims ) THEN
655                       iom_file(knumfl)%nvars           = idvar
656                       iom_file(knumfl)%cn_var(idvar) = trim(cdvar)
657                       iom_file(knumfl)%ndims(idvar)  = i_nvd
658                       CALL flioinqv( knumfl, cdvar, ll_fnd, &
659                            &         len_dims = iom_file(knumfl)%dimsz(1:i_nvd,idvar), &
660                            &         id_dims  = idimid(1:i_nvd) )
661                       DO ji = 1, i_nvd
662                          IF ( idimid(ji) == iom_file(knumfl)%iduld ) iom_file(knumfl)%luld(idvar) = .TRUE.
663                       END DO
664                       !----------
665                       !---------- Deal with scale_factor and offset
666                       CALL flioinqa( knumfl, cdvar, 'scale_factor', ll_fnd )
667                       IF (ll_fnd) THEN
668                          CALL fliogeta( knumfl, cdvar, 'scale_factor', iom_file(knumfl)%scf(idvar) )
669                       ELSE
670                          iom_file(knumfl)%scf(idvar) = 1.
671                       END IF
672                       CALL flioinqa( knumfl, cdvar, 'offset', ll_fnd )
673                       IF( ll_fnd ) THEN
674                          CALL fliogeta( knumfl, cdvar, 'offset', iom_file(knumfl)%ofs(idvar) )
675                       ELSE
676                          iom_file(knumfl)%ofs(idvar) = 0.
677                       END IF
678                       !
679                       iom_varid = idvar
680                       IF ( PRESENT(kdimsz) ) THEN
681                          IF ( i_nvd == size(kdimsz) ) THEN
682                             kdimsz(:) = iom_file(knumfl)%dimsz(1:i_nvd,idvar)
683                          ELSE
684                             WRITE(ctmp1,*) i_nvd, size(kdimsz)
685                             CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
686                          ENDIF
687                       ENDIF
688                    ELSE
689                       CALL ctl_stop( trim(clinfo), 'Too many dimensions in the file '//iom_file(knumfl)%name,   &
690                            &           'increase the parameter jpmax_vars')
691                    ENDIF
692                 ELSE 
693                    CALL ctl_warn( trim(clinfo), 'Variable '//trim(cdvar)// &
694                         & ' is not found in the file '//trim(iom_file(knumfl)%name) )
695                 ENDIF
696              ELSE
697                 CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(knumfl)%name,   &
698                      &           'increase the parameter jpmax_vars')
699              ENDIF
700           ELSE
701              iom_varid = idvar
702              IF ( PRESENT(kdimsz) ) THEN
703                 i_nvd = iom_file(knumfl)%ndims(idvar)
704                 IF ( i_nvd == size(kdimsz) ) THEN
705                    kdimsz(:) = iom_file(knumfl)%dimsz(1:i_nvd,idvar)
706                 ELSE
707                    WRITE(ctmp1,*) i_nvd, size(kdimsz)
708                    CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
709                 ENDIF
710              ENDIF
711           ENDIF
712        ENDIF
713     ENDIF
714
715   END FUNCTION iom_varid
716
717 
718   FUNCTION iom_get_gblatt( knumfl, kinfonum )
719      !!-----------------------------------------------------------------------
720      !!                  ***  FUNCTION  iom_get_gblatt  ***
721      !!
722      !! ** Purpose : ???
723      !!
724      !! ** Method : ???
725      !!
726      !!-----------------------------------------------------------------------
727      INTEGER,INTENT(in) :: knumfl
728      INTEGER,          intent(in) :: kinfonum
729      !
730      CHARACTER(LEN=10) :: clinfo
731      REAL(wp) :: iom_get_gblatt
732      !!-----------------------------------------------------------------------
733
734      WRITE(clinfo,*) kinfonum
735      clinfo = 'info'//trim(adjustl(clinfo))
736      CALL fliogeta (knumfl, "?", clinfo, iom_get_gblatt)
737
738   END FUNCTION iom_get_gblatt
739
740   !!======================================================================
741END MODULE iom
Note: See TracBrowser for help on using the repository browser.