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

Context Navigation

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

Last change on this file since 4473 was 4473, checked in by trackstand2, 10 years ago
Bug fix in iom.F90 to use jpkorig instead of jpk when creating tmp array to swap z-ordering prior to write
Property svn:keywords set to `Id`
File size: 70.2 KB

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

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

Download in other formats: