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/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/iom.F90 @ 478

Last change on this file since 478 was 478, checked in by opalod, 18 years ago
nemo_v1_bugfix_046 : SM + CT : add lines when using AGRIF tool and iom module
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 35.3 KB

Line
1	MODULE iom
2	!!=====================================================================
3	!! * MODULE iom *
4	!!
5	!! Input/Output manager : Library to read input files
6	!!
7	!! Ongoing work : This code is here to help discussions about I/O
8	!! library in the NEMO system
9	!!====================================================================
10	!!--------------------------------------------------------------------
11	!! iom_open : open a file read only
12	!! iom_close : close a file or all files opened by iom
13	!! iom_get : read a field : interface to several routines
14	!! iom_varid : get the id of a variable in a file
15	!! iom_get_gblatt : ???
16	!!--------------------------------------------------------------------
17	!! History : 9.0 ! 05 12 (J. Belier) Original code
18	!! 9.0 ! 06 02 (S. Masson) Adaptation to NEMO
19	!!--------------------------------------------------------------------
20	!! * Modules used
21	USE in_out_manager ! I/O manager
22	USE dom_oce ! ocean space and time domain
23	USE lbclnk ! ???
24	USE ioipsl ! ???
25
26	IMPLICIT NONE
27	PRIVATE
28
29	PUBLIC :: iom_open, iom_close, iom_get, iom_varid, iom_get_gblatt
30
31	!! * Interfaces
32	INTERFACE iom_get
33	MODULE PROCEDURE iom_get_r_1d, iom_get_r_2d, iom_get_r_3d
34	END INTERFACE
35
36	!! * Share module variables
37	INTEGER, PARAMETER, PUBLIC :: & !:
38	jpdom_data = 1, & !: ( 1 :jpidta, 1 :jpjdta)
39	jpdom_global = 2, & !: ( 1 :jpiglo, 1 :jpjglo)
40	jpdom_local = 3, & !: One of the 3 following cases
41	jpdom_local_full = 4, & !: ( 1 :jpi , 1 :jpi )
42	jpdom_local_noextra = 5, & !: ( 1 :nlci , 1 :nlcj )
43	jpdom_local_noovlap = 6, & !: (nldi:nlei ,nldj:nlej )
44	jpdom_unknown = 7 !: No dimension checking
45
46	!! * Module variables
47	INTEGER, PARAMETER :: &
48	jpmax_vars = 50, & ! maximum number of variables in one file
49	jpmax_dims = 5, & ! maximum number of dimensions for one variable
50	jpmax_digits = 5 ! maximum number of digits in the file name to reference the cpu number
51
52	!$AGRIF_DO_NOT_TREAT
53	INTEGER :: iom_init = 0
54
55	TYPE :: flio_file
56	CHARACTER(LEN=240) :: name ! name of the file
57	INTEGER :: iopen ! 1/0 is the file is open/not open
58	INTEGER :: nvars ! number of identified varibles in the file
59	INTEGER :: iduld ! id of the unlimited dimension
60	CHARACTER(LEN=16), DIMENSION(jpmax_vars) :: cn_var ! names of the variables
61	INTEGER, DIMENSION(jpmax_vars) :: ndims ! number of dimensions of the variables
62	LOGICAL, DIMENSION(jpmax_vars) :: luld ! variable including unlimited dimension
63	INTEGER, DIMENSION(jpmax_dims,jpmax_vars) :: dimsz ! size of the dimensions of the variables
64	REAL(kind=wp), DIMENSION(jpmax_vars) :: scf ! scale_factor of the variables
65	REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs ! add_offset of the variables
66	END TYPE flio_file
67	TYPE(flio_file), DIMENSION(flio_max_files) :: iom_file ! array containing the info for all opened files
68	!$AGRIF_END_DO_NOT_TREAT
69
70	!!----------------------------------------------------------------------
71	!! OPA 9.0 , LOCEAN-IPSL (2006)
72	!! $Header$
73	!! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
74	!!----------------------------------------------------------------------
75
76	CONTAINS
77
78	SUBROUTINE iom_open( cdname, knumfl, ldimg )
79	!!---------------------------------------------------------------------
80	!! * SUBROUTINE iom_open *
81	!!
82	!! ** Purpose : open an input file read only (return 0 if not found)
83	!!
84	!! ** Method :
85	!!
86	!!---------------------------------------------------------------------
87	CHARACTER(len=*), INTENT(in ) :: cdname ! File name
88	INTEGER, INTENT(out) :: knumfl ! Identifier of the opened file
89	LOGICAL, INTENT(in ), OPTIONAL :: ldimg ! flg to specify that we use dimg format
90
91	CHARACTER(LEN=100) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu]
92	CHARACTER(LEN=10) :: clsuffix ! ".nc" or ".dimg"
93	CHARACTER(LEN=10) :: clcpu ! the cpu number (max jpmax_digits digits)
94	LOGICAL :: llok ! check the existence
95	INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits)
96	!---------------------------------------------------------------------
97
98	! find the file
99	! =============
100	clname = trim(cdname)
101	#if defined key_agrif
102	if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
103	#endif
104	clsuffix = ".nc"
105	IF( PRESENT(ldimg) ) THEN
106	IF ( ldimg ) clsuffix = ".dimg"
107	ENDIF
108	!
109	INQUIRE( FILE = clname, EXIST = llok )
110	IF( .NOT.llok ) THEN ! try to complete the name with the suffix only
111	clname = TRIM(cdname)//TRIM(clsuffix)
112	#if defined key_agrif
113	if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
114	#endif
115	INQUIRE( FILE = clname, EXIST = llok )
116	IF( .NOT.llok ) THEN ! try to complete the name with both cpu number and suffix
117	WRITE(clcpu,*) narea-1
118	clcpu = trim(adjustl(clcpu))
119	clname = trim(cdname)//"_"
120	#if defined key_agrif
121	if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
122	#endif
123	icnt = 0
124	INQUIRE( FILE = trim(clname)//trim(clcpu)//trim(clsuffix), EXIST = llok )
125	DO WHILE( .NOT.llok .AND. icnt < jpmax_digits ) ! we try fifferent formats for the cpu number by adding 0
126	clname = trim(clname)//"0"
127	INQUIRE( FILE = trim(clname)//trim(clcpu)//trim(clsuffix), EXIST = llok )
128	icnt = icnt + 1
129	END DO
130	IF( .NOT.llok ) THEN ! no way to find the files...
131	CALL ctl_stop( 'iom_open: file '//trim(clname)//'... not found' )
132	ENDIF
133	clname = trim(clname)//trim(clcpu)//trim(clsuffix)
134	ENDIF
135	ENDIF
136
137	! Open the file
138	! =============
139	IF( llok ) THEN
140	IF (lwp) WRITE(numout,*) 'iom_open ~~~ open file: '//trim(clname)
141	CALL flioopfd( trim(clname), knumfl )
142	IF( iom_init == 0 ) THEN
143	iom_file(:)%iopen = 0
144	iom_init = 1
145	ENDIF
146	iom_file(knumfl)%iopen = 1
147	iom_file(knumfl)%name = TRIM(clname)
148	iom_file(knumfl)%nvars = 0
149	iom_file(knumfl)%ndims(:) = 0
150	iom_file(knumfl)%luld(:) = .FALSE.
151	iom_file(knumfl)%dimsz(:,:) = 0
152	! does the file contain time axis (that must be unlimitted) ?
153	CALL flioinqf( knumfl, id_uld = iom_file(knumfl)%iduld )
154	ELSE
155	knumfl = 0
156	ENDIF
157
158	END SUBROUTINE iom_open
159
160
161	SUBROUTINE iom_close( knumfl )
162	!!--------------------------------------------------------------------
163	!! * SUBROUTINE iom_close *
164	!!
165	!! ** Purpose : close an input file, or all files opened by iom
166	!!
167	!! ** Method :
168	!!
169	!!--------------------------------------------------------------------
170	INTEGER,INTENT(in), OPTIONAL :: knumfl ! Identifier of the file to be closed
171	! ! If this argument is not present,
172	! ! all the files opened by iom are closed.
173
174	INTEGER :: jf ! dummy loop indices
175	INTEGER :: i_s, i_e ! temporary integer
176	!---------------------------------------------------------------------
177
178	IF( PRESENT(knumfl) ) THEN
179	i_s = knumfl
180	i_e = knumfl
181	ELSE
182	i_s = 1
183	i_e = flio_max_files
184	ENDIF
185	IF ( i_s > 0 ) THEN
186	DO jf = i_s, i_e
187	IF( iom_file(jf)%iopen > 0 ) THEN
188	CALL flioclo( jf )
189	iom_file(jf)%iopen = 0
190	iom_file(jf)%name = 'NONE'
191	iom_file(jf)%nvars = 0
192	iom_file(jf)%iduld = 0
193	iom_file(jf)%ndims(:) = 0
194	iom_file(jf)%luld(:) = .FALSE.
195	iom_file(jf)%dimsz(:,:) = 0
196	ELSEIF( PRESENT(knumfl) ) THEN
197	WRITE(ctmp1,*) '--->', knumfl
198	CALL ctl_stop( 'iom_close: Invalid file identifier', ctmp1 )
199	ENDIF
200	END DO
201	ENDIF
202
203	END SUBROUTINE iom_close
204
205
206	!!----------------------------------------------------------------------
207	!! INTERFACE iom_u_getv
208	!!----------------------------------------------------------------------
209	SUBROUTINE iom_get_r_1d( knumfl, kdom , cdvar , pvar , &
210	& ktime, kstart, kcount )
211	INTEGER , INTENT(in ) :: knumfl ! Identifier of the file
212	INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
213	CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable
214	REAL(wp), DIMENSION(:), INTENT(out) :: pvar ! read field
215	INTEGER , INTENT(in ) ,OPTIONAL :: ktime ! record number
216	INTEGER , DIMENSION(:), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
217	INTEGER , DIMENSION(:), INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis
218	!
219	CHARACTER(LEN=100) :: clinfo ! info character
220	!
221	clinfo = 'iom_get_r_1d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
222	IF( PRESENT(kstart) ) THEN
223	IF ( SIZE(kstart) /= 1 ) CALL ctl_stop( trim(clinfo), 'kstart must be a 1 element vector' )
224	ENDIF
225	IF( PRESENT(kcount) ) THEN
226	IF ( SIZE(kcount) /= 1 ) CALL ctl_stop( trim(clinfo), 'kcount must be a 1 element vector' )
227	ENDIF
228	IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom , cdvar , pv_r1d=pvar, &
229	& ktime=ktime, kstart=kstart, kcount=kcount )
230	END SUBROUTINE iom_get_r_1d
231	SUBROUTINE iom_get_r_2d( knumfl, kdom , cdvar , pvar , &
232	& ktime, kstart, kcount )
233	INTEGER,INTENT(in) :: knumfl
234	INTEGER,INTENT(in) :: kdom
235	CHARACTER(len=*),INTENT(in) :: cdvar
236	REAL(wp),INTENT(out),DIMENSION(:,:) :: pvar
237	INTEGER,INTENT(in),OPTIONAL :: ktime
238	INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kstart
239	INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kcount
240	!
241	CHARACTER(LEN=100) :: clinfo ! info character
242	!
243	clinfo = 'iom_get_r_2d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
244	IF( PRESENT(kstart) ) THEN
245	IF ( size(kstart) /= 2 ) CALL ctl_stop(trim(clinfo), 'kstart must be a 2 element vector')
246	ENDIF
247	IF( PRESENT(kcount) ) THEN
248	IF ( size(kcount) /= 2 ) CALL ctl_stop(trim(clinfo), 'kcount must be a 2 element vector')
249	ENDIF
250	IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom , cdvar , pv_r2d=pvar, &
251	& ktime=ktime, kstart=kstart, kcount=kcount )
252	END SUBROUTINE iom_get_r_2d
253	SUBROUTINE iom_get_r_3d( knumfl, kdom , cdvar , pvar , &
254	& ktime, kstart, kcount )
255	INTEGER,INTENT(in) :: knumfl
256	INTEGER,INTENT(in) :: kdom
257	CHARACTER(len=*),INTENT(in) :: cdvar
258	REAL(wp),INTENT(out),DIMENSION(:,:,:) :: pvar
259	INTEGER,INTENT(in),OPTIONAL :: ktime
260	INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kstart
261	INTEGER,DIMENSION(:),INTENT(in),OPTIONAL :: kcount
262	!
263	CHARACTER(LEN=100) :: clinfo ! info character
264	!
265	clinfo = 'iom_get_r_3d, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
266	IF ( PRESENT(kstart) ) THEN
267	IF ( size(kstart) /= 3 ) CALL ctl_stop(trim(clinfo), 'kstart must be a 3 element vector')
268	ENDIF
269	IF ( PRESENT(kcount) ) THEN
270	IF ( size(kcount) /= 3 ) CALL ctl_stop(trim(clinfo), 'kcount must be a 3 element vector')
271	ENDIF
272	IF ( knumfl > 0 ) CALL iom_u_getv( knumfl, kdom , cdvar , pv_r3d=pvar, &
273	& ktime=ktime, kstart=kstart, kcount=kcount )
274	END SUBROUTINE iom_get_r_3d
275	!!----------------------------------------------------------------------
276
277
278	SUBROUTINE iom_u_getv( knumfl, kdom , cdvar , &
279	& pv_r1d, pv_r2d, pv_r3d, &
280	& ktime , kstart, kcount )
281	!!-----------------------------------------------------------------------
282	!! * ROUTINE iom_u_getv *
283	!!
284	!! ** Purpose : read a 1D/2D/3D variable
285	!!
286	!! ** Method : read ONE time step at each CALL
287	!!
288	!!-----------------------------------------------------------------------
289	INTEGER, INTENT(in ) :: knumfl ! Identifier of the file
290	INTEGER, INTENT(in ) :: kdom ! Type of domain to be read
291	CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
292	REAL(wp), DIMENSION(:) , INTENT(out), OPTIONAL :: pv_r1d ! read field (1D case)
293	REAL(wp), DIMENSION(:,:) , INTENT(out), OPTIONAL :: pv_r2d ! read field (2D case)
294	REAL(wp), DIMENSION(:,:,:) , INTENT(out), OPTIONAL :: pv_r3d ! read field (3D case)
295	INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number
296	INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
297	INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis
298
299	INTEGER :: jl ! loop on number of dimension
300	INTEGER :: idom, & ! type of domain
301	& idvar, & ! id of the variable
302	& inbdim, & ! number of dimensions of the variable
303	& idmspc, & ! number of spatial dimensions
304	& itime, & ! record number
305	& istop ! temporary value of nstop
306	INTEGER, DIMENSION(jpmax_dims) :: istart, & ! starting point to read for each axis
307	& icnt, & ! number of value to read along each axis
308	& idimsz ! size of the dimensions of the variable
309	REAL(wp) :: zscf, zofs ! sacle_factor and add_offset
310	INTEGER :: itmp ! temporary integer
311	CHARACTER(LEN=100) :: clinfo ! info character
312	!---------------------------------------------------------------------
313	clinfo = 'iom_u_getv, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
314	! local definition of the domain ?
315	idom = kdom
316	! check kcount and kstart optionals parameters...
317	IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) &
318	CALL ctl_stop( trim(clinfo), 'kcount present needs kstart present' )
319	IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) &
320	CALL ctl_stop( trim(clinfo), 'kstart present needs kcount present' )
321	IF( PRESENT(kstart) .AND. idom /= jpdom_unknown ) &
322	CALL ctl_stop( trim(clinfo), 'kstart present needs kdom = jpdom_unknown' )
323
324	! Search for the variable in the data base (eventually actualize data)
325	!-
326	istop = nstop
327	idvar = iom_varid( knumfl, cdvar )
328	!
329	IF ( idvar > 0 ) THEN
330	! to write iom_file(knumfl)%dimsz in a shorter way !
331	idimsz(:) = iom_file(knumfl)%dimsz(:, idvar)
332	inbdim = iom_file(knumfl)%ndims(idvar)! number of dimensions in the file
333	idmspc = inbdim ! number of spatial dimensions in the file
334	IF( iom_file(knumfl)%luld(idvar) ) idmspc = inbdim - 1
335	IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions', &
336	& 'this case is not coded...')
337	! Identify the domain in case of jpdom_local definition
338	!-
339	IF( idom == jpdom_local ) THEN
340	IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
341	idom = jpdom_local_full
342	ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN
343	idom = jpdom_local_noextra
344	ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN
345	idom = jpdom_local_noovlap
346	ELSE
347	CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )
348	ENDIF
349	ENDIF
350
351	! definition of istart and icnt
352	!-
353	! initializations
354	istart(:) = 1
355	icnt(:) = 1
356	itime = 1
357	IF( PRESENT(ktime) ) itime = ktime
358	!
359	IF( PRESENT(pv_r1d) ) THEN
360	IF( idmspc == 1 ) THEN
361	! data is 1d array (+ maybe a temporal dimension)
362	IF( PRESENT(kstart) ) THEN
363	istart(1:2) = (/ kstart(1), itime /)
364	icnt(1) = kcount(1)
365	ELSE
366	IF( kdom == jpdom_unknown ) THEN
367	istart(2) = itime
368	icnt(1) = idimsz(1)
369	ELSE
370	CALL ctl_stop( trim(clinfo), 'case not coded...You must use jpdom_unknown' )
371	ENDIF
372	ENDIF
373	ELSE
374	CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 1D array,', &
375	& 'we do not accept data with more than 1 spatial dimension', &
376	& 'Use ncwa -a to suppress the unnecessary dimensions')
377	ENDIF
378	ELSEIF( PRESENT(pv_r2d) ) THEN
379	SELECT CASE (idmspc)
380	CASE (1)
381	CALL ctl_stop( trim(clinfo), 'the file has only 1 spatial dimension', &
382	& 'it is impossible to read a 2d array from this file...')
383	CASE (2)
384	! data is 2d array (+ maybe a temporal dimension)
385	IF ( PRESENT(kstart) ) THEN
386	istart(1:3) = (/ kstart(1:2), itime /)
387	icnt(1:2) = kcount(1:2)
388	ELSE
389	IF( kdom == jpdom_unknown ) THEN
390	istart(3) = itime
391	icnt(1:2) = idimsz(1:2)
392	ELSE
393	IF( idom == jpdom_data ) THEN
394	istart(1:3) = (/ mig(1), mjg(1), itime /)
395	ELSEIF( idom == jpdom_global ) THEN
396	istart(1:3) = (/ nimpp, njmpp, itime /)
397	ENDIF
398	! we do not read the overlap -> we start to read at nldi, nldj
399	IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
400	! we do not read the overlap and the extra-halos
401	! -> from nldi to nlei and from nldj to nlej
402	icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
403	ENDIF
404	ENDIF
405	CASE DEFAULT
406	IF ( itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN
407	CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...', &
408	& 'As the size of the z dimension is 1 and as we try to read the first reacord, ', &
409	& 'we accept this case even if there is a possible mix-up between z and time dimension...')
410	IF ( PRESENT(kstart) ) THEN
411	istart(1:2) = kstart(1:2)
412	icnt(1:2) = kcount(1:2)
413	ELSE
414	IF( kdom == jpdom_unknown ) THEN
415	icnt(1:2) = idimsz(1:2)
416	ELSE
417	IF( idom == jpdom_data ) THEN
418	istart(1:2) = (/ mig(1), mjg(1) /)
419	ELSEIF( idom == jpdom_global ) THEN
420	istart(1:2) = (/ nimpp, njmpp /)
421	ENDIF
422	! we do not read the overlap -> we start to read at nldi, nldj
423	IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
424	! we do not read the overlap and the extra-halos
425	! -> from nldi to nlei and from nldj to nlej
426	icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
427	ENDIF
428	ENDIF
429	ELSE
430	CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 2D array,', &
431	& 'we do not accept data with more than 2 spatial dimension', &
432	& 'Use ncwa -a to suppress the unnecessary dimensions')
433	ENDIF
434	END SELECT
435	ELSEIF( PRESENT(pv_r3d) ) THEN
436	SELECT CASE (idmspc)
437	CASE (1)
438	CALL ctl_stop(trim(clinfo), 'the file has only 1 spatial dimension', &
439	& 'it is impossible to read a 3d array from this file...')
440	CASE (2)
441	CALL ctl_stop(trim(clinfo), 'the file has only 2 spatial dimension', &
442	& 'it is impossible to read a 3d array from this file...')
443	CASE (3)
444	! data is 3d array (+ maybe a temporal dimension)
445	IF( PRESENT(kstart) ) THEN
446	istart(1:4) = (/ kstart(1:3), itime /)
447	icnt(1:3) = kcount(1:3)
448	ELSE
449	IF( kdom == jpdom_unknown ) THEN
450	istart(4) = itime
451	icnt(1:3) = idimsz(1:3)
452	ELSE
453	IF( idom == jpdom_data ) THEN
454	istart(1:4) = (/ mig(1), mjg(1), 1, itime /)
455	ELSEIF( idom == jpdom_global ) THEN
456	istart(1:4) = (/ nimpp, njmpp, 1, itime /)
457	ENDIF
458	! we do not read the overlap -> we start to read at nldi, nldj
459	IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
460	! we do not read the overlap and the extra-halos
461	! -> from nldi to nlei and from nldj to nlej
462	icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
463	IF( idom == jpdom_data ) THEN
464	icnt(3) = jpkdta
465	ELSE
466	icnt(3) = jpk
467	ENDIF
468	ENDIF
469	ENDIF
470	CASE DEFAULT
471	CALL ctl_stop( trim(clinfo), 'to keep iom lisibility, when reading a 3D array,', &
472	& 'we do not accept data with more than 3 spatial dimension', &
473	& 'Use ncwa -a to suppress the unnecessary dimensions')
474	END SELECT
475	ENDIF
476
477	! check that istart and icnt can be used with this file
478	!-
479	DO jl = 1, jpmax_dims
480	itmp = istart(jl)+icnt(jl)-1
481	IF( (itmp) > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN
482	WRITE(ctmp1,*) '(istart(',jl,') + icnt(',jl,') - 1) = ', itmp
483	WRITE(ctmp2,*) ' is larger than idimsz(',jl,'): ', idimsz(jl)
484	CALL ctl_stop( trim(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 )
485	ENDIF
486	END DO
487
488	! check that istart and icnt match the input array
489	!-
490	IF( PRESENT(pv_r1d) ) THEN
491	itmp = size(pv_r1d)
492	WRITE(ctmp1,*) 'size(pv_r1d): ', itmp, ' /= icnt(1): ', icnt(1)
493	IF( itmp /= icnt(1) ) CALL ctl_stop( trim(clinfo), ctmp1 )
494	ELSEIF( PRESENT(pv_r2d) ) THEN
495	DO jl = 1, 2
496	IF( idom == jpdom_unknown ) THEN
497	itmp = size(pv_r2d, jl)
498	WRITE(ctmp1,*) 'size(pv_r2d, ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
499	ELSE
500	itmp = size(pv_r2d(nldi:nlei,nldj:nlej), jl)
501	WRITE(ctmp1,*) 'size(pv_r2d(nldi:nlei,nldj:nlej), ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
502	ENDIF
503	IF( itmp /= icnt(jl) ) CALL ctl_stop( trim(clinfo), ctmp1 )
504	END DO
505	ELSEIF( PRESENT(pv_r3d) ) THEN
506	DO jl = 1, 3
507	IF( idom == jpdom_unknown ) THEN
508	itmp = size(pv_r3d, jl)
509	WRITE(ctmp1,*) 'size(pv_r3d, ',jl,'): ',itmp,' /= icnt(',jl,'):', icnt(jl)
510	ELSE
511	itmp = size(pv_r3d(nldi:nlei,nldj:nlej,:), jl)
512	WRITE(ctmp1,*) 'size(pv_r3d(nldi:nlei,nldj:nlej), ',jl,'): ',itmp,' /= icnt(',jl,'): ',icnt(jl)
513	ENDIF
514	IF( itmp /= icnt(jl) ) CALL ctl_stop( trim(clinfo), ctmp1 )
515	END DO
516	ENDIF
517	ENDIF
518
519	! read the data
520	!-
521	IF( istop == nstop) THEN ! no additional errors until this point...
522	!
523	istop = nstop
524	!
525	zscf = iom_file(knumfl)%scf(idvar) ! scale factor
526	zofs = iom_file(knumfl)%ofs(idvar) ! offset
527	!
528	IF( PRESENT(pv_r1d) ) THEN
529	CALL fliogetv( knumfl, cdvar, pv_r1d(:), start=istart(1:inbdim), count=icnt(1:inbdim) )
530	!--- Apply scale_factor and offset
531	IF( zscf /= 1. ) pv_r1d(:) = pv_r1d(:) * zscf
532	IF( zofs /= 0. ) pv_r1d(:) = pv_r1d(:) + zofs
533	ELSEIF( PRESENT(pv_r2d) ) THEN
534	IF( idom /= jpdom_unknown ) THEN
535	CALL fliogetv( knumfl, cdvar, pv_r2d(nldi:nlei,nldj:nlej), start=istart(1:inbdim), count=icnt(1:inbdim) )
536	!--- Apply scale_factor and offset
537	IF (zscf /= 1.) pv_r2d(nldi:nlei, nldj:nlej) = pv_r2d(nldi:nlei,nldj:nlej) * zscf
538	IF (zofs /= 0.) pv_r2d(nldi:nlei, nldj:nlej) = pv_r2d(nldi:nlei,nldj:nlej) + zofs
539	!--- Fill the overlap areas and extra hallows (mpp)
540	CALL lbc_lnk (pv_r2d,'Z',-999.,'no0')
541	ELSE
542	CALL fliogetv( knumfl, cdvar, pv_r2d(:,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
543	!--- Apply scale_factor and offset
544	IF (zscf /= 1.) pv_r2d(:,:) = pv_r2d(:,:) * zscf
545	IF (zofs /= 0.) pv_r2d(:,:) = pv_r2d(:,:) + zofs
546	ENDIF
547	ELSEIF( PRESENT(pv_r3d) ) THEN
548	IF( idom /= jpdom_unknown ) THEN
549	CALL fliogetv( knumfl, cdvar, pv_r3d(nldi:nlei,nldj:nlej,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
550	!--- Apply scale_factor and offset
551	IF( zscf /= 1. ) pv_r3d(nldi:nlei,nldj:nlej,:) = pv_r3d(nldi:nlei,nldj:nlej,:) * zscf
552	IF( zofs /= 0. ) pv_r3d(nldi:nlei,nldj:nlej,:) = pv_r3d(nldi:nlei,nldj:nlej,:) + zofs
553	!--- Fill the overlap areas and extra hallows (mpp)
554	IF( jpk == jpkdta ) CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) ! this if could be removed with the new lbc_lnk ...
555	ELSE
556	CALL fliogetv( knumfl, cdvar, pv_r3d(:,:,:), start=istart(1:inbdim), count=icnt(1:inbdim) )
557	!--- Apply scale_factor and offset
558	IF (zscf /= 1.) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf
559	IF (zofs /= 0.) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs
560	ENDIF
561	ENDIF
562	!
563	IF( istop == nstop .AND. lwp ) &
564	& WRITE(numout,*) ' read '//trim(cdvar)//' in '//trim(iom_file(knumfl)%name)//' ok'
565	ENDIF
566	!
567	END SUBROUTINE iom_u_getv
568
569
570	SUBROUTINE iom_gettime( knumfl, cdvar, ptime )
571	!!--------------------------------------------------------------------
572	!! * SUBROUTINE iom_close *
573	!!
574	!! ** Purpose : read the time axis cdvar in the file
575	!!
576	!! ** Method :
577	!!
578	!!--------------------------------------------------------------------
579	INTEGER , INTENT(in) :: knumfl ! Identifier of the file to be closed
580	CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name
581	REAL(wp), DIMENSION(:), INTENT(out) :: ptime ! the time axis
582
583	INTEGER :: idvar ! id of the variable
584	CHARACTER(LEN=100) :: clinfo ! info character
585	!---------------------------------------------------------------------
586	clinfo = 'iom_gettime, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
587	idvar = iom_varid( knumfl, cdvar )
588	!
589	ptime(:) = 0. ! default definition
590	IF ( idvar > 0 ) THEN
591	IF ( iom_file(knumfl)%ndims(idvar) == 1 ) THEN
592	IF ( iom_file(knumfl)%luld(idvar) ) THEN
593	IF ( iom_file(knumfl)%dimsz(1,idvar) == size(ptime) ) THEN
594	CALL fliogetv( knumfl, cdvar, ptime(:), start=(/ 1 /), &
595	& count=(/ iom_file(knumfl)%dimsz(1,idvar) /) )
596	ELSE
597	WRITE(ctmp1,*) 'error with the size of ptime ',size(ptime),iom_file(knumfl)%dimsz(1,idvar)
598	CALL ctl_stop( trim(clinfo), trim(ctmp1) )
599	ENDIF
600	ELSE
601	CALL ctl_stop( trim(clinfo), 'variable dimension is not unlimited... use iom_get' )
602	ENDIF
603	ELSE
604	CALL ctl_stop( trim(clinfo), 'the variable has more than 1 dimension' )
605	ENDIF
606	ELSE
607	CALL ctl_stop( trim(clinfo), 'variable not found in '//iom_file(knumfl)%name )
608	ENDIF
609
610	END SUBROUTINE iom_gettime
611
612
613
614	FUNCTION iom_varid ( knumfl, cdvar, kdimsz )
615	!!-----------------------------------------------------------------------
616	!! * FUNCTION iom_varid *
617	!!
618	!! ** Purpose : get the id of a variable in a file (return 0 if not found)
619	!!
620	!! ** Method : ???
621	!!
622	!!-----------------------------------------------------------------------
623	INTEGER , INTENT(in) :: knumfl ! file Identifier
624	CHARACTER(len=*) , INTENT(in) :: cdvar ! name of the variable
625	INTEGER, DIMENSION(:), INTENT(out), OPTIONAL :: kdimsz ! size of the dimensions
626	!
627	INTEGER :: iom_varid, idvar, i_nvd, ji
628	INTEGER, DIMENSION(jpmax_dims) :: idimid
629	LOGICAL :: ll_fnd
630	CHARACTER(LEN=100) :: clinfo ! info character
631	!!-----------------------------------------------------------------------
632	clinfo = 'iom_varid, file: '//trim(iom_file(knumfl)%name)//', var: '//trim(cdvar)
633	iom_varid = 0 ! default definition
634	IF ( PRESENT(kdimsz) ) kdimsz(:) = 0 ! default definition
635	!
636	IF ( knumfl > 0 ) THEN
637	IF( iom_file(knumfl)%iopen == 0 ) THEN
638	CALL ctl_stop( trim(clinfo), 'the file is not open' )
639	ELSE
640	!
641	ll_fnd = .FALSE.
642	idvar = 0
643	!
644	DO WHILE ( .NOT.ll_fnd .AND. idvar < iom_file(knumfl)%nvars )
645	idvar = idvar + 1
646	ll_fnd = ( TRIM(cdvar) == TRIM(iom_file(knumfl)%cn_var(idvar)) )
647	END DO
648	!
649	IF( .NOT.ll_fnd ) THEN
650	idvar = idvar + 1
651	IF( idvar <= jpmax_vars ) THEN
652	CALL flioinqv( knumfl, cdvar, ll_fnd, nb_dims = i_nvd )
653	IF( ll_fnd ) THEN
654	IF( i_nvd <= jpmax_dims ) THEN
655	iom_file(knumfl)%nvars = idvar
656	iom_file(knumfl)%cn_var(idvar) = trim(cdvar)
657	iom_file(knumfl)%ndims(idvar) = i_nvd
658	CALL flioinqv( knumfl, cdvar, ll_fnd, &
659	& len_dims = iom_file(knumfl)%dimsz(1:i_nvd,idvar), &
660	& id_dims = idimid(1:i_nvd) )
661	DO ji = 1, i_nvd
662	IF ( idimid(ji) == iom_file(knumfl)%iduld ) iom_file(knumfl)%luld(idvar) = .TRUE.
663	END DO
664	!----------
665	!---------- Deal with scale_factor and offset
666	CALL flioinqa( knumfl, cdvar, 'scale_factor', ll_fnd )
667	IF (ll_fnd) THEN
668	CALL fliogeta( knumfl, cdvar, 'scale_factor', iom_file(knumfl)%scf(idvar) )
669	ELSE
670	iom_file(knumfl)%scf(idvar) = 1.
671	END IF
672	CALL flioinqa( knumfl, cdvar, 'offset', ll_fnd )
673	IF( ll_fnd ) THEN
674	CALL fliogeta( knumfl, cdvar, 'offset', iom_file(knumfl)%ofs(idvar) )
675	ELSE
676	iom_file(knumfl)%ofs(idvar) = 0.
677	END IF
678	!
679	iom_varid = idvar
680	IF ( PRESENT(kdimsz) ) THEN
681	IF ( i_nvd == size(kdimsz) ) THEN
682	kdimsz(:) = iom_file(knumfl)%dimsz(1:i_nvd,idvar)
683	ELSE
684	WRITE(ctmp1,*) i_nvd, size(kdimsz)
685	CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
686	ENDIF
687	ENDIF
688	ELSE
689	CALL ctl_stop( trim(clinfo), 'Too many dimensions in the file '//iom_file(knumfl)%name, &
690	& 'increase the parameter jpmax_vars')
691	ENDIF
692	ELSE
693	CALL ctl_warn( trim(clinfo), 'Variable '//trim(cdvar)// &
694	& ' is not found in the file '//trim(iom_file(knumfl)%name) )
695	ENDIF
696	ELSE
697	CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(knumfl)%name, &
698	& 'increase the parameter jpmax_vars')
699	ENDIF
700	ELSE
701	iom_varid = idvar
702	IF ( PRESENT(kdimsz) ) THEN
703	i_nvd = iom_file(knumfl)%ndims(idvar)
704	IF ( i_nvd == size(kdimsz) ) THEN
705	kdimsz(:) = iom_file(knumfl)%dimsz(1:i_nvd,idvar)
706	ELSE
707	WRITE(ctmp1,*) i_nvd, size(kdimsz)
708	CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
709	ENDIF
710	ENDIF
711	ENDIF
712	ENDIF
713	ENDIF
714
715	END FUNCTION iom_varid
716
717
718	FUNCTION iom_get_gblatt( knumfl, kinfonum )
719	!!-----------------------------------------------------------------------
720	!! * FUNCTION iom_get_gblatt *
721	!!
722	!! ** Purpose : ???
723	!!
724	!! ** Method : ???
725	!!
726	!!-----------------------------------------------------------------------
727	INTEGER,INTENT(in) :: knumfl
728	INTEGER, intent(in) :: kinfonum
729	!
730	CHARACTER(LEN=10) :: clinfo
731	REAL(wp) :: iom_get_gblatt
732	!!-----------------------------------------------------------------------
733
734	WRITE(clinfo,*) kinfonum
735	clinfo = 'info'//trim(adjustl(clinfo))
736	CALL fliogeta (knumfl, "?", clinfo, iom_get_gblatt)
737
738	END FUNCTION iom_get_gblatt
739
740	!!======================================================================
741	END MODULE iom

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

Download in other formats: