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

Context Navigation

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

Last change on this file since 3983 was 3983, checked in by acc, 11 years ago
Update xml files with missing iceberg (ICB) variables and add new axis definition to iom.F90. The latter requires changes in icb modules to avoid a cyclic dependency
Property svn:keywords set to `Id`
File size: 74.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: