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 @ 3971

Last change on this file since 3971 was 3971, checked in by cbricaud, 11 years ago

Correction for 1D configuration ; see ticket #1096

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