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.F90 in trunk/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: trunk/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90 @ 3983

Last change on this file since 3983 was 3983, checked in by acc, 11 years ago

Update xml files with missing iceberg (ICB) variables and add new axis definition to iom.F90. The latter requires changes in icb modules to avoid a cyclic dependency

  • Property svn:keywords set to Id
File size: 74.3 KB
Line 
1MODULE iom
2   !!=====================================================================
3   !!                    ***  MODULE  iom ***
4   !! Input/Output manager :  Library to read input files
5   !!====================================================================
6   !! History :  2.0  ! 2005-12  (J. Belier) Original code
7   !!            2.0  ! 2006-02  (S. Masson) Adaptation to NEMO
8   !!            3.0  ! 2007-07  (D. Storkey) Changes to iom_gettime
9   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add C1D case 
10   !!--------------------------------------------------------------------
11
12   !!--------------------------------------------------------------------
13   !!   iom_open       : open a file read only
14   !!   iom_close      : close a file or all files opened by iom
15   !!   iom_get        : read a field (interfaced to several routines)
16   !!   iom_gettime    : read the time axis cdvar in the file
17   !!   iom_varid      : get the id of a variable in a file
18   !!   iom_rstput     : write a field in a restart file (interfaced to several routines)
19   !!--------------------------------------------------------------------
20   USE dom_oce         ! ocean space and time domain
21   USE c1d             ! 1D vertical configuration
22   USE flo_oce         ! floats module declarations
23   USE lbclnk          ! lateal boundary condition / mpp exchanges
24   USE iom_def         ! iom variables definitions
25   USE iom_ioipsl      ! NetCDF format with IOIPSL library
26   USE iom_nf90        ! NetCDF format with native NetCDF library
27   USE iom_rstdimg     ! restarts access direct format "dimg" style...
28   USE in_out_manager  ! I/O manager
29   USE lib_mpp           ! MPP library
30#if defined key_iomput
31   USE sbc_oce, ONLY :   nn_fsbc         ! ocean space and time domain
32   USE trc_oce, ONLY :   nn_dttrc        !  !: frequency of step on passive tracers
33   USE icb_oce, ONLY :   class_num       !  !: iceberg classes
34   USE domngb          ! ocean space and time domain
35   USE phycst          ! physical constants
36   USE dianam          ! build name of file
37   USE xios
38# endif
39   USE ioipsl, ONLY :  ju2ymds    ! for calendar
40
41   IMPLICIT NONE
42   PUBLIC   !   must be public to be able to access iom_def through iom
43   
44#if defined key_iomput
45   LOGICAL, PUBLIC, PARAMETER ::   lk_iomput = .TRUE.        !: iom_put flag
46#else
47   LOGICAL, PUBLIC, PARAMETER ::   lk_iomput = .FALSE.       !: iom_put flag
48#endif
49   PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_gettime, iom_rstput, iom_put
50   PUBLIC iom_getatt
51
52   PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
53   PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d
54   PRIVATE iom_p1d, iom_p2d, iom_p3d
55#if defined key_iomput
56   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr
57   PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate
58# endif
59
60   INTERFACE iom_get
61      MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d
62   END INTERFACE
63   INTERFACE iom_getatt
64      MODULE PROCEDURE iom_g0d_intatt
65   END INTERFACE
66   INTERFACE iom_rstput
67      MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
68   END INTERFACE
69  INTERFACE iom_put
70     MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d
71  END INTERFACE
72#if defined key_iomput
73   INTERFACE iom_setkt
74      MODULE PROCEDURE xios_update_calendar
75   END INTERFACE
76# endif
77
78   !!----------------------------------------------------------------------
79   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
80   !! $Id$
81   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
82   !!----------------------------------------------------------------------
83
84CONTAINS
85
86   SUBROUTINE iom_init
87      !!----------------------------------------------------------------------
88      !!                     ***  ROUTINE   ***
89      !!
90      !! ** Purpose :   
91      !!
92      !!----------------------------------------------------------------------
93#if defined key_iomput
94      TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0)
95      CHARACTER(len=19) :: cldate 
96      CHARACTER(len=10) :: clname
97      INTEGER           ::   ji
98      !!----------------------------------------------------------------------
99
100      clname = "nemo"
101      IF( TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
102# if defined key_mpp_mpi
103      CALL xios_context_initialize(TRIM(clname), mpi_comm_opa)
104# else
105      CALL xios_context_initialize(TRIM(clname), 0)
106# endif
107      CALL iom_swap
108
109      ! calendar parameters
110      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL
111      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian")
112      CASE ( 0)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "NoLeap")
113      CASE (30)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "D360")
114      END SELECT
115      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday 
116      CALL xios_set_context_attr(TRIM(clname), start_date=cldate )
117
118      ! horizontal grid definition
119      CALL set_scalar
120      CALL set_grid( "T", glamt, gphit ) 
121      CALL set_grid( "U", glamu, gphiu )
122      CALL set_grid( "V", glamv, gphiv )
123      CALL set_grid( "W", glamt, gphit )
124
125      ! vertical grid definition
126      CALL iom_set_axis_attr( "deptht", gdept_0 )
127      CALL iom_set_axis_attr( "depthu", gdept_0 )
128      CALL iom_set_axis_attr( "depthv", gdept_0 )
129      CALL iom_set_axis_attr( "depthw", gdepw_0 )
130# if defined key_floats
131      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) )
132# endif
133      CALL iom_set_axis_attr( "icbcla", class_num )
134     
135      ! automatic definitions of some of the xml attributs
136      CALL set_xmlatt
137
138      ! end file definition
139      dtime%second = rdt
140      CALL xios_set_timestep(dtime)
141      CALL xios_close_context_definition()
142     
143      CALL xios_update_calendar(0)
144#endif
145     
146   END SUBROUTINE iom_init
147
148
149   SUBROUTINE iom_swap
150      !!---------------------------------------------------------------------
151      !!                   ***  SUBROUTINE  iom_swap  ***
152      !!
153      !! ** Purpose :  swap context between different agrif grid for xmlio_server
154      !!---------------------------------------------------------------------
155#if defined key_iomput
156      TYPE(xios_context) :: nemo_hdl
157
158     IF( TRIM(Agrif_CFixed()) == '0' ) THEN
159        CALL xios_get_handle("nemo",nemo_hdl)
160     ELSE
161        CALL xios_get_handle(TRIM(Agrif_CFixed())//"_nemo",nemo_hdl)
162     ENDIF
163     CALL xios_set_current_context(nemo_hdl)
164
165#endif
166   END SUBROUTINE iom_swap
167
168
169   SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof )
170      !!---------------------------------------------------------------------
171      !!                   ***  SUBROUTINE  iom_open  ***
172      !!
173      !! ** Purpose :  open an input file (return 0 if not found)
174      !!---------------------------------------------------------------------
175      CHARACTER(len=*), INTENT(in   )           ::   cdname   ! File name
176      INTEGER         , INTENT(  out)           ::   kiomid   ! iom identifier of the opened file
177      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldwrt    ! open in write modeb          (default = .FALSE.)
178      INTEGER         , INTENT(in   ), OPTIONAL ::   kdom     ! Type of domain to be written (default = jpdom_local_noovlap)
179      INTEGER         , INTENT(in   ), OPTIONAL ::   kiolib   ! library used to open the file (default = jpnf90)
180      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.)
181      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldiof    ! Interp On the Fly, needed for AGRIF (default = .FALSE.)
182
183      CHARACTER(LEN=256)    ::   clname    ! the name of the file based on cdname [[+clcpu]+clcpu]
184      CHARACTER(LEN=256)    ::   cltmpn    ! tempory name to store clname (in writting mode)
185      CHARACTER(LEN=10)     ::   clsuffix  ! ".nc" or ".dimg"
186      CHARACTER(LEN=15)     ::   clcpu     ! the cpu number (max jpmax_digits digits)
187      CHARACTER(LEN=256)    ::   clinfo    ! info character
188      LOGICAL               ::   llok      ! check the existence
189      LOGICAL               ::   llwrt     ! local definition of ldwrt
190      LOGICAL               ::   llnoov    ! local definition to read overlap
191      LOGICAL               ::   llstop    ! local definition of ldstop
192      LOGICAL               ::   lliof     ! local definition of ldiof
193      INTEGER               ::   iolib     ! library do we use to open the file
194      INTEGER               ::   icnt      ! counter for digits in clcpu (max = jpmax_digits)
195      INTEGER               ::   iln, ils  ! lengths of character
196      INTEGER               ::   idom      ! type of domain
197      INTEGER               ::   istop     !
198      INTEGER, DIMENSION(2,5) ::   idompar ! domain parameters:
199      ! local number of points for x,y dimensions
200      ! position of first local point for x,y dimensions
201      ! position of last local point for x,y dimensions
202      ! start halo size for x,y dimensions
203      ! end halo size for x,y dimensions
204      !---------------------------------------------------------------------
205      ! Initializations and control
206      ! =============
207      kiomid = -1
208      clinfo = '                    iom_open ~~~  '
209      istop = nstop
210      ! if iom_open is called for the first time: initialize iom_file(:)%nfid to 0
211      ! (could be done when defining iom_file in f95 but not in f90)
212      IF( Agrif_Root() ) THEN
213         IF( iom_open_init == 0 ) THEN
214            iom_file(:)%nfid = 0
215            iom_open_init = 1
216         ENDIF
217      ENDIF
218      ! do we read or write the file?
219      IF( PRESENT(ldwrt) ) THEN   ;   llwrt = ldwrt
220      ELSE                        ;   llwrt = .FALSE.
221      ENDIF
222      ! do we call ctl_stop if we try to open a non-existing file in read mode?
223      IF( PRESENT(ldstop) ) THEN   ;   llstop = ldstop
224      ELSE                         ;   llstop = .TRUE.
225      ENDIF
226      ! what library do we use to open the file?
227      IF( PRESENT(kiolib) ) THEN   ;   iolib = kiolib
228      ELSE                         ;   iolib = jpnf90
229      ENDIF
230      ! are we using interpolation on the fly?
231      IF( PRESENT(ldiof) ) THEN   ;   lliof = ldiof
232      ELSE                        ;   lliof = .FALSE.
233      ENDIF
234      ! do we read the overlap
235      ! ugly patch SM+JMM+RB to overwrite global definition in some cases
236      llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif 
237      ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix)
238      ! =============
239      clname   = trim(cdname)
240      IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN
241         iln    = INDEX(clname,'/') 
242         cltmpn = clname(1:iln)
243         clname = clname(iln+1:LEN_TRIM(clname))
244         clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname)
245      ENDIF
246      ! which suffix should we use?
247      SELECT CASE (iolib)
248      CASE (jpioipsl ) ;   clsuffix = '.nc'
249      CASE (jpnf90   ) ;   clsuffix = '.nc'
250      CASE (jprstdimg) ;   clsuffix = '.dimg'
251      CASE DEFAULT     ;   clsuffix = ''
252         CALL ctl_stop( TRIM(clinfo), 'accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
253      END SELECT
254      ! Add the suffix if needed
255      iln = LEN_TRIM(clname)
256      ils = LEN_TRIM(clsuffix)
257      IF( iln <= ils .OR. INDEX( TRIM(clname), TRIM(clsuffix), back = .TRUE. ) /= iln - ils + 1 )   &
258         &   clname = TRIM(clname)//TRIM(clsuffix)
259      cltmpn = clname   ! store this name
260      ! try to find if the file to be opened already exist
261      ! =============
262      INQUIRE( FILE = clname, EXIST = llok )
263      IF( .NOT.llok ) THEN
264         ! we try to add the cpu number to the name
265         IF( iolib == jprstdimg ) THEN   ;   WRITE(clcpu,*) narea
266         ELSE                            ;   WRITE(clcpu,*) narea-1
267         ENDIF
268         clcpu  = TRIM(ADJUSTL(clcpu))
269         iln = INDEX(clname,TRIM(clsuffix), back = .TRUE.)
270         clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix)
271         icnt = 0
272         INQUIRE( FILE = clname, EXIST = llok ) 
273         ! we try different formats for the cpu number by adding 0
274         DO WHILE( .NOT.llok .AND. icnt < jpmax_digits )
275            clcpu  = "0"//trim(clcpu)
276            clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix)
277            INQUIRE( FILE = clname, EXIST = llok )
278            icnt = icnt + 1
279         END DO
280      ENDIF
281      IF( llwrt ) THEN
282         ! check the domain definition
283! JMM + SM: ugly patch before getting the new version of lib_mpp)
284!         idom = jpdom_local_noovlap   ! default definition
285         IF( llnoov ) THEN   ;   idom = jpdom_local_noovlap   ! default definition
286         ELSE                ;   idom = jpdom_local_full      ! default definition
287         ENDIF
288         IF( PRESENT(kdom) )   idom = kdom
289         ! create the domain informations
290         ! =============
291         SELECT CASE (idom)
292         CASE (jpdom_local_full)
293            idompar(:,1) = (/ jpi             , jpj              /)
294            idompar(:,2) = (/ nimpp           , njmpp            /)
295            idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1  /)
296            idompar(:,4) = (/ nldi - 1        , nldj - 1         /)
297            idompar(:,5) = (/ jpi - nlei      , jpj - nlej       /)
298         CASE (jpdom_local_noextra)
299            idompar(:,1) = (/ nlci            , nlcj             /)
300            idompar(:,2) = (/ nimpp           , njmpp            /)
301            idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)
302            idompar(:,4) = (/ nldi - 1        , nldj - 1         /)
303            idompar(:,5) = (/ nlci - nlei     , nlcj - nlej      /)
304         CASE (jpdom_local_noovlap)
305            idompar(:,1) = (/ nlei  - nldi + 1, nlej  - nldj + 1 /)
306            idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)
307            idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)
308            idompar(:,4) = (/ 0               , 0                /)
309            idompar(:,5) = (/ 0               , 0                /)
310         CASE DEFAULT
311            CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )
312         END SELECT
313      ENDIF
314      ! Open the NetCDF or RSTDIMG file
315      ! =============
316      ! do we have some free file identifier?
317      IF( MINVAL(iom_file(:)%nfid) /= 0 )   &
318         &   CALL ctl_stop( TRIM(clinfo), 'No more free file identifier', 'increase jpmax_files in iom_def' )
319      ! if no file was found...
320      IF( .NOT. llok ) THEN
321         IF( .NOT. llwrt ) THEN   ! we are in read mode
322            IF( llstop ) THEN   ;   CALL ctl_stop( TRIM(clinfo), 'File '//TRIM(cltmpn)//'* not found' )
323            ELSE                ;   istop = nstop + 1   ! make sure that istop /= nstop so we don't open the file
324            ENDIF
325         ELSE                     ! we are in write mode so we
326            clname = cltmpn       ! get back the file name without the cpu number
327         ENDIF
328      ELSE
329         IF( llwrt .AND. .NOT. ln_clobber ) THEN   ! we stop as we want to write in a new file
330            CALL ctl_stop( TRIM(clinfo), 'We want to write in a new file but '//TRIM(clname)//' already exists...' )
331            istop = nstop + 1                      ! make sure that istop /= nstop so we don't open the file
332         ENDIF
333      ENDIF
334      IF( istop == nstop ) THEN   ! no error within this routine
335         SELECT CASE (iolib)
336         CASE (jpioipsl )   ;   CALL iom_ioipsl_open(  clname, kiomid, llwrt, llok, idompar )
337         CASE (jpnf90   )   ;   CALL iom_nf90_open(    clname, kiomid, llwrt, llok, idompar )
338         CASE (jprstdimg)   ;   CALL iom_rstdimg_open( clname, kiomid, llwrt, llok, idompar )
339         CASE DEFAULT
340            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
341         END SELECT
342      ENDIF
343      !
344   END SUBROUTINE iom_open
345
346
347   SUBROUTINE iom_close( kiomid )
348      !!--------------------------------------------------------------------
349      !!                   ***  SUBROUTINE  iom_close  ***
350      !!
351      !! ** Purpose : close an input file, or all files opened by iom
352      !!--------------------------------------------------------------------
353      INTEGER, INTENT(inout), OPTIONAL ::   kiomid   ! iom identifier of the file to be closed
354      !                                              ! return 0 when file is properly closed
355      !                                              ! No argument: all files opened by iom are closed
356
357      INTEGER ::   jf         ! dummy loop indices
358      INTEGER ::   i_s, i_e   ! temporary integer
359      CHARACTER(LEN=100)    ::   clinfo    ! info character
360      !---------------------------------------------------------------------
361      !
362      clinfo = '                    iom_close ~~~  '
363      IF( PRESENT(kiomid) ) THEN
364         i_s = kiomid
365         i_e = kiomid
366      ELSE
367         i_s = 1
368         i_e = jpmax_files
369      ENDIF
370
371      IF( i_s > 0 ) THEN
372         DO jf = i_s, i_e
373            IF( iom_file(jf)%nfid > 0 ) THEN
374               SELECT CASE (iom_file(jf)%iolib)
375               CASE (jpioipsl )   ;   CALL iom_ioipsl_close(  jf )
376               CASE (jpnf90   )   ;   CALL iom_nf90_close(    jf )
377               CASE (jprstdimg)   ;   CALL iom_rstdimg_close( jf )
378               CASE DEFAULT
379                  CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
380               END SELECT
381               iom_file(jf)%nfid       = 0          ! free the id
382               IF( PRESENT(kiomid) )   kiomid = 0   ! return 0 as id to specify that the file was closed
383               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok'
384            ELSEIF( PRESENT(kiomid) ) THEN
385               WRITE(ctmp1,*) '--->',  kiomid
386               CALL ctl_stop( TRIM(clinfo)//' Invalid file identifier', ctmp1 )
387            ENDIF
388         END DO
389      ENDIF
390      !   
391   END SUBROUTINE iom_close
392
393
394   FUNCTION iom_varid ( kiomid, cdvar, kdimsz, ldstop ) 
395      !!-----------------------------------------------------------------------
396      !!                  ***  FUNCTION  iom_varid  ***
397      !!
398      !! ** Purpose : get the id of a variable in a file (return 0 if not found)
399      !!-----------------------------------------------------------------------
400      INTEGER              , INTENT(in   )           ::   kiomid   ! file Identifier
401      CHARACTER(len=*)     , INTENT(in   )           ::   cdvar    ! name of the variable
402      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of the dimensions
403      LOGICAL              , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if looking for non-existing variable (default = .TRUE.)
404      !
405      INTEGER                        ::   iom_varid, iiv, i_nvd
406      LOGICAL                        ::   ll_fnd
407      CHARACTER(LEN=100)             ::   clinfo                   ! info character
408      LOGICAL                        ::   llstop                   ! local definition of ldstop
409      !!-----------------------------------------------------------------------
410      iom_varid = 0                         ! default definition
411      ! do we call ctl_stop if we look for non-existing variable?
412      IF( PRESENT(ldstop) ) THEN   ;   llstop = ldstop
413      ELSE                         ;   llstop = .TRUE.
414      ENDIF
415      !
416      IF( kiomid > 0 ) THEN
417         clinfo = 'iom_varid, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(cdvar)
418         IF( iom_file(kiomid)%nfid == 0 ) THEN
419            CALL ctl_stop( trim(clinfo), 'the file is not open' )
420         ELSE
421            ll_fnd  = .FALSE.
422            iiv = 0
423            !
424            DO WHILE ( .NOT.ll_fnd .AND. iiv < iom_file(kiomid)%nvars )
425               iiv = iiv + 1
426               ll_fnd  = ( TRIM(cdvar) == TRIM(iom_file(kiomid)%cn_var(iiv)) )
427            END DO
428            !
429            IF( .NOT.ll_fnd ) THEN
430               iiv = iiv + 1
431               IF( iiv <= jpmax_vars ) THEN
432                  SELECT CASE (iom_file(kiomid)%iolib)
433                  CASE (jpioipsl )   ;   iom_varid = iom_ioipsl_varid( kiomid, cdvar, iiv, kdimsz )
434                  CASE (jpnf90   )   ;   iom_varid = iom_nf90_varid  ( kiomid, cdvar, iiv, kdimsz )
435                  CASE (jprstdimg)   ;   iom_varid = -1   ! all variables are listed in iom_file
436                  CASE DEFAULT   
437                     CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
438                  END SELECT
439               ELSE
440                  CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name,   &
441                        &                         'increase the parameter jpmax_vars')
442               ENDIF
443               IF( llstop .AND. iom_varid == -1 )   CALL ctl_stop( TRIM(clinfo)//' not found' ) 
444            ELSE
445               iom_varid = iiv
446               IF( PRESENT(kdimsz) ) THEN
447                  i_nvd = iom_file(kiomid)%ndims(iiv)
448                  IF( i_nvd == size(kdimsz) ) THEN
449                     kdimsz(:) = iom_file(kiomid)%dimsz(1:i_nvd,iiv)
450                  ELSE
451                     WRITE(ctmp1,*) i_nvd, size(kdimsz)
452                     CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
453                  ENDIF
454               ENDIF
455            ENDIF
456         ENDIF
457      ENDIF
458      !
459   END FUNCTION iom_varid
460
461
462   !!----------------------------------------------------------------------
463   !!                   INTERFACE iom_get
464   !!----------------------------------------------------------------------
465   SUBROUTINE iom_g0d( kiomid, cdvar, pvar )
466      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
467      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable
468      REAL(wp)        , INTENT(  out)                 ::   pvar      ! read field
469      !
470      INTEGER               :: idvar   ! variable id
471      !
472      IF( kiomid > 0 ) THEN
473         idvar = iom_varid( kiomid, cdvar )
474         IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN
475            SELECT CASE (iom_file(kiomid)%iolib)
476            CASE (jpioipsl )   ;   CALL iom_ioipsl_get(  kiomid, idvar, pvar )
477            CASE (jpnf90   )   ;   CALL iom_nf90_get(    kiomid, idvar, pvar )
478            CASE (jprstdimg)   ;   CALL iom_rstdimg_get( kiomid, idvar, pvar )
479            CASE DEFAULT   
480               CALL ctl_stop( 'iom_g0d: accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
481            END SELECT
482         ENDIF
483      ENDIF
484   END SUBROUTINE iom_g0d
485
486   SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )
487      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file
488      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read
489      CHARACTER(len=*), INTENT(in   )                         ::   cdvar     ! Name of the variable
490      REAL(wp)        , INTENT(  out), DIMENSION(:)           ::   pvar      ! read field
491      INTEGER         , INTENT(in   )              , OPTIONAL ::   ktime     ! record number
492      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading
493      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis
494      !
495      IF( kiomid > 0 ) THEN
496         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=pvar,   &
497              &                                                     ktime=ktime, kstart=kstart, kcount=kcount )
498      ENDIF
499   END SUBROUTINE iom_g1d
500
501   SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )
502      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file
503      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read
504      CHARACTER(len=*), INTENT(in   )                           ::   cdvar     ! Name of the variable
505      REAL(wp)        , INTENT(  out), DIMENSION(:,:)           ::   pvar      ! read field
506      INTEGER         , INTENT(in   )                , OPTIONAL ::   ktime     ! record number
507      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading
508      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kcount    ! number of points in each axis
509      !
510      IF( kiomid > 0 ) THEN
511         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   &
512              &                                                     ktime=ktime, kstart=kstart, kcount=kcount )
513      ENDIF
514   END SUBROUTINE iom_g2d
515
516   SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )
517      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file
518      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read
519      CHARACTER(len=*), INTENT(in   )                             ::   cdvar     ! Name of the variable
520      REAL(wp)        , INTENT(  out), DIMENSION(:,:,:)           ::   pvar      ! read field
521      INTEGER         , INTENT(in   )                  , OPTIONAL ::   ktime     ! record number
522      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading
523      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kcount    ! number of points in each axis
524      !
525      IF( kiomid > 0 ) THEN
526         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   &
527              &                                                     ktime=ktime, kstart=kstart, kcount=kcount )
528      ENDIF
529   END SUBROUTINE iom_g3d
530   !!----------------------------------------------------------------------
531
532   SUBROUTINE iom_get_123d( kiomid, kdom  , cdvar ,   &
533         &                  pv_r1d, pv_r2d, pv_r3d,   &
534         &                  ktime , kstart, kcount  )
535      !!-----------------------------------------------------------------------
536      !!                  ***  ROUTINE  iom_get_123d  ***
537      !!
538      !! ** Purpose : read a 1D/2D/3D variable
539      !!
540      !! ** Method : read ONE record at each CALL
541      !!-----------------------------------------------------------------------
542      INTEGER                    , INTENT(in   )           ::   kiomid     ! Identifier of the file
543      INTEGER                    , INTENT(in   )           ::   kdom       ! Type of domain to be read
544      CHARACTER(len=*)           , INTENT(in   )           ::   cdvar      ! Name of the variable
545      REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d     ! read field (1D case)
546      REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d     ! read field (2D case)
547      REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d     ! read field (3D case)
548      INTEGER                    , INTENT(in   ), OPTIONAL ::   ktime      ! record number
549      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis
550      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis
551      !
552      LOGICAL                        ::   llnoov      ! local definition to read overlap
553      INTEGER                        ::   jl          ! loop on number of dimension
554      INTEGER                        ::   idom        ! type of domain
555      INTEGER                        ::   idvar       ! id of the variable
556      INTEGER                        ::   inbdim      ! number of dimensions of the variable
557      INTEGER                        ::   idmspc      ! number of spatial dimensions
558      INTEGER                        ::   itime       ! record number
559      INTEGER                        ::   istop       ! temporary value of nstop
560      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes
561      INTEGER                        ::   ji, jj      ! loop counters
562      INTEGER                        ::   irankpv       !
563      INTEGER                        ::   ind1, ind2  ! substring index
564      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis
565      INTEGER, DIMENSION(jpmax_dims) ::   icnt        ! number of value to read along each axis
566      INTEGER, DIMENSION(jpmax_dims) ::   idimsz      ! size of the dimensions of the variable
567      INTEGER, DIMENSION(jpmax_dims) ::   ishape      ! size of the dimensions of the variable
568      REAL(wp)                       ::   zscf, zofs  ! sacle_factor and add_offset
569      INTEGER                        ::   itmp        ! temporary integer
570      CHARACTER(LEN=256)             ::   clinfo      ! info character
571      CHARACTER(LEN=256)             ::   clname      ! file name
572      CHARACTER(LEN=1)               ::   clrankpv, cldmspc      !
573      !---------------------------------------------------------------------
574      !
575      clname = iom_file(kiomid)%name   !   esier to read
576      clinfo = '          iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar)
577      ! local definition of the domain ?
578      idom = kdom
579      ! do we read the overlap
580      ! ugly patch SM+JMM+RB to overwrite global definition in some cases
581      llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif 
582      ! check kcount and kstart optionals parameters...
583      IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present')
584      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present')
585      IF( PRESENT(kstart) .AND. idom /= jpdom_unknown   ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown')
586
587      ! Search for the variable in the data base (eventually actualize data)
588      istop = nstop
589      idvar = iom_varid( kiomid, cdvar )
590      !
591      IF( idvar > 0 ) THEN
592         ! to write iom_file(kiomid)%dimsz in a shorter way !
593         idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) 
594         inbdim = iom_file(kiomid)%ndims(idvar)            ! number of dimensions in the file
595         idmspc = inbdim                                   ! number of spatial dimensions in the file
596         IF( iom_file(kiomid)%luld(idvar) )   idmspc = inbdim - 1
597         IF( idmspc > 3 )   CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') 
598         !
599         ! update idom definition...
600         ! Identify the domain in case of jpdom_auto(glo/dta) definition
601         IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN           
602            IF( idom == jpdom_autoglo ) THEN   ;   idom = jpdom_global 
603            ELSE                               ;   idom = jpdom_data
604            ENDIF
605            ind1 = INDEX( clname, '_', back = .TRUE. ) + 1
606            ind2 = INDEX( clname, '.', back = .TRUE. ) - 1
607            IF( ind2 > ind1 ) THEN   ;   IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 )   idom = jpdom_local   ;   ENDIF
608         ENDIF
609         ! Identify the domain in case of jpdom_local definition
610         IF( idom == jpdom_local ) THEN
611            IF(     idimsz(1) == jpi               .AND. idimsz(2) == jpj               ) THEN   ;   idom = jpdom_local_full
612            ELSEIF( idimsz(1) == nlci              .AND. idimsz(2) == nlcj              ) THEN   ;   idom = jpdom_local_noextra
613            ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN   ;   idom = jpdom_local_noovlap
614            ELSE   ;   CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )
615            ENDIF
616         ENDIF
617         !
618         ! check the consistency between input array and data rank in the file
619         !
620         ! initializations
621         itime = 1
622         IF( PRESENT(ktime) ) itime = ktime
623
624         irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) )
625         WRITE(clrankpv, fmt='(i1)') irankpv
626         WRITE(cldmspc , fmt='(i1)') idmspc
627         !
628         IF(     idmspc <  irankpv ) THEN
629            CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension',   &
630               &                         'it is impossible to read a '//clrankpv//'D array from this file...' )
631         ELSEIF( idmspc == irankpv ) THEN
632            IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown )   &
633               &   CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' )
634         ELSEIF( idmspc >  irankpv ) THEN
635               IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN
636                  CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...'              ,   &
637                        &         'As the size of the z dimension is 1 and as we try to read the first record, ',   &
638                        &         'we accept this case, even if there is a possible mix-up between z and time dimension' )   
639                  idmspc = idmspc - 1
640               ELSE
641                  CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,'         ,   &
642                     &                         'we do not accept data with more than '//cldmspc//' spatial dimension',   &
643                     &                         'Use ncwa -a to suppress the unnecessary dimensions' )
644               ENDIF
645         ENDIF
646
647         !
648         ! definition of istart and icnt
649         !
650         icnt  (:) = 1
651         istart(:) = 1
652         istart(idmspc+1) = itime
653
654         IF(              PRESENT(kstart)       ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc)
655         ELSE
656            IF(           idom == jpdom_unknown ) THEN                                       ; icnt(1:idmspc) = idimsz(1:idmspc)
657            ELSE
658               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array
659                  IF(     idom == jpdom_data    ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /)  ! icnt(1:2) done bellow
660                  ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done bellow
661                  ENDIF
662                  ! we do not read the overlap                     -> we start to read at nldi, nldj
663! JMM + SM: ugly patch before getting the new version of lib_mpp)
664!                  IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
665                  IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
666                  ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej
667! JMM + SM: ugly patch before getting the new version of lib_mpp)
668!                  icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
669                  IF( llnoov ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
670                  ELSE                ;   icnt(1:2) = (/ nlci           , nlcj            /)
671                  ENDIF
672                  IF( PRESENT(pv_r3d) ) THEN
673                     IF( idom == jpdom_data ) THEN   ; icnt(3) = jpkdta
674                     ELSE                            ; icnt(3) = jpk
675                     ENDIF
676                  ENDIF
677               ENDIF
678            ENDIF
679         ENDIF
680
681         ! check that istart and icnt can be used with this file
682         !-
683         DO jl = 1, jpmax_dims
684            itmp = istart(jl)+icnt(jl)-1
685            IF( itmp > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN
686               WRITE( ctmp1, FMT="('(istart(', i1, ') + icnt(', i1, ') - 1) = ', i5)" ) jl, jl, itmp
687               WRITE( ctmp2, FMT="(' is larger than idimsz(', i1,') = ', i5)"         ) jl, idimsz(jl)
688               CALL ctl_stop( trim(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 )     
689            ENDIF
690         END DO
691
692         ! check that icnt matches the input array
693         !-     
694         IF( idom == jpdom_unknown ) THEN
695            IF( irankpv == 1 )        ishape(1:1) = SHAPE(pv_r1d)
696            IF( irankpv == 2 )        ishape(1:2) = SHAPE(pv_r2d)
697            IF( irankpv == 3 )        ishape(1:3) = SHAPE(pv_r3d)
698            ctmp1 = 'd'
699         ELSE
700            IF( irankpv == 2 ) THEN
701! JMM + SM: ugly patch before getting the new version of lib_mpp)
702!               ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej  ))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej)'
703               IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)'
704               ELSE              ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)'
705               ENDIF
706            ENDIF
707            IF( irankpv == 3 ) THEN 
708! JMM + SM: ugly patch before getting the new version of lib_mpp)
709!               ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej,:)'
710               IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'
711               ELSE              ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)'
712               ENDIF
713            ENDIF
714         ENDIF
715         
716         DO jl = 1, irankpv
717            WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl)
718            IF( ishape(jl) /= icnt(jl) )   CALL ctl_stop( TRIM(clinfo), 'size(pv_r'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) )
719         END DO
720
721      ENDIF
722
723      ! read the data
724      !-     
725      IF( idvar > 0 .AND. istop == nstop ) THEN   ! no additional errors until this point...
726         !
727         ! find the right index of the array to be read
728! JMM + SM: ugly patch before getting the new version of lib_mpp)
729!         IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej
730!         ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
731!         ENDIF
732         IF( llnoov ) THEN
733            IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej
734            ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
735            ENDIF
736         ELSE
737            IF( idom /= jpdom_unknown ) THEN   ;   ix1 = 1      ;   ix2 = nlci      ;   iy1 = 1      ;   iy2 = nlcj
738            ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
739            ENDIF
740         ENDIF
741     
742         SELECT CASE (iom_file(kiomid)%iolib)
743         CASE (jpioipsl )   ;   CALL iom_ioipsl_get(  kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2,   &
744            &                                         pv_r1d, pv_r2d, pv_r3d )
745         CASE (jpnf90   )   ;   CALL iom_nf90_get(    kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2,   &
746            &                                         pv_r1d, pv_r2d, pv_r3d )
747         CASE (jprstdimg)   ;   CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2,   &
748            &                                         pv_r1d, pv_r2d, pv_r3d )
749         CASE DEFAULT   
750            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
751         END SELECT
752
753         IF( istop == nstop ) THEN   ! no additional errors until this point...
754            IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i4,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name)
755         
756            !--- overlap areas and extra hallows (mpp)
757            IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN
758               CALL lbc_lnk( pv_r2d,'Z',-999.,'no0' )
759            ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN
760               ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension
761               IF( icnt(3) == jpk ) THEN
762                  CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' )
763               ELSE   ! put some arbitrary value (a call to lbc_lnk will be done later...)
764                  DO jj = nlcj+1, jpj   ;   pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :)   ;   END DO
765                  DO ji = nlci+1, jpi   ;   pv_r3d(ji    , : , :) = pv_r3d(nlei  , :   , :)   ;   END DO
766               ENDIF
767            ENDIF
768           
769            ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain
770            IF( lk_c1d .AND. PRESENT(pv_r2d) )   CALL lbc_lnk( pv_r2d,'Z',1. )
771            IF( lk_c1d .AND. PRESENT(pv_r3d) )   CALL lbc_lnk( pv_r3d,'Z',1. )
772   
773            !--- Apply scale_factor and offset
774            zscf = iom_file(kiomid)%scf(idvar)      ! scale factor
775            zofs = iom_file(kiomid)%ofs(idvar)      ! offset
776            IF(     PRESENT(pv_r1d) ) THEN
777               IF( zscf /= 1. )   pv_r1d(:) = pv_r1d(:) * zscf 
778               IF( zofs /= 0. )   pv_r1d(:) = pv_r1d(:) + zofs
779            ELSEIF( PRESENT(pv_r2d) ) THEN
780!CDIR COLLAPSE
781               IF( zscf /= 1.)   pv_r2d(:,:) = pv_r2d(:,:) * zscf
782!CDIR COLLAPSE
783               IF( zofs /= 0.)   pv_r2d(:,:) = pv_r2d(:,:) + zofs
784            ELSEIF( PRESENT(pv_r3d) ) THEN
785!CDIR COLLAPSE
786               IF( zscf /= 1.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf
787!CDIR COLLAPSE
788               IF( zofs /= 0.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs
789            ENDIF
790            !
791         ENDIF
792         !
793      ENDIF
794      !
795   END SUBROUTINE iom_get_123d
796
797
798   SUBROUTINE iom_gettime( kiomid, ptime, cdvar, kntime, cdunits, cdcalendar )
799      !!--------------------------------------------------------------------
800      !!                   ***  SUBROUTINE iom_gettime  ***
801      !!
802      !! ** Purpose : read the time axis cdvar in the file
803      !!--------------------------------------------------------------------
804      INTEGER                    , INTENT(in   ) ::   kiomid     ! file Identifier
805      REAL(wp), DIMENSION(:)     , INTENT(  out) ::   ptime      ! the time axis
806      CHARACTER(len=*), OPTIONAL , INTENT(in   ) ::   cdvar      ! time axis name
807      INTEGER         , OPTIONAL , INTENT(  out) ::   kntime     ! number of times in file
808      CHARACTER(len=*), OPTIONAL , INTENT(  out) ::   cdunits    ! units attribute of time coordinate
809      CHARACTER(len=*), OPTIONAL , INTENT(  out) ::   cdcalendar ! calendar attribute of
810      !
811      INTEGER, DIMENSION(1) :: kdimsz
812      INTEGER            ::   idvar    ! id of the variable
813      CHARACTER(LEN=32)  ::   tname    ! local name of time coordinate
814      CHARACTER(LEN=100) ::   clinfo   ! info character
815      !---------------------------------------------------------------------
816      !
817      IF ( PRESENT(cdvar) ) THEN
818         tname = cdvar
819      ELSE
820         tname = iom_file(kiomid)%uldname
821      ENDIF
822      IF( kiomid > 0 ) THEN
823         clinfo = 'iom_gettime, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(tname)
824         IF ( PRESENT(kntime) ) THEN
825            idvar  = iom_varid( kiomid, tname, kdimsz = kdimsz )
826            kntime = kdimsz(1)
827         ELSE
828            idvar = iom_varid( kiomid, tname )
829         ENDIF
830         !
831         ptime(:) = 0. ! default definition
832         IF( idvar > 0 ) THEN
833            IF( iom_file(kiomid)%ndims(idvar) == 1 ) THEN
834               IF( iom_file(kiomid)%luld(idvar) ) THEN
835                  IF( iom_file(kiomid)%dimsz(1,idvar) <= size(ptime) ) THEN
836                     SELECT CASE (iom_file(kiomid)%iolib)
837                     CASE (jpioipsl )   ;   CALL iom_ioipsl_gettime( kiomid, idvar, ptime, cdunits, cdcalendar )
838                     CASE (jpnf90   )   ;   CALL iom_nf90_gettime(   kiomid, idvar, ptime, cdunits, cdcalendar )
839                     CASE (jprstdimg)   ;   CALL ctl_stop( TRIM(clinfo)//' case IO library == jprstdimg not coded...' )
840                     CASE DEFAULT   
841                        CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
842                     END SELECT
843                  ELSE
844                     WRITE(ctmp1,*) 'error with the size of ptime ',size(ptime),iom_file(kiomid)%dimsz(1,idvar)
845                     CALL ctl_stop( trim(clinfo), trim(ctmp1) )
846                  ENDIF
847               ELSE
848                  CALL ctl_stop( trim(clinfo), 'variable dimension is not unlimited... use iom_get' )
849               ENDIF
850            ELSE
851               CALL ctl_stop( trim(clinfo), 'the variable has more than 1 dimension' )
852            ENDIF
853         ELSE
854            CALL ctl_stop( trim(clinfo), 'variable not found in '//iom_file(kiomid)%name )
855         ENDIF
856      ENDIF
857      !
858   END SUBROUTINE iom_gettime
859
860
861   !!----------------------------------------------------------------------
862   !!                   INTERFACE iom_getatt
863   !!----------------------------------------------------------------------
864   SUBROUTINE iom_g0d_intatt( kiomid, cdatt, pvar )
865      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
866      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
867      INTEGER         , INTENT(  out)                 ::   pvar      ! read field
868      !
869      IF( kiomid > 0 ) THEN
870         IF( iom_file(kiomid)%nfid > 0 ) THEN
871            SELECT CASE (iom_file(kiomid)%iolib)
872            CASE (jpioipsl )   ;   CALL ctl_stop('iom_getatt: only nf90 available')
873            CASE (jpnf90   )   ;   CALL iom_nf90_getatt( kiomid, cdatt, pvar )
874            CASE (jprstdimg)   ;   CALL ctl_stop('iom_getatt: only nf90 available')
875            CASE DEFAULT   
876               CALL ctl_stop( 'iom_g0d_att: accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
877            END SELECT
878         ENDIF
879      ENDIF
880   END SUBROUTINE iom_g0d_intatt
881
882
883   !!----------------------------------------------------------------------
884   !!                   INTERFACE iom_rstput
885   !!----------------------------------------------------------------------
886   SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype )
887      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
888      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
889      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file
890      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
891      REAL(wp)        , INTENT(in)                         ::   pvar     ! written field
892      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
893      INTEGER :: ivid   ! variable id
894      IF( kiomid > 0 ) THEN
895         IF( iom_file(kiomid)%nfid > 0 ) THEN
896            ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
897            SELECT CASE (iom_file(kiomid)%iolib)
898            CASE (jpioipsl )   ;   CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar )
899            CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar )
900            CASE (jprstdimg)   ;   IF( kt == kwrite )    CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pvar )
901            CASE DEFAULT     
902               CALL ctl_stop( 'iom_rp0d: accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
903            END SELECT
904         ENDIF
905      ENDIF
906   END SUBROUTINE iom_rp0d
907
908   SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype )
909      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
910      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
911      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file
912      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
913      REAL(wp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field
914      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
915      INTEGER :: ivid   ! variable id
916      IF( kiomid > 0 ) THEN
917         IF( iom_file(kiomid)%nfid > 0 ) THEN
918            ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
919            SELECT CASE (iom_file(kiomid)%iolib)
920            CASE (jpioipsl )   ;   CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar )
921            CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar )
922            CASE (jprstdimg)   ;   IF( kt == kwrite )    CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pv_r1d = pvar )
923            CASE DEFAULT     
924               CALL ctl_stop( 'iom_rp1d: accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
925            END SELECT
926         ENDIF
927      ENDIF
928   END SUBROUTINE iom_rp1d
929
930   SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype )
931      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
932      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
933      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file
934      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
935      REAL(wp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field
936      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
937      INTEGER :: ivid   ! variable id
938      IF( kiomid > 0 ) THEN
939         IF( iom_file(kiomid)%nfid > 0 ) THEN
940            ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
941            SELECT CASE (iom_file(kiomid)%iolib)
942            CASE (jpioipsl )   ;   CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar )
943            CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar )
944            CASE (jprstdimg)   ;   IF( kt == kwrite )   CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pv_r2d = pvar ) 
945            CASE DEFAULT     
946               CALL ctl_stop( 'iom_rp2d: accepted IO library are only jpioipsl, jpnf90 and jprstdimg' )
947            END SELECT
948         ENDIF
949      ENDIF
950   END SUBROUTINE iom_rp2d
951
952   SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype )
953      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
954      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
955      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file
956      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
957      REAL(wp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field
958      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
959      INTEGER :: ivid   ! variable id
960      IF( kiomid > 0 ) THEN
961         IF( iom_file(kiomid)%nfid > 0 ) THEN
962            ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
963            SELECT CASE (iom_file(kiomid)%iolib)
964            CASE (jpioipsl )   ;   CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar )
965            CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar )
966            CASE (jprstdimg)   ;   IF( kt == kwrite )   CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pv_r3d = pvar )
967            CASE DEFAULT     
968               CALL ctl_stop( 'iom_rp3d: accepted IO library are only jpioipsl and jprstdimg' )
969            END SELECT
970         ENDIF
971      ENDIF
972   END SUBROUTINE iom_rp3d
973
974
975   !!----------------------------------------------------------------------
976   !!                   INTERFACE iom_put
977   !!----------------------------------------------------------------------
978   SUBROUTINE iom_p0d( cdname, pfield0d )
979      CHARACTER(LEN=*), INTENT(in) ::   cdname
980      REAL(wp)        , INTENT(in) ::   pfield0d
981#if defined key_iomput
982      CALL xios_send_field(cdname, (/pfield0d/))
983#else
984      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings
985#endif
986   END SUBROUTINE iom_p0d
987
988   SUBROUTINE iom_p1d( cdname, pfield1d )
989      CHARACTER(LEN=*)          , INTENT(in) ::   cdname
990      REAL(wp),     DIMENSION(:), INTENT(in) ::   pfield1d
991#if defined key_iomput
992      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) )
993#else
994      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings
995#endif
996   END SUBROUTINE iom_p1d
997
998   SUBROUTINE iom_p2d( cdname, pfield2d )
999      CHARACTER(LEN=*)            , INTENT(in) ::   cdname
1000      REAL(wp),     DIMENSION(:,:), INTENT(in) ::   pfield2d
1001#if defined key_iomput
1002      CALL xios_send_field(cdname, pfield2d)
1003#else
1004      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings
1005#endif
1006   END SUBROUTINE iom_p2d
1007
1008   SUBROUTINE iom_p3d( cdname, pfield3d )
1009      CHARACTER(LEN=*)                , INTENT(in) ::   cdname
1010      REAL(wp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d
1011#if defined key_iomput
1012      CALL xios_send_field(cdname, pfield3d)
1013#else
1014      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings
1015#endif
1016   END SUBROUTINE iom_p3d
1017   !!----------------------------------------------------------------------
1018
1019#if defined key_iomput
1020
1021   SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj,   &
1022      &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask )
1023      CHARACTER(LEN=*)                 , INTENT(in) ::   cdid
1024      INTEGER                , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj
1025      INTEGER                , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj
1026      INTEGER                , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj
1027      REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) ::   lonvalue, latvalue
1028      LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) ::   mask
1029
1030      IF ( xios_is_valid_domain     (cdid) ) THEN
1031         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   &
1032            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   &
1033            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       &
1034            &    lonvalue=lonvalue, latvalue=latvalue,mask=mask )
1035      ENDIF
1036
1037      IF ( xios_is_valid_domaingroup(cdid) ) THEN
1038         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   &
1039            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   &
1040            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       &
1041            &    lonvalue=lonvalue, latvalue=latvalue,mask=mask )
1042      ENDIF
1043      CALL xios_solve_inheritance()
1044
1045   END SUBROUTINE iom_set_domain_attr
1046
1047
1048   SUBROUTINE iom_set_axis_attr( cdid, paxis )
1049      CHARACTER(LEN=*)      , INTENT(in) ::   cdid
1050      REAL(wp), DIMENSION(:), INTENT(in) ::   paxis
1051      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=size(paxis),value=paxis )
1052      IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis )
1053      CALL xios_solve_inheritance()
1054   END SUBROUTINE iom_set_axis_attr
1055
1056
1057   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset )
1058      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
1059      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op
1060      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset
1061      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset )
1062      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset )
1063      CALL xios_solve_inheritance()
1064   END SUBROUTINE iom_set_field_attr
1065
1066
1067   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix )
1068      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
1069      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   name, name_suffix
1070      IF ( xios_is_valid_file     (cdid) )   CALL xios_set_file_attr     ( cdid, name=name, name_suffix=name_suffix )
1071      IF ( xios_is_valid_filegroup(cdid) )   CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix )
1072      CALL xios_solve_inheritance()
1073   END SUBROUTINE iom_set_file_attr
1074
1075
1076   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq )
1077      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid
1078      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq
1079      LOGICAL                                 ::   llexist1,llexist2,llexist3
1080      !---------------------------------------------------------------------
1081      IF( PRESENT( name        ) )   name = ''          ! default values
1082      IF( PRESENT( name_suffix ) )   name_suffix = ''
1083      IF( PRESENT( output_freq ) )   output_freq = ''
1084      IF ( xios_is_valid_file     (cdid) ) THEN
1085         CALL xios_solve_inheritance()
1086         CALL xios_is_defined_file_attr     ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3)
1087         IF(llexist1)   CALL xios_get_file_attr     ( cdid, name = name )
1088         IF(llexist2)   CALL xios_get_file_attr     ( cdid, name_suffix = name_suffix )
1089         IF(llexist3)   CALL xios_get_file_attr     ( cdid, output_freq = output_freq )
1090      ENDIF
1091      IF ( xios_is_valid_filegroup(cdid) ) THEN
1092         CALL xios_solve_inheritance()
1093         CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3)
1094         IF(llexist1)   CALL xios_get_filegroup_attr( cdid, name = name )
1095         IF(llexist2)   CALL xios_get_filegroup_attr( cdid, name_suffix = name_suffix )
1096         IF(llexist3)   CALL xios_get_filegroup_attr( cdid, output_freq = output_freq )
1097      ENDIF
1098   END SUBROUTINE iom_get_file_attr
1099
1100
1101   SUBROUTINE iom_set_grid_attr( cdid, mask )
1102      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid
1103      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask
1104      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask )
1105      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask )
1106      CALL xios_solve_inheritance()
1107   END SUBROUTINE iom_set_grid_attr
1108
1109
1110   SUBROUTINE set_grid( cdgrd, plon, plat )
1111      !!----------------------------------------------------------------------
1112      !!                     ***  ROUTINE set_grid  ***
1113      !!
1114      !! ** Purpose :   define horizontal grids
1115      !!
1116      !!----------------------------------------------------------------------
1117      CHARACTER(LEN=1)            , INTENT(in) ::   cdgrd
1118      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plon
1119      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plat
1120      !
1121      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask
1122      INTEGER  :: ni,nj
1123     
1124      ni=nlei-nldi+1 ; nj=nlej-nldj+1
1125
1126      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj)
1127      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)
1128      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   &
1129         &                                     latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 
1130
1131      IF ( ln_mskland ) THEN
1132         ! mask land points, keep values on coast line -> specific mask for U, V and W points
1133         SELECT CASE ( cdgrd )
1134         CASE('T')   ;   zmask(:,:,:)       = tmask(:,:,:)
1135         CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( zmask, 'U', 1. )
1136         CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpi,:)   ;   CALL lbc_lnk( zmask, 'V', 1. )
1137         CASE('W')   ;   zmask(:,:,2:jpk  ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk)   ;   zmask(:,:,1) = tmask(:,:,1)
1138         END SELECT
1139         !
1140         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. )
1141         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )
1142      ENDIF
1143     
1144   END SUBROUTINE set_grid
1145
1146
1147   SUBROUTINE set_scalar
1148      !!----------------------------------------------------------------------
1149      !!                     ***  ROUTINE set_scalar  ***
1150      !!
1151      !! ** Purpose :   define fake grids for scalar point
1152      !!
1153      !!----------------------------------------------------------------------
1154      REAL(wp), DIMENSION(1,1) ::   zz = 1.
1155      !!----------------------------------------------------------------------
1156      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1)
1157      CALL iom_set_domain_attr('scalarpoint', data_dim=1)
1158      CALL iom_set_domain_attr('scalarpoint', lonvalue=(/ zz /), latvalue=(/ zz /))
1159
1160   END SUBROUTINE set_scalar
1161
1162
1163   SUBROUTINE set_xmlatt
1164      !!----------------------------------------------------------------------
1165      !!                     ***  ROUTINE set_xmlatt  ***
1166      !!
1167      !! ** Purpose :   automatic definitions of some of the xml attributs...
1168      !!
1169      !!----------------------------------------------------------------------
1170      CHARACTER(len=1),DIMENSION( 3) ::   clgrd                    ! suffix name
1171      CHARACTER(len=256)             ::   clsuff                   ! suffix name
1172      CHARACTER(len=1)               ::   cl1                      ! 1 character
1173      CHARACTER(len=2)               ::   cl2                      ! 1 character
1174      INTEGER                        ::   ji, jg                   ! loop counters
1175      INTEGER                        ::   ix, iy                   ! i-,j- index
1176      REAL(wp)        ,DIMENSION(11) ::   zlontao                  ! longitudes of tao    moorings
1177      REAL(wp)        ,DIMENSION( 7) ::   zlattao                  ! latitudes  of tao    moorings
1178      REAL(wp)        ,DIMENSION( 4) ::   zlonrama                 ! longitudes of rama   moorings
1179      REAL(wp)        ,DIMENSION(11) ::   zlatrama                 ! latitudes  of rama   moorings
1180      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings
1181      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings
1182      !!----------------------------------------------------------------------
1183      !
1184      ! frequency of the call of iom_put (attribut: freq_op)
1185      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts')
1186      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts')
1187      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts')
1188      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts')
1189       
1190      ! output file names (attribut: name)
1191      DO ji = 1, 9
1192         WRITE(cl1,'(i1)') ji 
1193         CALL iom_update_file_name('file'//cl1)
1194      END DO
1195      DO ji = 1, 99
1196         WRITE(cl2,'(i2.2)') ji 
1197         CALL iom_update_file_name('file'//cl2)
1198      END DO
1199
1200      ! Zooms...
1201      clgrd = (/ 'T', 'U', 'W' /) 
1202      DO jg = 1, SIZE(clgrd)                                                                   ! grid type
1203         cl1 = clgrd(jg)
1204         ! Equatorial section (attributs: jbegin, ni, name_suffix)
1205         CALL dom_ngb( 0., 0., ix, iy, cl1 )
1206         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo)
1207         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             )
1208         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq')
1209         CALL iom_update_file_name('Eq'//cl1)
1210      END DO
1211      ! TAO moorings (attributs: ibegin, jbegin, name_suffix)
1212      zlontao = (/ 137.0, 147.0, 156.0, 165.0, -180.0, -170.0, -155.0, -140.0, -125.0, -110.0, -95.0 /)
1213      zlattao = (/  -8.0,  -5.0,  -2.0,   0.0,    2.0,    5.0,    8.0 /)
1214      CALL set_mooring( zlontao, zlattao )
1215      ! RAMA moorings (attributs: ibegin, jbegin, name_suffix)
1216      zlonrama = (/  55.0,  67.0, 80.5, 90.0 /)
1217      zlatrama = (/ -16.0, -12.0, -8.0, -4.0, -1.5, 0.0, 1.5, 4.0, 8.0, 12.0, 15.0 /)
1218      CALL set_mooring( zlonrama, zlatrama )
1219      ! PIRATA moorings (attributs: ibegin, jbegin, name_suffix)
1220      zlonpira = (/ -38.0, -23.0, -10.0 /)
1221      zlatpira = (/ -19.0, -14.0,  -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /)
1222      CALL set_mooring( zlonpira, zlatpira )
1223     
1224   END SUBROUTINE set_xmlatt
1225
1226
1227   SUBROUTINE set_mooring( plon, plat)
1228      !!----------------------------------------------------------------------
1229      !!                     ***  ROUTINE set_mooring  ***
1230      !!
1231      !! ** Purpose :   automatic definitions of moorings xml attributs...
1232      !!
1233      !!----------------------------------------------------------------------
1234      REAL(wp), DIMENSION(:), INTENT(in) ::  plon, plat           ! longitudes/latitudes oft the mooring
1235      !
1236!!$      CHARACTER(len=1),DIMENSION(4) ::   clgrd = (/ 'T', 'U', 'V', 'W' /)   ! suffix name
1237      CHARACTER(len=1),DIMENSION(1) ::   clgrd = (/ 'T' /)        ! suffix name
1238      CHARACTER(len=256)            ::   clname                   ! file name
1239      CHARACTER(len=256)            ::   clsuff                   ! suffix name
1240      CHARACTER(len=1)              ::   cl1                      ! 1 character
1241      CHARACTER(len=6)              ::   clon,clat                ! name of longitude, latitude
1242      INTEGER                       ::   ji, jj, jg               ! loop counters
1243      INTEGER                       ::   ix, iy                   ! i-,j- index
1244      REAL(wp)                      ::   zlon, zlat
1245      !!----------------------------------------------------------------------
1246      DO jg = 1, SIZE(clgrd)
1247         cl1 = clgrd(jg)
1248         DO ji = 1, SIZE(plon)
1249            DO jj = 1, SIZE(plat)
1250               zlon = plon(ji)
1251               zlat = plat(jj)
1252               ! modifications for RAMA moorings
1253               IF( zlon ==  67. .AND. zlat ==  15. )   zlon =  65.
1254               IF( zlon ==  90. .AND. zlat <=  -4. )   zlon =  95.
1255               IF( zlon ==  95. .AND. zlat ==  -4. )   zlat =  -5.
1256               ! modifications for PIRATA moorings
1257               IF( zlon == -38. .AND. zlat == -19. )   zlon = -34.
1258               IF( zlon == -38. .AND. zlat == -14. )   zlon = -32.
1259               IF( zlon == -38. .AND. zlat ==  -8. )   zlon = -30.
1260               IF( zlon == -38. .AND. zlat ==   0. )   zlon = -35.
1261               IF( zlon == -23. .AND. zlat ==  20. )   zlat =  21.
1262               IF( zlon == -10. .AND. zlat == -14. )   zlat = -10.
1263               IF( zlon == -10. .AND. zlat ==  -8. )   zlat =  -6.
1264               IF( zlon == -10. .AND. zlat ==   4. ) THEN   ;   zlon = 0.   ;   zlat = 0.   ;   ENDIF
1265               CALL dom_ngb( zlon, zlat, ix, iy, cl1 )
1266               IF( zlon >= 0. ) THEN 
1267                  IF( zlon == REAL(NINT(zlon), wp) ) THEN   ;   WRITE(clon, '(i3,  a)') NINT( zlon), 'e'
1268                  ELSE                                      ;   WRITE(clon, '(f5.1,a)')       zlon , 'e'
1269                  ENDIF
1270               ELSE             
1271                  IF( zlon == REAL(NINT(zlon), wp) ) THEN   ;   WRITE(clon, '(i3,  a)') NINT(-zlon), 'w'
1272                  ELSE                                      ;   WRITE(clon, '(f5.1,a)')      -zlon , 'w'
1273                  ENDIF
1274               ENDIF
1275               IF( zlat >= 0. ) THEN 
1276                  IF( zlat == REAL(NINT(zlat), wp) ) THEN   ;   WRITE(clat, '(i2,  a)') NINT( zlat), 'n'
1277                  ELSE                                      ;   WRITE(clat, '(f4.1,a)')       zlat , 'n'
1278                  ENDIF
1279               ELSE             
1280                  IF( zlat == REAL(NINT(zlat), wp) ) THEN   ;   WRITE(clat, '(i2,  a)') NINT(-zlat), 's'
1281                  ELSE                                      ;   WRITE(clat, '(f4.1,a)')      -zlat , 's'
1282                  ENDIF
1283               ENDIF
1284               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon))
1285               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy)
1286               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         )
1287               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname))
1288               CALL iom_update_file_name(TRIM(clname)//cl1)
1289            END DO
1290         END DO
1291      END DO
1292     
1293   END SUBROUTINE set_mooring
1294
1295   
1296   SUBROUTINE iom_update_file_name( cdid )
1297      !!----------------------------------------------------------------------
1298      !!                     ***  ROUTINE iom_update_file_name  ***
1299      !!
1300      !! ** Purpose :   
1301      !!
1302      !!----------------------------------------------------------------------
1303      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
1304      !
1305      CHARACTER(LEN=256) ::   clname
1306      CHARACTER(LEN=20)  ::   clfreq
1307      CHARACTER(LEN=20)  ::   cldate
1308      INTEGER            ::   idx
1309      INTEGER            ::   jn
1310      INTEGER            ::   itrlen
1311      INTEGER            ::   iyear, imonth, iday, isec
1312      REAL(wp)           ::   zsec
1313      LOGICAL            ::   llexist
1314      !!----------------------------------------------------------------------
1315
1316      DO jn = 1,2
1317
1318         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq )
1319         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname )
1320
1321         IF ( TRIM(clname) /= '' ) THEN
1322
1323            idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@')
1324            DO WHILE ( idx /= 0 ) 
1325               clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname))
1326               idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@')
1327            END DO
1328
1329            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@')
1330            DO WHILE ( idx /= 0 ) 
1331               IF ( TRIM(clfreq) /= '' ) THEN
1332                  itrlen = LEN_TRIM(clfreq)
1333                  IF ( clfreq(itrlen-1:itrlen) == 'mo' ) clfreq = clfreq(1:itrlen-1)
1334                  clname = clname(1:idx-1)//TRIM(clfreq)//clname(idx+6:LEN_TRIM(clname))
1335               ELSE
1336                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   &
1337                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) )
1338               ENDIF
1339               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@')
1340            END DO
1341
1342            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@')
1343            DO WHILE ( idx /= 0 ) 
1344               cldate = iom_sdate( fjulday - rdttra(1) / rday )
1345               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname))
1346               idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@')
1347            END DO
1348
1349            idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@')
1350            DO WHILE ( idx /= 0 ) 
1351               cldate = iom_sdate( fjulday - rdttra(1) / rday, ldfull = .TRUE. )
1352               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname))
1353               idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@')
1354            END DO
1355
1356            idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@')
1357            DO WHILE ( idx /= 0 ) 
1358               cldate = iom_sdate( fjulday + rdttra(1) / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. )
1359               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname))
1360               idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@')
1361            END DO
1362
1363            idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@')
1364            DO WHILE ( idx /= 0 ) 
1365               cldate = iom_sdate( fjulday + rdttra(1) / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. )
1366               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname))
1367               idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@')
1368            END DO
1369
1370            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname )
1371            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname )
1372
1373         ENDIF
1374
1375      END DO
1376
1377   END SUBROUTINE iom_update_file_name
1378
1379
1380   FUNCTION iom_sdate( pjday, ld24, ldfull )
1381      !!----------------------------------------------------------------------
1382      !!                     ***  ROUTINE iom_sdate  ***
1383      !!
1384      !! ** Purpose :   send back the date corresponding to the given julian day
1385      !!
1386      !!----------------------------------------------------------------------
1387      REAL(wp), INTENT(in   )           ::   pjday         ! julian day
1388      LOGICAL , INTENT(in   ), OPTIONAL ::   ld24          ! true to force 24:00 instead of 00:00
1389      LOGICAL , INTENT(in   ), OPTIONAL ::   ldfull        ! true to get the compleate date: yyyymmdd_hh:mm:ss
1390      !
1391      CHARACTER(LEN=20) ::   iom_sdate
1392      CHARACTER(LEN=50) ::   clfmt                         !  format used to write the date
1393      INTEGER           ::   iyear, imonth, iday, ihour, iminute, isec
1394      REAL(wp)          ::   zsec
1395      LOGICAL           ::   ll24, llfull
1396      !
1397      IF( PRESENT(ld24) ) THEN   ;   ll24 = ld24
1398      ELSE                       ;   ll24 = .FALSE.
1399      ENDIF
1400
1401      IF( PRESENT(ldfull) ) THEN   ;   llfull = ldfull
1402      ELSE                         ;   llfull = .FALSE.
1403      ENDIF
1404
1405      CALL ju2ymds( pjday, iyear, imonth, iday, zsec )
1406      isec = NINT(zsec)
1407
1408      IF ( ll24 .AND. isec == 0 ) THEN   ! 00:00 of the next day -> move to 24:00 of the current day
1409         CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec )
1410         isec = 86400
1411      ENDIF
1412
1413      IF( iyear < 10000 ) THEN   ;   clfmt = "i4.4,2i2.2"                ! format used to write the date
1414      ELSE                       ;   WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1
1415      ENDIF
1416     
1417      IF( llfull ) THEN
1418         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2"
1419         ihour   = isec / 3600
1420         isec    = MOD(isec, 3600)
1421         iminute = isec / 60
1422         isec    = MOD(isec, 60)
1423         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec    ! date of the end of run
1424      ELSE
1425         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run
1426      ENDIF
1427
1428   END FUNCTION iom_sdate
1429
1430#else
1431
1432   SUBROUTINE iom_setkt( kt )
1433      INTEGER, INTENT(in   )::   kt 
1434      IF( .FALSE. )   WRITE(numout,*) kt   ! useless test to avoid compilation warnings
1435   END SUBROUTINE iom_setkt
1436
1437#endif
1438   
1439   !!======================================================================
1440END MODULE iom
Note: See TracBrowser for help on using the repository browser.