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 branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 13 years ago

Stephen Pickles, 11 Dec 2011

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