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

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

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

Download in other formats: