source: IOIPSL/trunk/src/flincom.f90 @ 1660

Last change on this file since 1660 was 1660, checked in by mmaipsl, 10 years ago

Add ipsldbg management for debugging flincom.
Correct a bug in flinget_mat when readding multiple time steps.

  • Property svn:keywords set to Id
File size: 58.4 KB
Line 
1MODULE flincom
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!---------------------------------------------------------------------
8  USE netcdf
9!-
10  USE calendar,  ONLY : ju2ymds, ymds2ju, ioconf_calendar
11  USE errioipsl, ONLY : histerr, ipslout,ipslerr,ipsldbg
12  USE stringop,  ONLY : strlowercase
13!-
14  IMPLICIT NONE
15!-
16  PRIVATE
17  PUBLIC :: flinput, flincre, flinget, flinclo, &
18            flinopen, flininfo, flininspect, flinquery_var
19!-
20  INTERFACE flinopen
21!---------------------------------------------------------------------
22!- The "flinopen" routines will open an input file
23!-
24!- INPUT
25!-
26!- filename  : Name of the netCDF file to be opened
27!-
28!- iideb     : index i for zoom     !
29!- iilen     : length  of  zoom     !   for
30!- jjdeb     : index j for zoom     !   zoom
31!- jjlen     : length  of  zoom     !
32!-
33!- do_test   : A flag that enables the testing of the content
34!-             of the file against the input from the model
35!-
36!- INPUT if do_test=TRUE      OUTPUT else
37!-
38!- iim       : size in the x direction in the file (longitude)
39!- jjm       : size in the y direction
40!- llm       : number of levels
41!-             (llm = 0 means no axis to be expected)
42!- lon       : array of (iilen,jjlen) (zoom), or (iim,jjm) (no zoom),
43!-             that contains the longitude of each point
44!- lat       : same for latitude
45!- lev       : An array of llm for the latitude
46!-
47!- WARNING :
48!- In the case of do_test=FALSE it is for the user to check
49!- that the dimensions of lon lat and lev are correct when passed to
50!- flinopen. This can be done after the call when iim and jjm have
51!- been retrieved from the netCDF file. In F90 this problem will
52!- be solved with an internal assign
53!- IF iim, jjm, llm or ttm are parameters in the calling program and
54!- you use the option do_test=FALSE it will create a segmentation fault
55!-
56!-  OUTPUT
57!-
58!-  ttm       : size of time axis
59!-  itaus     : Time steps within this file
60!-  date0     : Julian date at which itau = 0
61!-  dt        : length of the time steps of the data
62!-  fid       : returned file ID which is later used to read the data
63!---------------------------------------------------------------------
64    MODULE PROCEDURE flinopen_zoom2d, flinopen_nozoom
65  END INTERFACE
66!-
67  INTERFACE flinput
68!---------------------------------------------------------------------
69!- The "flinput" routines will put a variable
70!- on the netCDF file created by flincre.
71!- If the sizes of the axis do not match the one of the IDs
72!- then a new axis is created.
73!- That is we loose the possibility of writting hyperslabs of data.
74!-
75!- Again here if iim = jjm = llm = ttm = 0
76!- then a global attribute is added to the file.
77!-
78!- INPUT
79!-
80!- fid      : Identification of the file in which we will write
81!- varname  : Name of variable to be written
82!- iim      : size in x of variable
83!- nlonid   : ID of x axis which could fit for this axis
84!- jjm      : size in y of variable
85!- nlatid   : ID of y axis which could fit for this axis
86!- llm      : size in z of variable
87!- zdimid   : ID of z axis which could fit for this axis
88!- ttm      : size in t of variable
89!- tdimid   : ID of t axis which could fit for this axis
90!-
91!- OUTPUT
92!-
93!- NONE
94!---------------------------------------------------------------------
95    MODULE PROCEDURE flinput_r4d, flinput_r3d, flinput_r2d, &
96                     flinput_r1d, flinput_scal
97  END INTERFACE
98!-
99  INTERFACE flinget
100    MODULE PROCEDURE flinget_r4d, flinget_r3d, flinget_r2d, &
101                     flinget_r1d, flinget_scal, &
102                     flinget_r4d_zoom2d, flinget_r3d_zoom2d, &
103                     flinget_r2d_zoom2d
104  END INTERFACE
105!-
106! This is the data we keep on each file we open
107!-
108  INTEGER, PARAMETER :: nbfile_max = 200
109  INTEGER, SAVE :: nbfiles = 0
110  INTEGER, SAVE :: ncids(nbfile_max), ncnbd(nbfile_max), &
111                   ncfunli(nbfile_max), ncnba(nbfile_max)
112  INTEGER, SAVE :: ncnbva(nbfile_max), ncdims(nbfile_max,4)
113  LOGICAL, SAVE :: ncfileopen(nbfile_max)=.FALSE.
114!-
115  INTEGER, SAVE :: cind_vid, cind_fid, cind_len
116  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: cindex
117!-
118  INTEGER,DIMENSION(4) :: w_sta, w_len, w_dim
119!-
120CONTAINS
121!-
122!===
123!-
124SUBROUTINE flincre &
125  (filename, iim1, jjm1, lon1, lat1, llm1, lev1, ttm1, itaus, &
126   time0, dt, fid_out, nlonid1, nlatid1, zdimid1, tdimid1)
127!---------------------------------------------------------------------
128!- This is a "low level" subroutine for opening netCDF files wich
129!- contain the major coordinate system of the model.
130!- Other coordinates needed for other variables
131!- will be added as they are needed.
132!-
133!- INPUT
134!-
135!- filename    : Name of the file to be created
136!- iim1, jjm1  : Horizontal size of the grid
137!-               which will be stored in the file
138!- lon1, lat1  : Horizontal grids
139!- llm1        : Size of the vertical grid
140!- lev1        : Vertical grid
141!- ttm1        : Size of time axis
142!- itaus       : time steps on the time axis
143!- time0       : Time in julian days at which itau = 0
144!- dt          : time step in seconds between itaus
145!-               (one step of itau)
146!-
147!- OUTPUT
148!-
149!- fid         : File identification
150!- nlonid1     : Identification of longitudinal axis
151!- nlatid1     : Identification of latitudinal axis
152!- zdimid1     : ID of vertical axis
153!- tdimid1     : ID of time axis
154!---------------------------------------------------------------------
155  IMPLICIT NONE
156!-
157! ARGUMENTS
158!-
159  CHARACTER(LEN=*) :: filename
160  INTEGER :: iim1, jjm1, llm1, ttm1
161  REAL :: lon1(iim1,jjm1)
162  REAL :: lat1(iim1,jjm1)
163  REAL :: lev1(llm1)
164  INTEGER :: itaus(ttm1)
165  REAL :: time0
166  REAL :: dt
167  INTEGER :: fid_out, zdimid1, nlonid1, nlatid1, tdimid1
168!-
169! LOCAL
170!-
171  INTEGER :: iret, lll, fid
172  INTEGER :: lonid, latid, levid, timeid
173  INTEGER :: year, month, day
174  REAL :: sec
175  CHARACTER(LEN=250):: name
176!-
177  LOGICAL :: l_dbg
178!---------------------------------------------------------------------
179  CALL ipsldbg (old_status=l_dbg)
180
181  lll = LEN_TRIM(filename)
182  IF (filename(lll-2:lll) /= '.nc') THEN
183    name=filename(1:lll)//'.nc'
184  ELSE
185    name=filename(1:lll)
186  ENDIF
187!-
188  iret = NF90_CREATE (name, NF90_CLOBBER, fid)
189!-
190  iret = NF90_DEF_DIM (fid, 'x',     iim1, nlonid1)
191  iret = NF90_DEF_DIM (fid, 'y',     jjm1, nlatid1)
192  iret = NF90_DEF_DIM (fid, 'lev',   llm1, zdimid1)
193  iret = NF90_DEF_DIM (fid, 'tstep', ttm1, tdimid1)
194!-
195! Vertical axis
196!-
197  IF (l_dbg) WRITE(ipslout,*) 'flincre Vertical axis'
198!-
199  iret = NF90_DEF_VAR (fid, 'lev', NF90_FLOAT, zdimid1, levid)
200  iret = NF90_PUT_ATT (fid, levid, 'units',     '-')
201  iret = NF90_PUT_ATT (fid, levid, 'title',     'levels')
202  iret = NF90_PUT_ATT (fid, levid, 'long_name', 'Sigma Levels')
203!-
204! Time axis
205!-
206  IF (l_dbg) WRITE(ipslout,*) 'flincre time axis'
207!-
208  iret = NF90_DEF_VAR (fid, 'tstep', NF90_FLOAT, tdimid1, timeid)
209  iret = NF90_PUT_ATT (fid, timeid, 'units',     '-')
210  iret = NF90_PUT_ATT (fid, timeid, 'title',     'time')
211  iret = NF90_PUT_ATT (fid, timeid, 'long_name', 'time steps')
212!-
213! The longitude
214!-
215  IF (l_dbg) WRITE(ipslout,*) 'flincre Longitude axis'
216!-
217  iret = NF90_DEF_VAR (fid, "nav_lon", NF90_FLOAT, &
218                       (/ nlonid1, nlatid1 /), lonid)
219  iret = NF90_PUT_ATT (fid, lonid, 'units', "degrees_east")
220  iret = NF90_PUT_ATT (fid, lonid, 'title', "Longitude")
221  iret = NF90_PUT_ATT (fid, lonid, 'nav_model', &
222                       "Lambert projection of PROMES")
223  iret = NF90_PUT_ATT (fid, lonid, 'valid_min', &
224                       REAL(MINVAL(lon1),KIND=4))
225  iret = NF90_PUT_ATT (fid, lonid, 'valid_max', &
226                       REAL(MAXVAL(lon1),KIND=4))
227!-
228! The Latitude
229!-
230  IF (l_dbg) WRITE(ipslout,*) 'flincre Latitude axis'
231!-
232  iret = NF90_DEF_VAR (fid, "nav_lat", NF90_FLOAT, &
233                     (/ nlonid1, nlatid1 /), latid)
234  iret = NF90_PUT_ATT (fid, latid, 'units', "degrees_north")
235  iret = NF90_PUT_ATT (fid, latid, 'title', "Latitude")
236  iret = NF90_PUT_ATT (fid, latid, 'nav_model', &
237                       "Lambert projection of PROMES")
238  iret = NF90_PUT_ATT (fid, latid, 'valid_min', &
239                       REAL(MINVAL(lat1),KIND=4))
240  iret = NF90_PUT_ATT (fid, latid, 'valid_max', &
241                       REAL(MAXVAL(lat1),KIND=4))
242!-
243! The time coordinates
244!-
245  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', &
246                       REAL(dt,KIND=4))
247!-
248  CALL ju2ymds (time0, year, month, day, sec)
249!-
250  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'year0',  REAL(year,KIND=4))
251  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'month0', REAL(month,KIND=4))
252  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'day0',   REAL(day,KIND=4))
253  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'sec0',   REAL(sec,KIND=4))
254!-
255  iret = NF90_ENDDEF (fid)
256!-
257  IF (l_dbg) WRITE(ipslout,*) 'flincre Variable'
258!-
259  iret = NF90_PUT_VAR (fid, levid, lev1(1:llm1))
260!-
261  IF (l_dbg) WRITE(ipslout,*) 'flincre Time Variable'
262!-
263  iret = NF90_PUT_VAR (fid, timeid, REAL(itaus(1:ttm1)))
264!-
265  IF (l_dbg) WRITE(ipslout,*) 'flincre Longitude'
266!-
267  iret = NF90_PUT_VAR (fid, lonid, lon1(1:iim1,1:jjm1))
268!-
269  IF (l_dbg) WRITE(ipslout,*) 'flincre Latitude'
270!-
271  iret = NF90_PUT_VAR (fid, latid, lat1(1:iim1,1:jjm1))
272!-
273! Keep all this information
274!-
275  nbfiles = nbfiles+1
276!-
277  IF (nbfiles > nbfile_max) THEN
278    CALL histerr (3,'flincre', &
279     'Too many files. Please increase nbfil_max', &
280     'in program flincom.F90.',' ')
281  ENDIF
282!-
283  ncids(nbfiles) = fid
284  ncnbd(nbfiles) = 4
285!-
286  ncdims(nbfiles,1:4) = (/ iim1, jjm1, llm1, ttm1 /)
287!-
288  ncfunli(nbfiles) = -1
289  ncnba(nbfiles)   =  4
290  ncnbva(nbfiles)  =  0
291  ncfileopen(nbfiles) = .TRUE.
292!-
293  fid_out = nbfiles
294!---------------------
295END SUBROUTINE flincre
296!-
297!===
298!-
299SUBROUTINE flinopen_zoom2d &
300  (filename, iideb, iilen, jjdeb, jjlen, do_test, &
301  iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
302!---------------------------------------------------------------------
303  IMPLICIT NONE
304!-
305! ARGUMENTS
306!-
307  CHARACTER(LEN=*) :: filename
308  LOGICAL :: do_test
309  INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen
310  REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm)
311  INTEGER :: itaus(ttm)
312  REAL :: date0, dt
313  INTEGER :: fid_out
314!-
315  LOGICAL :: l_dbg
316!---------------------------------------------------------------------
317  CALL ipsldbg (old_status=l_dbg)
318
319  IF (l_dbg) WRITE (*,*) ' iideb, iilen, jjdeb, jjlen, iim, jjm ', &
320                           iideb, iilen, jjdeb, jjlen, iim, jjm
321  IF (l_dbg) WRITE (*,*) ' lon ', lon(1,1), lon(iilen,jjlen)
322  IF (l_dbg) WRITE (*,*) ' lat ', lat(1,1), lat(iilen,jjlen)
323!-
324  CALL flinopen_work &
325    (filename, iideb, iilen, jjdeb, jjlen, do_test, &
326     iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
327!-----------------------------
328END SUBROUTINE flinopen_zoom2d
329!-
330!===
331!-
332SUBROUTINE flinopen_nozoom &
333  (filename, do_test, iim, jjm, llm, lon, lat, lev, ttm, &
334   itaus, date0, dt, fid_out)
335!---------------------------------------------------------------------
336  IMPLICIT NONE
337!-
338! ARGUMENTS
339!-
340  CHARACTER(LEN=*) :: filename
341  LOGICAL :: do_test
342  INTEGER :: iim, jjm, llm, ttm
343  REAL :: lon(iim,jjm), lat(iim,jjm), lev(llm)
344  INTEGER :: itaus(ttm)
345  REAL :: date0, dt
346  INTEGER :: fid_out
347  INTEGER :: iimc, jjmc
348!---------------------------------------------------------------------
349  iimc=iim
350  jjmc=jjm
351  CALL flinopen_work &
352    (filename, 1, iimc, 1, jjmc, do_test, &
353     iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
354!-------------------------
355END SUBROUTINE flinopen_nozoom
356!-
357!===
358!-
359SUBROUTINE flinopen_work &
360  (filename, iideb, iilen, jjdeb, jjlen, do_test, &
361   iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
362!---------------------------------------------------------------------
363  IMPLICIT NONE
364!-
365! ARGUMENTS
366!-
367  CHARACTER(LEN=*) :: filename
368  LOGICAL :: do_test
369  INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen
370  REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm)
371  INTEGER :: itaus(ttm)
372  REAL :: date0, dt
373  INTEGER :: fid_out
374!-
375! LOCAL
376!-
377  REAL, PARAMETER :: eps = 1.e-4
378!-
379  INTEGER :: iret, vid, fid, nbdim, i, iilast, jjlast
380  INTEGER :: gdtt_id, old_id, iv, gdtmaf_id
381  CHARACTER(LEN=250) :: name
382  CHARACTER(LEN=80) :: units, calendar
383  INTEGER :: tmp_iim, tmp_jjm, tmp_llm, tmp_ttm
384  REAL :: x_first, x_last
385  INTEGER :: year, month, day
386  REAL :: r_year, r_month, r_day
387  INTEGER :: year0, month0, day0, hours0, minutes0, seci
388  REAL :: sec, sec0
389  CHARACTER :: strc
390!-
391  REAL,DIMENSION(:),ALLOCATABLE :: vec_tmp
392!-
393  LOGICAL :: open_file
394  LOGICAL :: l_dbg
395!---------------------------------------------------------------------
396  CALL ipsldbg (old_status=l_dbg)
397
398  iilast = iideb+iilen-1
399  jjlast = jjdeb+jjlen-1
400  IF (l_dbg) WRITE (*,*) &
401    ' flinopen_work zoom 2D information '// &
402    ' iideb, iilen, iilast, jjdeb, jjlen, jjlast ', &
403      iideb, iilen, iilast, jjdeb, jjlen, jjlast
404!-
405! 1.0 get all infos on the file
406!-
407! Either the fid_out has not been initialized (0 or very large)
408! then we have to open anyway. Else we only need to open the file
409! if it has not been opened before.
410!-
411  IF ( (fid_out < 1).OR.(fid_out > nbfile_max) ) THEN
412    open_file = .TRUE.
413  ELSE IF (.NOT.ncfileopen(fid_out)) THEN
414    open_file = .TRUE.
415  ELSE
416    open_file = .FALSE.
417  ENDIF
418!-
419  IF (open_file) THEN
420    CALL flininfo (filename,tmp_iim,tmp_jjm,tmp_llm,tmp_ttm,fid_out)
421  ELSE
422!-- The user has already opened the file
423!-- and we trust that he knows the dimensions
424    tmp_iim = iim
425    tmp_jjm = jjm
426    tmp_llm = llm
427    tmp_ttm = ttm
428  ENDIF
429!-
430  IF (l_dbg) &
431    WRITE(ipslout,*) 'OUT OF flininfo :',tmp_iim,tmp_jjm,tmp_llm,tmp_ttm
432!-
433  fid = ncids(fid_out)
434!-
435! 2.0 get the sizes and names of the different coordinates
436!     and do a first set of verification.
437!-
438! 2.2 We test the axis if we have to.
439!-
440  IF (l_dbg) &
441    WRITE(ipslout,*) 'flininfo 2.2 We test if we have to test : ',do_test
442!-
443  IF (do_test) THEN
444    IF      (iim /= tmp_iim) THEN
445      CALL histerr (3,'flinopen', &
446        'file '//filename//' does not have the ', &
447        'required dimension in x direction (longitude)',' ')
448    ELSE IF (jjm /= tmp_jjm) THEN
449      CALL histerr (3,'flinopen', &
450        'file '//filename//' does not have the ', &
451        'required dimension in y direction (latitude)',' ')
452    ELSE IF ( llm /= tmp_llm .AND. llm > 0 ) THEN
453      CALL histerr (3,'flinopen', &
454        'file '//filename//' does not have the ', &
455        'required dimension in the vertical',' ')
456    ENDIF
457  ELSE
458!---
459!-- 2.3 Else the sizes of the axes are returned to the user
460!---
461    IF (l_dbg) WRITE(ipslout,*) 'flinopen 2.3 Else sizes are returned'
462!---
463    iim = tmp_iim
464    jjm = tmp_jjm
465    llm = tmp_llm
466  ENDIF
467!-
468  ttm = tmp_ttm
469!-
470! 3.0 Check if we are realy talking about the same coodinate system
471!     if not then we get the lon, lat and lev variables from the file
472!-
473  IF (l_dbg) WRITE(ipslout,*) 'flinopen 3.0 we are realy talking'
474!-
475  IF (do_test) THEN
476!---
477    CALL flinfindcood (fid_out, 'lon', vid, nbdim)
478    iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /))
479    iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /))
480!---
481    IF (l_dbg) &
482      WRITE(ipslout,*) 'from file lon first and last, modulo 360. ', &
483        x_first, x_last, MODULO(x_first,360.), MODULO(x_last,360.)
484    IF (l_dbg) &
485      WRITE(ipslout,*) 'from model lon first and last, modulo 360. ', &
486        lon(1,1),lon(iilen,jjlen), &
487        MODULO(lon(1,1),360.), MODULO(lon(iilen,jjlen),360.)
488    IF (    (ABS( MODULO(x_first,360.) &
489                 -MODULO(lon(1,1),360.)) > eps) &
490        .OR.(ABS( MODULO(x_last,360.) &
491                 -MODULO(lon(iilen ,jjlen),360.)) > eps ) ) THEN
492      CALL histerr (3,'flinopen', &
493        'file '//filename//' and the model do not', &
494        'share the same longitude coordinate', &
495        'Obtained by comparing the first and last values ')
496    ENDIF
497!---
498    CALL flinfindcood (fid_out, 'lat', vid, nbdim)
499    iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /))
500    iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /))
501!---
502    IF (l_dbg) WRITE(ipslout,*) &
503      'from file lat first and last ',x_first,x_last
504    IF (l_dbg) WRITE(ipslout,*) &
505      'from model lat first and last ',lat(1,1),lat(iilen,jjlen)
506!---
507    IF (    (ABS(x_first-lat(1,1)) > eps) &
508        .OR.(ABS(x_last-lat(iilen,jjlen)) > eps) ) THEN
509      CALL histerr (3,'flinopen', &
510        'file '//filename//' and the model do not', &
511        'share the same latitude coordinate', &
512        'Obtained by comparing the first and last values ')
513    ENDIF
514!---
515    IF (llm > 0) THEN
516      CALL flinfindcood (fid_out, 'lev', vid, nbdim)
517      iret = NF90_GET_VAR (fid, vid, x_first, start=(/ 1 /))
518      iret = NF90_GET_VAR (fid, vid, x_last, start=(/ llm /))
519!-----
520      IF (l_dbg) WRITE(ipslout,*) &
521        'from file lev first and last ',x_first ,x_last
522      IF (l_dbg) WRITE(ipslout,*) &
523        'from model lev first and last ',lev(1),lev(llm)
524!-----
525      IF (    (ABS(x_first-lev(1)) > eps) &
526          .OR.(ABS(x_last-lev(llm)) > eps) ) THEN
527        CALL histerr (3,'flinopen', &
528          'file '//filename//' and the model do not', &
529          'share the same vertical coordinate', &
530          'Obtained by comparing the first and last values')
531      ENDIF
532    ENDIF
533!---
534  ELSE
535!---
536!-- 4.0 extracting the coordinates if we do not check
537!---
538    IF (l_dbg) WRITE(ipslout,*) 'flinopen 4.0 extracting the coordinates'
539!---
540    CALL flinfindcood (fid_out, 'lon', vid, nbdim)
541    IF (nbdim == 2) THEN
542      iret = NF90_GET_VAR (fid, vid, lon, &
543               start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /))
544    ELSE
545      ALLOCATE(vec_tmp(iilen))
546      iret = NF90_GET_VAR (fid, vid, vec_tmp, &
547               start=(/ iideb /), count=(/ iilen /))
548      DO i=1,jjlen
549        lon(:,i) = vec_tmp(:)
550      ENDDO
551      DEALLOCATE(vec_tmp)
552    ENDIF
553!---
554    CALL flinfindcood (fid_out, 'lat', vid, nbdim)
555    IF (nbdim == 2) THEN
556      iret = NF90_GET_VAR (fid, vid, lat, &
557               start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /))
558    ELSE
559      ALLOCATE(vec_tmp(jjlen))
560      iret = NF90_GET_VAR (fid, vid, vec_tmp, &
561               start=(/ jjdeb /), count=(/ jjlen /))
562      DO i=1,iilen
563        lat(i,:) = vec_tmp(:)
564      ENDDO
565      DEALLOCATE(vec_tmp)
566    ENDIF
567!---
568    IF (llm > 0) THEN
569      CALL flinfindcood (fid_out, 'lev', vid, nbdim)
570      IF (nbdim == 1) THEN
571        iret = NF90_GET_VAR (fid, vid, lev, &
572                 start=(/ 1 /), count=(/ llm /))
573      ELSE
574        CALL histerr (3,'flinopen', &
575          'Can not handle vertical coordinates that have more',&
576          'than 1 dimension',' ')
577      ENDIF
578    ENDIF
579  ENDIF
580!-
581! 5.0 Get all the details for the time if possible needed
582!-
583  IF (l_dbg) WRITE(ipslout,*) 'flinopen 5.0 Get time'
584!-
585  IF (ttm > 0) THEN
586!---
587!-- 5.1 Find the time axis. Prefered method is the 'timestep since'
588!---
589    gdtmaf_id = -1
590    gdtt_id = -1
591    old_id = -1
592    DO iv=1,ncnbva(fid_out)
593      name=''
594      iret = NF90_INQUIRE_VARIABLE (fid, iv, name=name)
595      units=''
596      iret = NF90_GET_ATT (fid, iv, 'units', units)
597      IF (INDEX(units,'seconds since') > 0) gdtmaf_id = iv
598      IF (INDEX(units,'timesteps since') > 0) gdtt_id = iv
599      IF (INDEX(name, 'tstep') > 0) old_id = iv
600    ENDDO
601!---
602    IF (gdtt_id > 0) THEN
603      vid = gdtt_id
604    ELSE IF (gdtmaf_id > 0) THEN
605      vid = gdtmaf_id
606    ELSE IF (old_id > 0) THEN
607      vid = old_id
608    ELSE
609      CALL histerr (3, 'flinopen', 'No time axis found',' ',' ')
610    ENDIF
611!---
612    ALLOCATE(vec_tmp(ttm))
613    iret = NF90_GET_VAR (fid,vid,vec_tmp,start=(/ 1 /),count=(/ ttm /))
614    itaus(1:ttm) = NINT(vec_tmp(1:ttm))
615    DEALLOCATE(vec_tmp)
616!---
617    IF (l_dbg) WRITE(ipslout,*) 'flinopen 5.1 Times ',itaus
618!---
619!-- Getting all the details for the time axis
620!---
621!-- Find the calendar
622    calendar = ''
623    iret = NF90_GET_ATT (fid,gdtmaf_id,'calendar',calendar)
624    IF (iret == NF90_NOERR) THEN
625      CALL ioconf_calendar(calendar)
626    ENDIF
627!--
628    units = ''
629    iret = NF90_GET_ATT (fid,vid,'units',units)
630    IF (gdtt_id > 0) THEN
631      units = units(INDEX(units,'since')+6:LEN_TRIM(units))
632      READ (units,'(I4.4,5(a,I2.2))') &
633        year0, strc, month0, strc, day0, &
634               strc, hours0, strc, minutes0, strc, seci
635      sec0 = hours0*3600. + minutes0*60. + seci
636      CALL ymds2ju (year0, month0, day0, sec0, date0)
637      IF (l_dbg) &
638        WRITE(ipslout,*) 'flinopen 5.1 gdtt_id year0 ... date0 ', &
639                   year0, month0, day0, sec0, date0
640!-----
641      iret = NF90_GET_ATT (fid, gdtt_id, 'tstep_sec', dt)
642    ELSE IF (gdtmaf_id > 0) THEN
643      units = units(INDEX(units,'since')+6:LEN_TRIM(units))
644      READ (units,'(I4.4,5(a,I2.2))') &
645        year0, strc, month0, strc, day0, &
646               strc, hours0, strc, minutes0, strc, seci
647      sec0 = hours0*3600. + minutes0*60. + seci
648      CALL ymds2ju (year0, month0, day0, sec0, date0)
649!-----
650      IF (l_dbg) &
651        WRITE(ipslout,*) 'flinopen 5.1 gdtmaf_id year0 ... date0 ', &
652                   year0, month0, day0, sec0, date0
653    ELSE IF (old_id > 0) THEN
654      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', dt)
655      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'day0', r_day)
656      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'sec0', sec)
657      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'year0', r_year)
658      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'month0', r_month)
659!-----
660      day = INT(r_day)
661      month = INT(r_month)
662      year = INT(r_year)
663!-----
664      CALL ymds2ju (year, month, day, sec, date0)
665    ENDIF
666  ENDIF
667!-
668  IF (l_dbg) WRITE(ipslout,*) 'flinopen 6.0 File opened', date0, dt
669!---------------------------
670END SUBROUTINE flinopen_work
671!-
672!===
673!-
674SUBROUTINE flininfo (filename, iim, jjm, llm, ttm, fid_out)
675!---------------------------------------------------------------------
676!- This subroutine allows to get some information.
677!- It is usualy done within flinopen but the user may want to call
678!- it before in order to allocate the space needed to extract the
679!- data from the file.
680!---------------------------------------------------------------------
681  IMPLICIT NONE
682!-
683! ARGUMENTS
684!-
685  CHARACTER(LEN=*) :: filename
686  INTEGER :: iim, jjm, llm, ttm, fid_out
687!-
688! LOCAL
689!-
690  INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim
691  INTEGER :: iv, lll
692  INTEGER :: xid, yid, zid, tid
693  CHARACTER(LEN=80) :: name
694  CHARACTER(LEN=30) :: axname
695!-
696  LOGICAL :: l_dbg
697!---------------------------------------------------------------------
698  CALL ipsldbg (old_status=l_dbg)
699
700  lll = LEN_TRIM(filename)
701  IF (filename(lll-2:lll) /= '.nc') THEN
702    name = filename(1:lll)//'.nc'
703  ELSE
704    name = filename(1:lll)
705  ENDIF
706!-
707  iret = NF90_OPEN (name, NF90_NOWRITE, fid)
708  IF (iret /= NF90_NOERR) THEN
709    CALL histerr(3, 'flininfo','Could not open file :',TRIM(name),' ')
710  ENDIF
711!-
712  iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, &
713                      nAttributes=nb_atts, unlimitedDimId=id_unlim)
714!-
715  xid = -1; iim = 0;
716  yid = -1; jjm = 0;
717  zid = -1; llm = 0;
718  tid = -1; ttm = 0;
719!-
720  DO iv=1,ndims
721!---
722    iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll)
723    CALL strlowercase (axname)
724    axname = ADJUSTL(axname)
725!---
726    IF (l_dbg) WRITE(ipslout,*) &
727      'flininfo - getting axname',iv,axname,lll
728!---
729    IF      (    (INDEX(axname,'x') == 1) &
730             .OR.(INDEX(axname,'lon') == 1) ) THEN
731      xid = iv; iim = lll;
732    ELSE IF (    (INDEX(axname,'y') == 1) &
733             .OR.(INDEX(axname,'lat') == 1) ) THEN
734      yid = iv; jjm = lll;
735    ELSE IF (    (INDEX(axname,'lev') == 1) &
736             .OR.(INDEX(axname,'plev') == 1) &
737             .OR.(INDEX(axname,'z') == 1) &
738             .OR.(INDEX(axname,'depth') == 1) ) THEN
739      zid = iv; llm = lll;
740    ELSE IF (    (INDEX(axname,'tstep') == 1) &
741             .OR.(INDEX(axname,'time_counter') == 1) ) THEN
742!---- For the time we certainly need to allow for other names
743      tid = iv; ttm = lll;
744    ELSE IF (ndims == 1) THEN
745!---- Nothing was found and ndims=1 then we have a vector of data
746      xid = 1; iim = lll;
747    ENDIF
748!---
749  ENDDO
750!-
751! Keep all this information
752!-
753  nbfiles = nbfiles+1
754!-
755  IF (nbfiles > nbfile_max) THEN
756    CALL histerr (3,'flininfo', &
757      'Too many files. Please increase nbfil_max', &
758      'in program flincom.F90.',' ')
759  ENDIF
760!-
761  ncids(nbfiles) = fid
762  ncnbd(nbfiles) = ndims
763!-
764  ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /)
765!-
766  ncfunli(nbfiles) = id_unlim
767  ncnba(nbfiles)   = nb_atts
768  ncnbva(nbfiles)  = nvars
769  ncfileopen(nbfiles) = .TRUE.
770!-
771  fid_out = nbfiles
772!----------------------
773END SUBROUTINE flininfo
774!-
775!===
776!-
777SUBROUTINE flinput_r1d &
778  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
779!---------------------------------------------------------------------
780  IMPLICIT NONE
781!-
782  INTEGER :: fid_in
783  CHARACTER(LEN=*) :: varname
784  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
785  REAL :: var(:)
786!-
787  INTEGER :: fid, ncvarid, ndim, iret
788  LOGICAL :: l_dbg
789!---------------------------------------------------------------------
790  CALL ipsldbg (old_status=l_dbg)
791
792  IF (l_dbg) WRITE(ipslout,*) &
793     "flinput_r1d : SIZE(var) = ",SIZE(var)
794!-
795  CALL flinput_mat &
796    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
797     fid,ncvarid,ndim)
798!-
799  iret = NF90_PUT_VAR (fid, ncvarid, var, &
800           start=w_sta(1:ndim), count=w_len(1:ndim))
801!-------------------------
802END SUBROUTINE flinput_r1d
803!-
804!===
805!-
806SUBROUTINE flinput_r2d &
807  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
808!---------------------------------------------------------------------
809  IMPLICIT NONE
810!-
811  INTEGER :: fid_in
812  CHARACTER(LEN=*) :: varname
813  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
814  REAL :: var(:,:)
815!-
816  INTEGER :: fid, ncvarid, ndim, iret
817  LOGICAL :: l_dbg
818!---------------------------------------------------------------------
819  CALL ipsldbg (old_status=l_dbg)
820
821  IF (l_dbg) WRITE(ipslout,*) &
822     "flinput_r2d : SIZE(var) = ",SIZE(var)
823!-
824  CALL flinput_mat &
825    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
826     fid,ncvarid,ndim)
827!-
828  iret = NF90_PUT_VAR (fid, ncvarid, var, &
829           start=w_sta(1:ndim), count=w_len(1:ndim))
830!-------------------------
831END SUBROUTINE flinput_r2d
832!-
833!===
834!-
835SUBROUTINE flinput_r3d &
836  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
837!---------------------------------------------------------------------
838  IMPLICIT NONE
839!-
840  INTEGER :: fid_in
841  CHARACTER(LEN=*) :: varname
842  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
843  REAL :: var(:,:,:)
844!-
845  INTEGER :: fid, ncvarid, ndim, iret
846  LOGICAL :: l_dbg
847!---------------------------------------------------------------------
848  CALL ipsldbg (old_status=l_dbg)
849
850  IF (l_dbg) WRITE(ipslout,*) &
851     "flinput_r3d : SIZE(var) = ",SIZE(var)
852!-
853  CALL flinput_mat &
854    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
855     fid,ncvarid,ndim)
856!-
857  iret = NF90_PUT_VAR (fid, ncvarid, var, &
858           start=w_sta(1:ndim), count=w_len(1:ndim))
859!-------------------------
860END SUBROUTINE flinput_r3d
861!-
862!===
863!-
864SUBROUTINE flinput_r4d &
865  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
866!---------------------------------------------------------------------
867  IMPLICIT NONE
868!-
869  INTEGER :: fid_in
870  CHARACTER(LEN=*) :: varname
871  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
872  REAL :: var(:,:,:,:)
873!-
874  INTEGER :: fid, ncvarid, ndim, iret
875  LOGICAL :: l_dbg
876!---------------------------------------------------------------------
877  CALL ipsldbg (old_status=l_dbg)
878
879  IF (l_dbg) WRITE(ipslout,*) &
880     "flinput_r4d : SIZE(var) = ",SIZE(var)
881!-
882  CALL flinput_mat &
883    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
884     fid,ncvarid,ndim)
885!-
886  iret = NF90_PUT_VAR (fid, ncvarid, var, &
887           start=w_sta(1:ndim), count=w_len(1:ndim))
888!-------------------------
889END SUBROUTINE flinput_r4d
890!-
891!===
892!-
893SUBROUTINE flinput_mat &
894  (fid_in,varname,iim,nlonid,jjm,nlatid, &
895                  llm,zdimid,ttm,tdimid,fid,ncvarid,ndim)
896!---------------------------------------------------------------------
897  IMPLICIT NONE
898!-
899  INTEGER :: fid_in
900  CHARACTER(LEN=*) :: varname
901  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
902  INTEGER :: fid, ncvarid, ndim
903!-
904! LOCAL
905!-
906  INTEGER :: iret
907!---------------------------------------------------------------------
908  fid = ncids(fid_in)
909!-
910  w_sta(1:4) = (/      1,      1,  1,  1 /)
911  w_len(1:2) = (/    iim,    jjm /)
912  w_dim(1:2) = (/ nlonid, nlatid /)
913!-
914  IF ( (llm > 0).AND.(ttm > 0) ) THEN
915    ndim = 4
916    w_len(3:4) = (/    llm,    ttm /)
917    w_dim(3:4) = (/ zdimid, tdimid /)
918  ELSE IF (llm > 0) THEN
919    ndim = 3
920    w_dim(3) = zdimid
921    w_len(3) = llm
922  ELSE IF (ttm > 0) THEN
923    ndim = 3
924    w_dim(3) = tdimid
925    w_len(3) = ttm
926  ELSE
927    ndim = 2
928  ENDIF
929!-
930  iret = NF90_REDEF   (fid)
931  iret = NF90_DEF_VAR (fid,varname,NF90_FLOAT,w_dim(1:ndim),ncvarid)
932  iret = NF90_PUT_ATT (fid,ncvarid,'short_name',TRIM(varname))
933  iret = NF90_ENDDEF  (fid)
934!--------------------------
935END  SUBROUTINE flinput_mat
936!-
937!===
938!-
939SUBROUTINE flinput_scal &
940  (fid_in, varname, iim, nlonid, jjm, nlatid, &
941                    llm, zdimid, ttm, tdimid, var)
942!---------------------------------------------------------------------
943  IMPLICIT NONE
944!-
945  INTEGER :: fid_in
946  CHARACTER(LEN=*) :: varname
947  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
948  REAL :: var
949!-
950! LOCAL
951!-
952  INTEGER :: fid, iret
953!---------------------------------------------------------------------
954  fid = ncids(fid_in)
955!-
956  iret = NF90_REDEF   (fid)
957  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, varname, REAL(var,KIND=4))
958  iret = NF90_ENDDEF  (fid)
959!---------------------------
960END  SUBROUTINE flinput_scal
961!-
962!===
963!-
964SUBROUTINE flinget_r1d &
965  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
966!---------------------------------------------------------------------
967  IMPLICIT NONE
968!-
969  INTEGER :: fid_in
970  CHARACTER(LEN=*) :: varname
971  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
972  REAL :: var(:)
973!-
974  INTEGER :: jl, ji
975  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
976  LOGICAL :: l_dbg
977!---------------------------------------------------------------------
978  CALL ipsldbg (old_status=l_dbg)
979
980  IF (.NOT.ALLOCATED(buff_tmp)) THEN
981    IF (l_dbg) WRITE(ipslout,*) &
982      "flinget_r1d : allocate buff_tmp for buff_sz = ",SIZE(var)
983    ALLOCATE (buff_tmp(SIZE(var)))
984  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
985    IF (l_dbg) WRITE(ipslout,*) &
986      "flinget_r1d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
987    DEALLOCATE (buff_tmp)
988    ALLOCATE (buff_tmp(SIZE(var)))
989  ENDIF
990!-
991  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
992                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
993!-
994  jl=0
995  DO ji=1,SIZE(var,1)
996    jl=jl+1
997    var(ji) = buff_tmp(jl)
998  ENDDO
999!-------------------------
1000END SUBROUTINE flinget_r1d
1001!-
1002!===
1003!-
1004SUBROUTINE flinget_r2d &
1005  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
1006!---------------------------------------------------------------------
1007  IMPLICIT NONE
1008!-
1009  INTEGER :: fid_in
1010  CHARACTER(LEN=*) :: varname
1011  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
1012  REAL :: var(:,:)
1013!-
1014  INTEGER :: jl, jj, ji
1015  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1016  LOGICAL :: l_dbg
1017!---------------------------------------------------------------------
1018  CALL ipsldbg (old_status=l_dbg)
1019
1020  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1021    IF (l_dbg) WRITE(ipslout,*) &
1022      "flinget_r2d : allocate buff_tmp for buff_sz = ",SIZE(var)
1023    ALLOCATE (buff_tmp(SIZE(var)))
1024  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1025    IF (l_dbg) WRITE(ipslout,*) &
1026      "flinget_r2d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1027    DEALLOCATE (buff_tmp)
1028    ALLOCATE (buff_tmp(SIZE(var)))
1029  ENDIF
1030!-
1031  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1032                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
1033!-
1034  jl=0
1035  DO jj=1,SIZE(var,2)
1036    DO ji=1,SIZE(var,1)
1037      jl=jl+1
1038      var(ji,jj) = buff_tmp(jl)
1039    ENDDO
1040  ENDDO
1041!-------------------------
1042END SUBROUTINE flinget_r2d
1043!-
1044!===
1045!-
1046SUBROUTINE flinget_r2d_zoom2d &
1047  (fid_in,varname,iim,jjm,llm,ttm, &
1048   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
1049!---------------------------------------------------------------------
1050  IMPLICIT NONE
1051!-
1052  INTEGER :: fid_in
1053  CHARACTER(LEN=*) :: varname
1054  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
1055  REAL :: var(:,:)
1056!-
1057  INTEGER :: jl, jj, ji
1058  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1059  LOGICAL :: l_dbg
1060!---------------------------------------------------------------------
1061  CALL ipsldbg (old_status=l_dbg)
1062
1063  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1064    IF (l_dbg) WRITE(ipslout,*) &
1065      "flinget_r2d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
1066    ALLOCATE (buff_tmp(SIZE(var)))
1067  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1068    IF (l_dbg) WRITE(ipslout,*) &
1069      "flinget_r2d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1070    DEALLOCATE (buff_tmp)
1071    ALLOCATE (buff_tmp(SIZE(var)))
1072  ENDIF
1073!-
1074  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1075                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
1076!-
1077  jl=0
1078  DO jj=1,SIZE(var,2)
1079    DO ji=1,SIZE(var,1)
1080      jl=jl+1
1081      var(ji,jj) = buff_tmp(jl)
1082    ENDDO
1083  ENDDO
1084!--------------------------------
1085END SUBROUTINE flinget_r2d_zoom2d
1086!-
1087!===
1088!-
1089SUBROUTINE flinget_r3d &
1090  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
1091!---------------------------------------------------------------------
1092  IMPLICIT NONE
1093!-
1094  INTEGER :: fid_in
1095  CHARACTER(LEN=*) :: varname
1096  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
1097  REAL :: var(:,:,:)
1098!-
1099  INTEGER :: jl, jk, jj, ji
1100  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1101  LOGICAL :: l_dbg
1102!---------------------------------------------------------------------
1103  CALL ipsldbg (old_status=l_dbg)
1104
1105  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1106    IF (l_dbg) WRITE(ipslout,*) &
1107      "flinget_r3d : allocate buff_tmp for buff_sz = ",SIZE(var)
1108    ALLOCATE (buff_tmp(SIZE(var)))
1109  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1110    IF (l_dbg) WRITE(ipslout,*) &
1111      "flinget_r3d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1112    DEALLOCATE (buff_tmp)
1113    ALLOCATE (buff_tmp(SIZE(var)))
1114  ENDIF
1115!-
1116  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1117                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
1118!-
1119  jl=0
1120  DO jk=1,SIZE(var,3)
1121    DO jj=1,SIZE(var,2)
1122      DO ji=1,SIZE(var,1)
1123        jl=jl+1
1124        var(ji,jj,jk) = buff_tmp(jl)
1125      ENDDO
1126    ENDDO
1127  ENDDO
1128!-------------------------
1129END SUBROUTINE flinget_r3d
1130!-
1131!===
1132!-
1133SUBROUTINE flinget_r3d_zoom2d &
1134  (fid_in,varname,iim,jjm,llm,ttm, &
1135   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
1136!---------------------------------------------------------------------
1137  IMPLICIT NONE
1138!-
1139  INTEGER :: fid_in
1140  CHARACTER(LEN=*) :: varname
1141  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
1142  REAL :: var(:,:,:)
1143!-
1144  INTEGER :: jl, jk, jj, ji
1145  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1146  LOGICAL :: l_dbg
1147!---------------------------------------------------------------------
1148  CALL ipsldbg (old_status=l_dbg)
1149
1150  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1151    IF (l_dbg) WRITE(ipslout,*) &
1152      "flinget_r3d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
1153    ALLOCATE (buff_tmp(SIZE(var)))
1154  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1155    IF (l_dbg) WRITE(ipslout,*) &
1156      "flinget_r3d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1157    DEALLOCATE (buff_tmp)
1158    ALLOCATE (buff_tmp(SIZE(var)))
1159  ENDIF
1160!-
1161  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1162                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
1163!-
1164  jl=0
1165  DO jk=1,SIZE(var,3)
1166    DO jj=1,SIZE(var,2)
1167      DO ji=1,SIZE(var,1)
1168        jl=jl+1
1169        var(ji,jj,jk) = buff_tmp(jl)
1170      ENDDO
1171    ENDDO
1172  ENDDO
1173!--------------------------------
1174END SUBROUTINE flinget_r3d_zoom2d
1175!-
1176!===
1177!-
1178SUBROUTINE flinget_r4d &
1179  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
1180!---------------------------------------------------------------------
1181  IMPLICIT NONE
1182!-
1183  INTEGER :: fid_in
1184  CHARACTER(LEN=*) :: varname
1185  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
1186  REAL :: var(:,:,:,:)
1187!-
1188  INTEGER :: jl, jk, jj, ji, jm
1189  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1190  LOGICAL :: l_dbg
1191!---------------------------------------------------------------------
1192  CALL ipsldbg (old_status=l_dbg)
1193
1194  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1195    IF (l_dbg) WRITE(ipslout,*) &
1196      "flinget_r4d : allocate buff_tmp for buff_sz = ",SIZE(var)
1197    ALLOCATE (buff_tmp(SIZE(var)))
1198  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1199    IF (l_dbg) WRITE(ipslout,*) &
1200      "flinget_r4d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1201    DEALLOCATE (buff_tmp)
1202    ALLOCATE (buff_tmp(SIZE(var)))
1203  ENDIF
1204!-
1205  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1206                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
1207!-
1208  jl=0
1209  DO jm=1,SIZE(var,4)
1210    DO jk=1,SIZE(var,3)
1211      DO jj=1,SIZE(var,2)
1212        DO ji=1,SIZE(var,1)
1213          jl=jl+1
1214          var(ji,jj,jk,jm) = buff_tmp(jl)
1215        ENDDO
1216      ENDDO
1217    ENDDO
1218  ENDDO
1219!-------------------------
1220END SUBROUTINE flinget_r4d
1221!-
1222!===
1223!-
1224SUBROUTINE flinget_r4d_zoom2d &
1225  (fid_in,varname,iim,jjm,llm,ttm, &
1226   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
1227!---------------------------------------------------------------------
1228  IMPLICIT NONE
1229!-
1230  INTEGER :: fid_in
1231  CHARACTER(LEN=*) :: varname
1232  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
1233  REAL :: var(:,:,:,:)
1234!-
1235  INTEGER :: jl, jk, jj, ji, jm
1236  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
1237  LOGICAL :: l_dbg
1238!---------------------------------------------------------------------
1239  CALL ipsldbg (old_status=l_dbg)
1240
1241  IF (.NOT.ALLOCATED(buff_tmp)) THEN
1242    IF (l_dbg) WRITE(ipslout,*) &
1243      "flinget_r4d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
1244    ALLOCATE (buff_tmp(SIZE(var)))
1245  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
1246    IF (l_dbg) WRITE(ipslout,*) &
1247      "flinget_r4d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
1248    DEALLOCATE (buff_tmp)
1249    ALLOCATE (buff_tmp(SIZE(var)))
1250  ENDIF
1251!-
1252  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
1253                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
1254!-
1255  jl=0
1256  DO jm=1,SIZE(var,4)
1257    DO jk=1,SIZE(var,3)
1258      DO jj=1,SIZE(var,2)
1259        DO ji=1,SIZE(var,1)
1260          jl=jl+1
1261          var(ji,jj,jk,jm) = buff_tmp(jl)
1262        ENDDO
1263      ENDDO
1264    ENDDO
1265  ENDDO
1266!--------------------------------
1267END SUBROUTINE flinget_r4d_zoom2d
1268!-
1269!===
1270!-
1271SUBROUTINE flinget_mat &
1272  (fid_in, varname, iim, jjm, llm, ttm, itau_dep, &
1273   itau_fin, iideb, iilen, jjdeb, jjlen, var)
1274!---------------------------------------------------------------------
1275!- This subroutine will read the variable named varname from
1276!- the file previously opened by flinopen and identified by fid
1277!-
1278!- It is checked that the dimensions of the variable to be read
1279!- correspond to what the user requested when he specified
1280!- iim, jjm and llm. The only exception which is allowed is
1281!- for compressed data where the horizontal grid is not expected
1282!- to be iim x jjm.
1283!-
1284!- If variable is of size zero a global attribute is read.
1285!- This global attribute will be of type real
1286!-
1287!- INPUT
1288!-
1289!- fid      : File ID returned by flinopen
1290!- varname  : Name of the variable to be read from the file
1291!- iim      : | These three variables give the size of the variables
1292!- jjm      : | to be read. It will be verified that the variables
1293!- llm      : | fits in there.
1294!- ttm      : |
1295!- itau_dep : Time step at which we will start to read
1296!- itau_fin : Time step until which we are going to read
1297!-            For the moment this is done on indexes
1298!-            but it should be in the physical space.
1299!-            If there is no time-axis in the file then use a
1300!-            itau_fin < itau_dep, this will tell flinget not to
1301!-            expect a time-axis in the file.
1302!- iideb    : index i for zoom
1303!- iilen    : length of zoom
1304!- jjdeb    : index j for zoom
1305!- jjlen    : length of zoom
1306!-
1307!- OUTPUT
1308!-
1309!- var      : array that will contain the data
1310!---------------------------------------------------------------------
1311  IMPLICIT NONE
1312!-
1313! ARGUMENTS
1314!-
1315  INTEGER, INTENT(IN) :: fid_in
1316  CHARACTER(LEN=*), INTENT(IN) :: varname
1317  INTEGER, INTENT(IN) :: iim, jjm, llm, ttm
1318  INTEGER, INTENT(IN) :: itau_dep, itau_fin, iideb, iilen, jjdeb, jjlen
1319  REAL, INTENT(OUT) :: var(:)
1320!-
1321! LOCAL
1322!-
1323  INTEGER :: iret, fid
1324  INTEGER :: vid, cvid, clen
1325  CHARACTER(LEN=70) :: str1
1326  CHARACTER(LEN=250) :: att_n, tmp_n
1327  CHARACTER(LEN=5) :: axs_l
1328  INTEGER :: tmp_i
1329  REAL,SAVE :: mis_v=0.
1330  REAL :: tmp_r
1331  INTEGER :: ndims, x_typ, nb_atts
1332  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids
1333  INTEGER :: i, nvars, i2d, cnd
1334  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: var_tmp
1335  INTEGER :: itau_len
1336  LOGICAL :: uncompress = .FALSE.
1337  INTEGER :: il, ip, i2p, it
1338  !-
1339  LOGICAL :: l_dbg
1340!---------------------------------------------------------------------
1341  CALL ipsldbg (old_status=l_dbg)
1342  !-
1343  fid = ncids(fid_in)
1344!-
1345  IF (l_dbg) THEN
1346    WRITE(ipslout,*) &
1347    'flinget_mat : fid_in, fid, varname :', fid_in, fid, TRIM(varname)
1348    WRITE(ipslout,*) &
1349    'flinget_mat : iim, jjm, llm, ttm, itau_dep, itau_fin :', &
1350    iim, jjm, llm, ttm, itau_dep, itau_fin
1351    WRITE(ipslout,*) &
1352    'flinget_mat : iideb, iilen, jjdeb, jjlen :', &
1353    iideb, iilen, jjdeb, jjlen
1354  ENDIF
1355!-
1356  uncompress = .FALSE.
1357!-
1358! 1.0 We get first all the details on this variable from the file
1359!-
1360  nvars = ncnbva(fid_in)
1361!-
1362  vid = -1
1363  iret = NF90_INQ_VARID (fid, varname, vid)
1364!-
1365  IF (vid < 0 .OR. iret /= NF90_NOERR) THEN
1366    CALL histerr (3,'flinget', &
1367      'Variable '//TRIM(varname)//' not found in file',' ',' ')
1368  ENDIF
1369!-
1370  iret = NF90_INQUIRE_VARIABLE (fid, vid, &
1371           ndims=ndims, dimids=dimids, nAtts=nb_atts)
1372  IF (l_dbg) THEN
1373    WRITE(ipslout,*) &
1374    'flinget_mat : fid, vid :', fid, vid
1375    WRITE(ipslout,*) &
1376    'flinget_mat : ndims, dimids(1:ndims), nb_atts :', &
1377    ndims, dimids(1:ndims), nb_atts
1378  ENDIF
1379!-
1380  w_dim(:) = 0
1381  DO i=1,ndims
1382    iret  = NF90_INQUIRE_DIMENSION (fid, dimids(i), len=w_dim(i))
1383  ENDDO
1384  IF (l_dbg) WRITE(ipslout,*) &
1385    'flinget_mat : w_dim :', w_dim(1:ndims)
1386!-
1387  mis_v = 0.0; axs_l = ' ';
1388!-
1389  IF (nb_atts > 0) THEN
1390     IF (l_dbg) THEN
1391      WRITE(ipslout,*) 'flinget_mat : attributes for variable :'
1392    ENDIF
1393  ENDIF
1394  DO i=1,nb_atts
1395    iret = NF90_INQ_ATTNAME (fid, vid, i, att_n)
1396    iret = NF90_INQUIRE_ATTRIBUTE (fid, vid, att_n, xtype=x_typ)
1397    CALL strlowercase (att_n)
1398    IF      (    (x_typ == NF90_INT).OR.(x_typ == NF90_SHORT) &
1399             .OR.(x_typ == NF90_BYTE) ) THEN
1400      iret = NF90_GET_ATT (fid, vid, att_n, tmp_i)
1401        IF (l_dbg) THEN
1402        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',tmp_i
1403      ENDIF
1404    ELSE IF ( (x_typ == NF90_FLOAT).OR.(x_typ == NF90_DOUBLE) ) THEN
1405      iret = NF90_GET_ATT (fid, vid, att_n, tmp_r)
1406        IF (l_dbg) THEN
1407        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',tmp_r
1408      ENDIF
1409      IF (index(att_n,'missing_value') > 0) THEN
1410        mis_v = tmp_r
1411      ENDIF
1412    ELSE
1413      tmp_n = ''
1414      iret = NF90_GET_ATT (fid, vid, att_n, tmp_n)
1415        IF (l_dbg) THEN
1416        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',TRIM(tmp_n)
1417      ENDIF
1418      IF (index(att_n,'axis') > 0) THEN
1419        axs_l = tmp_n
1420      ENDIF
1421    ENDIF
1422  ENDDO
1423!?
1424!!!!!!!!!! We will need a verification on the type of the variable
1425!?
1426!-
1427! 2.0 The dimensions are analysed to determine what is to be read
1428!-
1429! 2.1 the longitudes
1430!-
1431  IF ( w_dim(1) /= iim .OR. w_dim(2) /= jjm) THEN
1432!---
1433!-- There is a possibility that we have to deal with a compressed axis !
1434!---
1435    iret = NF90_INQUIRE_DIMENSION (fid, dimids(1), &
1436             name=tmp_n, len=clen)
1437    iret = NF90_INQ_VARID (fid, tmp_n, cvid)
1438!---
1439    IF (l_dbg) WRITE(ipslout,*) &
1440      'Dimname, iret , NF90_NOERR : ',TRIM(tmp_n),iret,NF90_NOERR
1441!---
1442!-- If we have an axis which has the same name
1443!-- as the dimension we can see if it is compressed
1444!---
1445!-- TODO TODO for zoom2d
1446!---
1447    IF (iret == NF90_NOERR) THEN
1448      iret = NF90_GET_ATT (fid, cvid, 'compress', str1)
1449!-----
1450      IF (iret == NF90_NOERR) THEN
1451        iret = NF90_INQUIRE_VARIABLE (fid,cvid,xtype=x_typ,ndims=cnd)
1452!-------
1453        IF ( cnd /= 1 .AND. x_typ /= NF90_INT) THEN
1454          CALL histerr (3,'flinget', &
1455            'Variable '//TRIM(tmp_n)//' can not be a compressed axis', &
1456            'Either it has too many dimensions'// &
1457            ' or it is not of type integer', ' ')
1458        ELSE
1459!---------
1460!-------- Let us see if we already have that index table
1461!---------
1462          IF (    (cind_len /= clen).OR.(cind_vid /= cvid) &
1463              .OR.(cind_fid /= fid) ) THEN
1464            IF (ALLOCATED(cindex))   DEALLOCATE(cindex)
1465            ALLOCATE(cindex(clen))
1466            cind_len = clen
1467            cind_vid = cvid
1468            cind_fid = fid
1469            iret = NF90_GET_VAR (fid, cvid, cindex)
1470          ENDIF
1471!---------
1472!-------- In any case we need to set the slab of data to be read
1473!---------
1474          uncompress = .TRUE.
1475          w_sta(1) = 1
1476          w_len(1) = clen
1477          i2d = 1
1478        ENDIF
1479      ELSE
1480        str1 = 'The horizontal dimensions of '//varname
1481        CALL histerr (3,'flinget',str1, &
1482          'is not compressed and does not'// &
1483          ' correspond to the requested size',' ')
1484      ENDIF
1485    ELSE
1486      IF (w_dim(1) /= iim) THEN
1487        str1 = 'The longitude dimension of '//varname
1488        CALL histerr (3,'flinget',str1, &
1489          'in the file is not equal to the dimension', &
1490          'that should be read')
1491      ENDIF
1492      IF (w_dim(2) /= jjm) THEN
1493        str1 = 'The latitude dimension of '//varname
1494        CALL histerr (3,'flinget',str1, &
1495          'in the file is not equal to the dimension', &
1496          'that should be read')
1497      ENDIF
1498    ENDIF
1499  ELSE
1500    w_sta(1:2) = (/ iideb, jjdeb /)
1501    w_len(1:2) = (/ iilen, jjlen /)
1502    i2d = 2
1503  ENDIF
1504!-
1505! 2.3 Now the difficult part, the 3rd dimension which can be
1506! time or levels.
1507!-
1508! Priority is given to the time axis if only three axes are present.
1509!-
1510  IF (ndims > i2d) THEN
1511!---
1512!-- 2.3.1 We have a vertical axis
1513!---
1514    IF (llm == 1 .AND. ndims == i2d+2 .OR. llm == w_dim(i2d+1)) THEN
1515!-----
1516      IF (w_dim(i2d+1) /= llm) THEN
1517        CALL histerr (3,'flinget', &
1518          'The vertical dimension of '//varname, &
1519          'in the file is not equal to the dimension', &
1520          'that should be read')
1521      ELSE
1522        w_sta(i2d+1) = 1
1523        IF (llm > 0) THEN
1524          w_len(i2d+1) = llm
1525        ELSE
1526          w_len(i2d+1) = w_sta(i2d+1)
1527        ENDIF
1528      ENDIF
1529!-----
1530      IF ((itau_fin-itau_dep) >= 0) THEN
1531        IF      (ndims /= i2d+2) THEN
1532          CALL histerr (3,'flinget', &
1533            'You attempt to read a time slab', &
1534            'but there is no time axis on this variable', varname)
1535        ELSE IF ((itau_fin - itau_dep) <= w_dim(i2d+2)) THEN
1536          w_sta(i2d+2) = itau_dep
1537          w_len(i2d+2) = itau_fin-itau_dep+1
1538        ELSE
1539          CALL histerr (3,'flinget', &
1540            'The time step you try to read is not', &
1541            'in the file (1)', varname)
1542        ENDIF
1543      ELSE IF (ndims == i2d+2 .AND. w_dim(i2d+2) > 1) THEN
1544        CALL histerr (3,'flinget', &
1545          'There is a time axis in the file but no', &
1546          'time step give in the call', varname)
1547      ELSE
1548        w_sta(i2d+2) = 1
1549        w_len(i2d+2) = 1
1550      ENDIF
1551    ELSE
1552!-----
1553!---- 2.3.2 We do not have any vertical axis
1554!-----
1555      IF (ndims == i2d+2) THEN
1556        CALL histerr (3,'flinget', &
1557          'The file contains 4 dimensions', &
1558          'but only 3 are requestes for variable ', varname)
1559      ENDIF
1560      IF ((itau_fin-itau_dep) >= 0) THEN
1561        IF (ndims == i2d+1) THEN
1562          IF ((itau_fin-itau_dep) < w_dim(i2d+1) ) THEN
1563            w_sta(i2d+1) = itau_dep
1564            w_len(i2d+1) = itau_fin-itau_dep+1
1565          ELSE
1566            CALL histerr (3,'flinget', &
1567              'The time step you try to read is not', &
1568              'in the file (2)', varname)
1569          ENDIF
1570        ELSE
1571          CALL histerr (3,'flinget', &
1572            'From your input you sould have 3 dimensions', &
1573            'in the file but there are 4', varname)
1574        ENDIF
1575      ELSE
1576        IF (ndims == i2d+1 .AND. w_dim(i2d+1) > 1) THEN
1577          CALL histerr (3,'flinget', &
1578            'There is a time axis in the file but no', &
1579            'time step given in the call', varname)
1580        ELSE
1581          w_sta(i2d+1) = 1
1582          w_len(i2d+1) = 1
1583        ENDIF
1584      ENDIF
1585    ENDIF
1586  ELSE
1587!---
1588!-- 2.3.3 We do not have any vertical axis
1589!---
1590    w_sta(i2d+1:i2d+2) = (/ 0, 0 /)
1591    w_len(i2d+1:i2d+2) = (/ 0, 0 /)
1592  ENDIF
1593!-
1594! 3.0 Reading the data
1595!-
1596  IF (l_dbg) WRITE(ipslout,*) &
1597    'flinget_mat 3.0 : ', uncompress, w_sta, w_len
1598!---
1599  var(:) = mis_v
1600  IF (uncompress) THEN
1601!---
1602    IF (ALLOCATED(var_tmp)) THEN
1603      IF (SIZE(var_tmp) < PRODUCT(w_len(:),mask=(w_len>1))) THEN
1604         DEALLOCATE(var_tmp)
1605         ALLOCATE(var_tmp(PRODUCT(w_len(:),mask=(w_len>1))))
1606      ENDIF
1607    ELSE
1608      ALLOCATE(var_tmp(PRODUCT(w_len(:),mask=(w_len>1))))
1609    ENDIF
1610!---
1611    iret = NF90_GET_VAR (fid, vid, var_tmp, &
1612             start=w_sta(:), count=w_len(:))
1613!---
1614    itau_len=itau_fin-itau_dep+1
1615    IF (l_dbg) WRITE(ipslout,*) 'flinget_mat 3.0 : clen, itau_len ',clen,itau_len
1616    var(:) = mis_v
1617    IF (itau_len > 0) THEN
1618       DO it=1,itau_len
1619          DO il=1,clen
1620             ip = il + (it-1)*clen
1621             i2p = cindex(il)+(it-1)*iim*jjm
1622             var(i2p) = var_tmp(ip)
1623          ENDDO
1624       ENDDO
1625    ELSE
1626       var(cindex(:)) = var_tmp(:)
1627    ENDIF
1628!---
1629  ELSE
1630    iret = NF90_GET_VAR (fid, vid, var, &
1631             start=w_sta(:), count=w_len(:))
1632  ENDIF
1633!-
1634  IF (l_dbg) WRITE(ipslout,*) 'flinget_mat 3.1 : ',NF90_STRERROR (iret)
1635!--------------------------
1636END  SUBROUTINE flinget_mat
1637!-
1638!===
1639!-
1640SUBROUTINE flinget_scal &
1641  (fid_in, varname, iim, jjm, llm, ttm, itau_dep, itau_fin, var)
1642!---------------------------------------------------------------------
1643!- This subroutine will read the variable named varname from
1644!- the file previously opened by flinopen and identified by fid
1645!-
1646!- If variable is of size zero a global attribute is read. This
1647!- global attribute will be of type real
1648!-
1649!- INPUT
1650!-
1651!- fid      : File ID returned by flinopen
1652!- varname  : Name of the variable to be read from the file
1653!- iim      : | These three variables give the size of the variables
1654!- jjm      : | to be read. It will be verified that the variables
1655!- llm      : | fits in there.
1656!- ttm      : |
1657!- itau_dep : Time step at which we will start to read
1658!- itau_fin : Time step until which we are going to read
1659!-           For the moment this is done on indeces but it should be
1660!-           in the physical space
1661!-           If there is no time-axis in the file then use a
1662!-           itau_fin < itau_dep, this will tell flinget not to
1663!-           expect a time-axis in the file.
1664!-
1665!- OUTPUT
1666!-
1667!- var      : scalar that will contain the data
1668!---------------------------------------------------------------------
1669  IMPLICIT NONE
1670!-
1671! ARGUMENTS
1672!-
1673  INTEGER :: fid_in
1674  CHARACTER(LEN=*) :: varname
1675  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
1676  REAL :: var
1677!-
1678! LOCAL
1679!-
1680  INTEGER :: iret, fid
1681!-
1682  LOGICAL :: l_dbg
1683!---------------------------------------------------------------------
1684  CALL ipsldbg (old_status=l_dbg)
1685
1686  IF (l_dbg) THEN
1687    WRITE (*,*) 'flinget_scal in file with id ',fid_in
1688  ENDIF
1689!-
1690  fid = ncids(fid_in)
1691!-
1692! 1.0 Reading a global attribute
1693!-
1694  iret = NF90_GET_ATT (fid, NF90_GLOBAL, varname, var)
1695!---------------------------
1696END  SUBROUTINE flinget_scal
1697!-
1698!===
1699!-
1700SUBROUTINE flinfindcood (fid_in, axtype, vid, ndim)
1701!---------------------------------------------------------------------
1702!- This subroutine explores the file in order to find
1703!- the coordinate according to a number of rules
1704!---------------------------------------------------------------------
1705  IMPLICIT NONE
1706!-
1707! ARGUMENTS
1708!-
1709  INTEGER :: fid_in, vid, ndim
1710  CHARACTER(LEN=3) :: axtype
1711!-
1712! LOCAL
1713!-
1714  INTEGER :: iv, iret, dimnb
1715  CHARACTER(LEN=40) :: dimname, dimuni1, dimuni2, dimuni3
1716  CHARACTER(LEN=80) :: str1
1717  LOGICAL :: found_rule = .FALSE.
1718!---------------------------------------------------------------------
1719  vid = -1
1720!-
1721! Make sure all strings are invalid
1722!-
1723  dimname = '?-?'
1724  dimuni1 = '?-?'
1725  dimuni2 = '?-?'
1726  dimuni3 = '?-?'
1727!-
1728! First rule : we look for the correct units
1729! lon : east
1730! lat : north
1731! We make an exact check as it would be too easy to mistake
1732! some units by just comparing the substrings.
1733!-
1734  SELECTCASE(axtype)
1735  CASE ('lon')
1736    dimuni1 = 'degree_e'
1737    dimuni2 = 'degrees_e'
1738    found_rule = .TRUE.
1739  CASE('lat')
1740    dimuni1 = 'degree_n'
1741    dimuni2 = 'degrees_n'
1742    found_rule = .TRUE.
1743  CASE('lev')
1744    dimuni1 = 'm'
1745    dimuni2 = 'km'
1746    dimuni3 = 'hpa'
1747    found_rule = .TRUE.
1748  CASE DEFAULT
1749    found_rule = .FALSE.
1750  END SELECT
1751!-
1752  IF (found_rule) THEN
1753    iv = 0
1754    DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
1755      iv = iv+1
1756      str1 = ''
1757      iret = NF90_GET_ATT (ncids(fid_in), iv, 'units', str1)
1758      IF (iret == NF90_NOERR) THEN
1759        CALL strlowercase (str1)
1760        IF (    (INDEX(str1, TRIM(dimuni1)) == 1) &
1761            .OR.(INDEX(str1, TRIM(dimuni2)) == 1) &
1762            .OR.(INDEX(str1, TRIM(dimuni3)) == 1) ) THEN
1763          vid = iv
1764          iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, ndims=ndim)
1765        ENDIF
1766      ENDIF
1767    ENDDO
1768  ENDIF
1769!-
1770! Second rule : we find specific names :
1771! lon : nav_lon
1772! lat : nav_lat
1773! Here we can check if we find the substring as the
1774! names are more specific.
1775!-
1776  SELECTCASE(axtype)
1777  CASE ('lon')
1778    dimname = 'nav_lon lon longitude'
1779    found_rule = .TRUE.
1780  CASE('lat')
1781    dimname = 'nav_lat lat latitude'
1782    found_rule = .TRUE.
1783  CASE('lev')
1784    dimname = 'plev level depth deptht'
1785    found_rule = .TRUE.
1786  CASE DEFAULT
1787    found_rule = .FALSE.
1788  END SELECT
1789!-
1790  IF (found_rule) THEN
1791    iv = 0
1792    DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
1793      iv = iv+1
1794      str1=''
1795      iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, &
1796                                    name=str1, ndims=ndim)
1797      IF (INDEX(dimname,TRIM(str1)) >= 1) THEN
1798        vid = iv
1799      ENDIF
1800    ENDDO
1801  ENDIF
1802!-
1803! Third rule : we find a variable with the same name as the dimension
1804! lon = 1
1805! lat = 2
1806! lev = 3
1807!-
1808  IF (vid < 0) THEN
1809    SELECTCASE(axtype)
1810    CASE ('lon')
1811      dimnb = 1
1812      found_rule = .TRUE.
1813    CASE('lat')
1814      dimnb = 2
1815      found_rule = .TRUE.
1816    CASE('lev')
1817      dimnb = 3
1818      found_rule = .TRUE.
1819    CASE DEFAULT
1820      found_rule = .FALSE.
1821    END SELECT
1822!---
1823    IF (found_rule) THEN
1824      iret = NF90_INQUIRE_DIMENSION (ncids(fid_in), dimnb, name=dimname)
1825      iv = 0
1826      DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
1827        iv = iv+1
1828        str1=''
1829        iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, &
1830                                      name=str1, ndims=ndim)
1831        IF (INDEX(dimname,TRIM(str1)) == 1) THEN
1832          vid = iv
1833        ENDIF
1834      ENDDO
1835    ENDIF
1836  ENDIF
1837!-
1838! Stop the program if no coordinate was found
1839!-
1840  IF (vid < 0) THEN
1841    CALL histerr (3,'flinfindcood', &
1842           'No coordinate axis was found in the file', &
1843           'The data in this file can not be used', axtype)
1844  ENDIF
1845!--------------------------
1846END SUBROUTINE flinfindcood
1847!-
1848!===
1849!-
1850SUBROUTINE flinclo (fid_in)
1851!---------------------------------------------------------------------
1852  IMPLICIT NONE
1853!-
1854  INTEGER :: fid_in
1855!-
1856  INTEGER :: iret
1857!---------------------------------------------------------------------
1858  iret = NF90_CLOSE (ncids(fid_in))
1859  ncfileopen(fid_in) = .FALSE.
1860!---------------------
1861END SUBROUTINE flinclo
1862!-
1863!===
1864!-
1865SUBROUTINE flinquery_var(fid_in, varname, exists)
1866!---------------------------------------------------------------------
1867!- Queries the existance of a variable in the file.
1868!---------------------------------------------------------------------
1869  IMPLICIT NONE
1870!-
1871  INTEGER :: fid_in
1872  CHARACTER(LEN=*) varname
1873  LOGICAL :: exists
1874!-
1875  INTEGER :: iret, fid, vid
1876!---------------------------------------------------------------------
1877  fid = ncids(fid_in)
1878  vid = -1
1879  iret = NF90_INQ_VARID (fid, varname, vid)
1880!-
1881  exists = ( (vid >= 0).AND.(iret == NF90_NOERR) )
1882!---------------------------
1883END SUBROUTINE flinquery_var
1884!-
1885!===
1886!-
1887SUBROUTINE flininspect (fid_in)
1888!---------------------------------------------------------------------
1889  IMPLICIT NONE
1890!-
1891! fid : File id to inspect
1892!-
1893  INTEGER :: fid_in
1894!-
1895!- LOCAL
1896!-
1897  INTEGER :: iim, jjm, llm, ttm, fid_out
1898  INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim
1899  INTEGER :: iv, in, lll
1900  INTEGER :: xid, yid, zid, tid
1901  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid
1902  CHARACTER(LEN=80) :: name
1903  CHARACTER(LEN=30) :: axname
1904!---------------------------------------------------------------------
1905  fid = ncids(fid_in)
1906!-
1907  iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, &
1908                       nAttributes=nb_atts, unlimitedDimId=id_unlim)
1909!-
1910  WRITE (*,*) 'IOIPSL ID                   : ',fid_in
1911  WRITE (*,*) 'NetCDF ID                   : ',fid
1912  WRITE (*,*) 'Number of dimensions        : ',ndims
1913  WRITE (*,*) 'Number of variables         : ',nvars
1914  WRITE (*,*) 'Number of global attributes : ',nb_atts
1915  WRITE (*,*) 'ID unlimited                : ',id_unlim
1916!-
1917  xid = -1; iim = 0;
1918  yid = -1; jjm = 0;
1919  zid = -1; llm = 0;
1920  tid = -1; ttm = 0;
1921!-
1922  DO iv=1,ndims
1923!---
1924    iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll)
1925    CALL strlowercase (axname)
1926    axname = ADJUSTL(axname)
1927!---
1928    WRITE (*,*) 'Dimension number : ',iv
1929    WRITE (*,*) 'Dimension name   : ',TRIM(axname)
1930!---
1931    IF      (    (INDEX(axname,'x') == 1) &
1932             .OR.(INDEX(axname,'lon') == 1)) THEN
1933      xid = iv; iim = lll;
1934      WRITE (*,*) 'Dimension X size   : ',iim
1935    ELSE IF (    (INDEX(axname,'y') == 1) &
1936             .OR.(INDEX(axname,'lat') == 1)) THEN
1937      yid = iv; jjm = lll;
1938      WRITE (*,*) 'Dimension Y size   : ',jjm
1939    ELSE IF (    (INDEX(axname,'lev') == 1) &
1940             .OR.(INDEX(axname,'plev') == 1) &
1941             .OR.(INDEX(axname,'z') == 1) &
1942             .OR.(INDEX(axname,'depth') == 1)) THEN
1943      zid = iv; llm = lll;
1944      WRITE (*,*) 'Dimension Z size   : ',llm
1945    ELSE IF (    (INDEX(axname,'tstep') == 1) &
1946             .OR.(INDEX(axname,'time_counter') == 1)) THEN
1947!---- For the time we certainly need to allow for other names
1948      tid = iv; ttm = lll;
1949    ELSE IF (ndims == 1) THEN
1950!---- Nothing was found and ndims=1 then we have a vector of data
1951      xid = 1; iim = lll;
1952    ENDIF
1953!---
1954  ENDDO
1955!-
1956! Keep all this information
1957!-
1958  nbfiles = nbfiles+1
1959!-
1960  IF (nbfiles > nbfile_max) THEN
1961    CALL histerr(3,'flininspect', &
1962      'Too many files. Please increase nbfil_max', &
1963      'in program flincom.F90.',' ')
1964  ENDIF
1965!-
1966  ncids(nbfiles) = fid
1967  ncnbd(nbfiles) = ndims
1968!-
1969  ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /)
1970!-
1971  ncfunli(nbfiles) = id_unlim
1972  ncnba(nbfiles)   = nb_atts
1973  ncnbva(nbfiles)  = nvars
1974  ncfileopen(nbfiles) = .TRUE.
1975!-
1976  fid_out = nbfiles
1977!-
1978  DO in=1,nvars
1979    iret = NF90_INQUIRE_VARIABLE (fid, in, &
1980             name=name, ndims=ndims, dimids=idimid, nAtts=nb_atts)
1981    WRITE (*,*) 'Variable number  ------------ > ', in
1982    WRITE (*,*) 'Variable name        : ', TRIM(name)
1983    WRITE (*,*) 'Number of dimensions : ', ndims
1984    WRITE (*,*) 'Dimensions ID''s     : ', idimid(1:ndims)
1985    WRITE (*,*) 'Number of attributes : ', nb_atts
1986  ENDDO
1987!-------------------------
1988END SUBROUTINE flininspect
1989!-
1990!===
1991!-
1992END MODULE flincom
Note: See TracBrowser for help on using the repository browser.