source: IOIPSL/trunk/src/restcom.f90 @ 386

Last change on this file since 386 was 386, checked in by bellier, 16 years ago

Added CeCILL License information

  • Property svn:keywords set to Id
File size: 77.4 KB
Line 
1MODULE restcom
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!-
8USE netcdf
9!-
10USE errioipsl, ONLY : ipslerr
11USE stringop
12USE calendar
13USE mathelp
14USE fliocom,   ONLY : flio_dom_file,flio_dom_att
15!-
16IMPLICIT NONE
17!-
18PRIVATE
19!-
20PUBLIC :: &
21 &  restini, restget, restput, restclo, &
22 &  ioconf_setatt, ioget_vname, ioconf_expval, &
23 &  ioget_expval, ioget_vdim
24!-
25INTERFACE restput
26  MODULE PROCEDURE &
27 &  restput_r3d, restput_r2d, restput_r1d, &
28 &  restput_opp_r2d, restput_opp_r1d
29END INTERFACE
30!-
31INTERFACE restget
32  MODULE PROCEDURE &
33 &  restget_r3d,restget_r2d,restget_r1d, &
34 &  restget_opp_r2d,restget_opp_r1d
35END INTERFACE
36!-
37! We do not use allocatable arrays because these sizes are safe
38! and we do not know from start how many variables will be in
39! the out file.
40!-
41  INTEGER,PARAMETER :: &
42 &  max_var=500, max_file=50, max_dim=NF90_MAX_VAR_DIMS
43!-
44  CHARACTER(LEN=9),SAVE :: calend_str='unknown'
45!-
46! The IDs of the netCDF files are going in pairs.
47! The input one (netcdf_id(?,1)) and the output one (netcdf_id(?,2))
48!-
49  INTEGER,SAVE :: nb_fi = 0
50  INTEGER,DIMENSION(max_file,2),SAVE :: netcdf_id = -1
51!-
52! Description of the content of the 'in' files and the 'out' files.
53!   Number of variables   : nbvar_*
54!   Number of dimensions  : nbdim_*
55!   ID of the time axis   : tdimid_*
56!-
57  INTEGER,SAVE :: nbvar_in(max_file), nbvar_out(max_file)
58  INTEGER,SAVE :: tdimid_in(max_file), tdimid_out(max_file)
59!-
60! Variables for one or the other file
61!-
62! Number of dimensions in the input file               : nbdim_in
63! Number of variables read so far from the input file  : nbvar_read
64! Type of variable read from the input file            : vartyp_in
65!   (Could be used later to test if we have a restart file)
66!-
67  INTEGER,SAVE :: nbdim_in(max_file), nbvar_read(max_file)
68  INTEGER,SAVE :: vartyp_in(max_file, max_var)
69!-
70! Time step and time origine in the input file.
71!-
72  REAL,DIMENSION(max_file),SAVE :: deltat,timeorig
73!-
74! Description of the axes in the output file
75!-
76!   tstp_out  : Index on the tie axis currently beeing written
77!   itau_out  : Time step which is written on this index of the file
78!-
79  INTEGER,DIMENSION(max_file),SAVE :: tstp_out,itau_out
80!-
81! Description of the axes in the output file
82!-
83! For the ?ax_infs variable the following order is used :
84!   ?ax_infs (if,in,1) = size of axis
85!   ?ax_infs (if,in,2) = id of dimension
86! Number of x,y and z axes in the output file :
87!   ?ax_nb(if)
88!-
89  INTEGER,DIMENSION(max_file,max_dim,2),SAVE :: &
90 &  xax_infs,yax_infs,zax_infs
91  INTEGER,DIMENSION(max_file),SAVE :: &
92 &  xax_nb=0,yax_nb=0,zax_nb=0
93!-
94! Description of the time axes in the input and output files
95!-
96!   ID of the variable which contains the itaus :
97!     tind_varid_*
98!   ID of the variables which contains the seconds since date :
99!     tax_varid_*
100!   Size of the time axis in the input file :
101!     tax_size_in
102!-
103  INTEGER,SAVE :: tind_varid_in(max_file),  tax_varid_in(max_file), &
104 &                tind_varid_out(max_file), tax_varid_out(max_file)
105  INTEGER,SAVE :: tax_size_in(max_file)=1
106!-
107! The two time axes we have in the input file :
108!   t_index   : dates in itaus
109!               (thus the variable has a tstep_sec attribute)
110!   t_julian  : Julian days of the time axis
111!-
112  INTEGER,SAVE,ALLOCATABLE :: t_index(:,:)
113  REAL,SAVE,ALLOCATABLE :: t_julian(:,:)
114!-
115! Here we save a number of informations on the variables
116! in the files we are handling
117!-
118! Name of variables :                                    varname_*
119! ID of the variables :                                  varid_*
120! Number of dimensions of the variable :                 varnbdim_*
121! Dimensions which are used for the variable :           vardims_*
122! Number of attributes for a variables :                 varatt_*
123! A flag which markes the variables we have worked on :  touched_*
124!-
125  CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: &
126 &  varname_in,varname_out
127  INTEGER,DIMENSION(max_file,max_var),SAVE :: &
128 &  varid_in,varid_out,varnbdim_in,varatt_in
129  INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: &
130 &  vardims_in
131  LOGICAL,DIMENSION(max_file,max_var),SAVE :: &
132 &  touched_in,touched_out
133!-
134  CHARACTER(LEN=120),SAVE :: indchfun= 'scatter, fill, gather, coll'
135  REAL,PARAMETER :: missing_val=1.e20
136!                or HUGE(1.0) (maximum real number)
137!-
138! The default value we will use for variables
139! which are not present in the restart file
140!-
141  REAL,SAVE :: val_exp =  999999.
142  LOGICAL,SAVE :: lock_valexp = .FALSE.
143!-
144! Temporary variables in which we store the attributed which are going
145! to be given to a new variable which is going to be defined.
146!-
147  CHARACTER(LEN=80),SAVE :: rest_units='XXXXX',rest_lname='XXXXX'
148!-
149! For allocations
150!-
151  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp1,buff_tmp2
152!-
153!===
154CONTAINS
155!===
156!-
157SUBROUTINE restini &
158 & (fnamein,iim,jjm,lon,lat,llm,lev, &
159 &  fnameout,itau,date0,dt,fid,owrite_time_in,domain_id)
160!---------------------------------------------------------------------
161!- This subroutine sets up all the restart process.
162!- It will call the subroutine which opens the input
163!- and output files.
164!- The time step (itau), date of origine (date0) and time step are
165!- READ from the input file.
166!- A file ID, which is common to the input and output file is returned
167!-
168!- If fnamein = fnameout then the same file is used for the reading
169!- the restart conditions and writing the new restart.
170!-
171!- A special mode can be switched in with filename='NONE'.
172!- This means that no restart file is present.
173!- Usefull for creating the first restart file
174!- or to get elements in a file without creating an output file.
175!-
176!- A mode needs to be written in which itau, date0 and dt
177!- are given to the restart process and thus
178!- written into the output restart file.
179!-
180!- INPUT
181!-
182!- fnamein  : name of the file for the restart
183!- iim      : Dimension in x
184!- jjm      : Dimension in y
185!- lon      : Longitude in the x,y domain
186!- lat      : Latitude in the x,y domain
187!- llm      : Dimension in the vertical
188!- lev      : Positions of the levels
189!- fnameout :
190!-
191!- OUTPUT
192!-
193!- itau     : Time step of the restart file and at which the model
194!-            should restart
195!- date0    : Time at which itau = 0
196!- dt       : time step in seconds between two succesiv itaus
197!- fid      : File identification of the restart file
198!-
199!- Optional INPUT arguments
200!-
201!- owrite_time_in : logical  argument which allows to
202!-                  overwrite the time in the restart file
203!- domain_id      : Domain identifier
204!---------------------------------------------------------------------
205  IMPLICIT NONE
206!-
207  CHARACTER(LEN=*),INTENT(IN) :: fnamein,fnameout
208  INTEGER :: iim,jjm,llm,fid,itau
209  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
210  REAL :: date0,dt
211  LOGICAL,OPTIONAL :: owrite_time_in
212  INTEGER,INTENT(IN),OPTIONAL :: domain_id
213!-
214! LOCAL
215!-
216  INTEGER :: ncfid
217  REAL :: dt_tmp,date0_tmp
218  LOGICAL :: l_fi,l_fo,l_rw
219  LOGICAL :: overwrite_time
220  CHARACTER(LEN=120) :: fname
221  LOGICAL :: check = .FALSE.
222!---------------------------------------------------------------------
223!-
224! 0.0 Prepare the configuration before opening any files
225!-
226  IF (.NOT.PRESENT(owrite_time_in)) THEN
227    overwrite_time = .FALSE.
228  ELSE
229    overwrite_time = owrite_time_in
230  ENDIF
231!-
232  IF (check) THEN
233    WRITE(*,*) 'restini 0.0 : ',TRIM(fnamein),' , ',TRIM(fnameout)
234  ENDIF
235!-
236  nb_fi = nb_fi+1
237!-
238  IF (nb_fi > max_file) THEN
239    CALL ipslerr (3,'restini',&
240 &   'Too many restart files are used. The problem can be',&
241 &   'solved by increasing max_file in restcom.f90 ',&
242 &   'and recompiling ioipsl.')
243  ENDIF
244!-
245! 0.1 Define the open flags
246!-
247  l_fi = (TRIM(fnamein)  /= 'NONE')
248  l_fo = (TRIM(fnameout) /= 'NONE')
249  IF ((.NOT.l_fi).AND.(.NOT.l_fo)) THEN
250    CALL ipslerr (3,'restini',&
251 &   'Input and output file names are both to NONE.',&
252 &   'It is probably an error.','Verify your logic.')
253  ENDIF
254  l_rw = l_fi.AND.l_fo.AND.(TRIM(fnamein) == TRIM(fnameout))
255!-
256  IF (check) THEN
257    WRITE(*,*) 'restini 0.1 l_fi, l_fo, l_rw : ',l_fi,l_fo,l_rw
258  ENDIF
259!-
260! 1.0 Open the input file.
261!-
262  IF (l_fi) THEN
263!---
264    IF (check) WRITE(*,*) 'restini 1.0 : Open input file'
265!-- Add DOMAIN number and ".nc" suffix in file names if needed
266    fname = fnamein
267    CALL flio_dom_file (fname,domain_id)
268!-- Open the file
269    CALL restopenin (nb_fi,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid)
270    netcdf_id(nb_fi,1) = ncfid
271!---
272!-- 1.3 Extract the time information
273!---
274    IF (overwrite_time) THEN
275       date0_tmp = date0
276    ENDIF
277    CALL restsett (dt_tmp,date0_tmp,itau,overwrite_time)
278    IF (.NOT.overwrite_time) THEN
279      dt = dt_tmp
280      date0 = date0_tmp
281    ENDIF
282!---
283  ELSE
284!---
285!-- 2.0 The case of a missing restart file is dealt with
286!---
287    IF (check) WRITE(*,*) 'restini 2.0'
288!---
289    IF (     (ALL(MINLOC(lon(:iim,:jjm)) == MAXLOC(lon(:iim,:jjm)))) &
290        .AND.(iim > 1) ) THEN
291      CALL ipslerr (3,'restini',&
292        & 'For creating a restart file the longitudes of the',&
293        & 'grid need to be provided to restini. This ',&
294        & 'information is needed for the restart files')
295    ENDIF
296    IF (     (ALL(MINLOC(lat(:iim,:jjm)) == MAXLOC(lat(:iim,:jjm)))) &
297        .AND.(jjm > 1) ) THEN
298      CALL ipslerr (3,'restini',&
299        & 'For creating a restart file the latitudes of the',&
300        & 'grid need to be provided to restini. This ',&
301        & 'information is needed for the restart files')
302    ENDIF
303    IF (     (ALL(MINLOC(lev(:llm)) == MAXLOC(lev(:llm)))) &
304        .AND.(llm > 1) ) THEN
305      CALL ipslerr (3,'restini',&
306        & 'For creating a restart file the levels of the',&
307        & 'grid need to be provided to restini. This',&
308        & 'information is needed for the restart files')
309    ENDIF
310!---
311!-- 2.2 Allocate the time axes and write the inputed variables
312!---
313    tax_size_in(nb_fi) = 1
314    CALL rest_atim (check,'restini')
315    t_index(nb_fi,1) = itau
316    t_julian(nb_fi,1) = date0
317  ENDIF
318!-
319  IF (l_fo.AND.(.NOT.l_rw)) THEN
320!-- Add DOMAIN number and ".nc" suffix in file names if needed
321    fname = fnameout
322    CALL flio_dom_file (fname,domain_id)
323!-- Open the file
324    CALL restopenout &
325      (nb_fi,fname,iim,jjm,lon,lat,llm,lev,dt,date0,ncfid,domain_id)
326    netcdf_id(nb_fi,2) = ncfid
327  ELSE IF (l_fi.AND.l_fo) THEN
328    netcdf_id(nb_fi,2) = netcdf_id(nb_fi,1)
329    varname_out(nb_fi,:) = varname_in(nb_fi,:)
330    nbvar_out(nb_fi) = nbvar_in(nb_fi)
331    tind_varid_out(nb_fi) = tind_varid_in(nb_fi)
332    tax_varid_out(nb_fi) = tax_varid_in(nb_fi)
333    varid_out(nb_fi,:) = varid_in(nb_fi,:)
334    touched_out(nb_fi,:) = .TRUE.
335  ENDIF
336!-
337! 2.3 Set the calendar for the run.
338!     This should not produce any error message if
339!     This does not mean any change in calendar
340!     (to be modified in ioconf_calendar)
341!-
342  IF (check) THEN
343    WRITE(*,*) 'restini 2.3 : Configure calendar if needed : ', &
344                calend_str
345  ENDIF
346!-
347  IF (INDEX(calend_str,'unknown') < 1) THEN
348    CALL ioconf_calendar (calend_str)
349    IF (check) THEN
350      WRITE(*,*) 'restini 2.3b : new calendar : ',calend_str
351    ENDIF
352  ENDIF
353!-
354! Save some data in the module
355!-
356  deltat(nb_fi) = dt
357!-
358! Prepare the variables which will be returned
359!-
360  fid = nb_fi
361  IF (check) THEN
362    WRITE(*,*) 'SIZE of t_index :',SIZE(t_index), &
363               SIZE(t_index,dim=1),SIZE(t_index,dim=2)
364    WRITE(*,*) 't_index = ',t_index(fid,:)
365  ENDIF
366  itau = t_index(fid,1)
367!-
368  IF (check) WRITE(*,*) 'restini END'
369!---------------------
370END SUBROUTINE restini
371!===
372SUBROUTINE restopenin &
373  (fid,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid)
374!---------------------------------------------------------------------
375!- Opens the restart file and checks that it belongsd to the model.
376!- This means that the coordinates of the model are compared to the
377!- ones in the file.
378!-
379!- The number and name of variable in the file are exctracted. Also
380!- the time details.
381!---------------------------------------------------------------------
382  IMPLICIT NONE
383!-
384  INTEGER,INTENT(IN) :: fid,iim,jjm,llm
385  CHARACTER(LEN=*),INTENT(IN) :: fname
386  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
387  LOGICAL,INTENT(IN) :: l_rw
388  INTEGER,INTENT(OUT) :: ncfid
389!-
390! LOCAL
391!-
392  INTEGER,DIMENSION(max_dim) :: var_dims,dimlen
393  INTEGER :: nb_dim,nb_var,id_unl,id,iv
394  INTEGER :: iread,jread,lread,iret
395  INTEGER :: lon_vid,lat_vid
396  REAL :: lon_read(iim,jjm),lat_read(iim,jjm)
397  REAL :: lev_read(llm)
398  REAL :: mdlon,mdlat
399  CHARACTER(LEN=80) :: units
400  CHARACTER(LEN=NF90_max_name),DIMENSION(max_dim) :: dimname
401  LOGICAL :: check = .FALSE.
402!---------------------------------------------------------------------
403!-
404! If we reuse the same file for input and output
405! then we open it in write mode
406!-
407  IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF
408  iret = NF90_OPEN(fname,id,ncfid)
409  IF (iret /= NF90_NOERR) THEN
410    CALL ipslerr (3,'restopenin','Could not open file :',fname,' ')
411  ENDIF
412!-
413  IF (check) WRITE (*,*) "restopenin 0.0 ",TRIM(fname)
414  iret = NF90_INQUIRE(ncfid,nDimensions=nb_dim, &
415 &         nVariables=nb_var,unlimitedDimId=id_unl)
416  tdimid_in(fid) = id_unl
417!-
418  IF (nb_dim > max_dim) THEN
419    CALL ipslerr (3,'restopenin',&
420      & 'More dimensions present in file that can be store',&
421      & 'Please increase max_dim in the global variables ',&
422      & 'in restcom.F90')
423  ENDIF
424  IF (nb_var > max_var) THEN
425    CALL ipslerr (3,'restopenin',&
426      & 'More variables present in file that can be store',&
427      & 'Please increase max_var in the global variables ',&
428      & 'in restcom.F90')
429  ENDIF
430!-
431  nbvar_in(fid) = nb_var
432  nbdim_in(fid) = nb_dim
433  iread = -1; jread = -1; lread = -1;
434  DO id=1,nb_dim
435    iret = NF90_INQUIRE_DIMENSION(ncfid,id, &
436 &           len=dimlen(id),name=dimname(id))
437    IF (check) THEN
438      WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id))
439    ENDIF
440    IF      (TRIM(dimname(id)) == 'x') THEN
441      iread = dimlen(id)
442      IF (check) WRITE (*,*) "iread",iread
443    ELSE IF (TRIM(dimname(id)) == 'y') THEN
444      jread = dimlen(id)
445      IF (check) WRITE (*,*) "jread",jread
446    ELSE IF (TRIM(dimname(id)) == 'z') THEN
447      lread = dimlen(id)
448      IF (check) WRITE (*,*) "lread",lread
449    ENDIF
450  ENDDO
451!-
452  IF (id_unl > 0) THEN
453!---
454!-- 0.1 If we are going to add values to this file
455!--     we need to know where it ends
456!--     We also need to have all the dimensions in the file
457!---
458    IF (l_rw) THEN
459      tstp_out(fid) = dimlen(id_unl)
460      itau_out(fid) = -1
461      tdimid_out(fid) =  tdimid_in(fid)
462      IF (check) THEN
463        WRITE (*,*) &
464 &       "restopenin 0.0 unlimited axis dimname", &
465 &       dimname(id_unl),tstp_out(fid)
466      ENDIF
467!-----
468      xax_nb(fid) = 0
469      yax_nb(fid) = 0
470      zax_nb(fid) = 0
471!-----
472      DO id=1,nb_dim
473        IF      (dimname(id)(1:1) == 'x') THEN
474          xax_nb(fid) = xax_nb(fid)+1
475          xax_infs(fid,xax_nb(fid),1) = dimlen(id)
476          xax_infs(fid,xax_nb(fid),2) = id
477        ELSE IF (dimname(id)(1:1) == 'y') THEN
478          yax_nb(fid) = yax_nb(fid)+1
479          yax_infs(fid,yax_nb(fid),1) = dimlen(id)
480          yax_infs(fid,yax_nb(fid),2) = id
481        ELSE IF (dimname(id)(1:1) == 'z') THEN
482          zax_nb(fid) = zax_nb(fid)+1
483          zax_infs(fid,zax_nb(fid),1) = dimlen(id)
484          zax_infs(fid,zax_nb(fid),2) = id
485        ENDIF
486      ENDDO
487    ENDIF
488  ELSE
489!---
490!-- Still need to find a method for dealing with this
491!---
492!  CALL ipslerr (3,'restopenin',&
493!    & ' We do not deal yet with files without time axis.',' ',' ')
494  ENDIF
495!-
496! 1.0 First let us check that we have the righ restart file
497!-
498  IF ((iread /= iim).OR.(jread /= jjm).OR.(lread /= llm)) THEN
499    CALL ipslerr (3,'restopenin',&
500 &    'The grid of the restart file does not correspond',&
501 &    'to that of the model',' ')
502  ENDIF
503!-
504! 2.0 Get the list of variables
505!-
506  IF (check) WRITE(*,*) 'restopenin 1.2'
507!-
508  lat_vid = -1
509  lon_vid = -1
510  tind_varid_in(fid) = -1
511  tax_varid_in(fid) = -1
512!-
513  DO iv=1,nb_var
514!---
515    varid_in(fid,iv) = iv
516    var_dims(:) = 0
517    iret = NF90_INQUIRE_VARIABLE(ncfid,iv, &
518 &           name=varname_in(fid,iv),xtype=vartyp_in(fid,iv), &
519 &           ndims=varnbdim_in(fid,iv),dimids=var_dims, &
520 &           nAtts=varatt_in(fid,iv))
521!---
522    DO id=1,varnbdim_in(fid,iv)
523      iret = NF90_INQUIRE_DIMENSION &
524 &             (ncfid,var_dims(id),len=vardims_in(fid,iv,id))
525    ENDDO
526!---
527!-- 2.1 Read the units of the variable
528!---
529    units=''
530    iret = NF90_GET_ATT(ncfid,iv,'units',units)
531    CALL strlowercase (units)
532    CALL cmpblank (units)
533!---
534!-- 2.2 Catch the time variables
535!---
536    IF (varnbdim_in(fid,iv) == 1) THEN
537      IF (     (INDEX(units,'timesteps since') > 0) &
538          .AND.(tind_varid_in(fid) < 0) ) THEN
539        tind_varid_in(fid) = iv
540        tax_size_in(fid) = vardims_in(fid,iv,1)
541      ENDIF
542      IF (     (INDEX(units,'seconds since') > 0) &
543          .AND.(tax_varid_in(fid) < 0) ) THEN
544        tax_varid_in(fid) = iv
545        tax_size_in(fid) = vardims_in(fid,iv,1)
546      ENDIF
547    ENDIF
548!---
549!-- 2.3 Catch longitude and latitude variables
550!---
551    IF (INDEX(units,'degrees_nort') >= 1) THEN
552      lat_vid = iv
553    ENDIF
554    IF (INDEX(units,'degrees_east') >= 1) THEN
555      lon_vid = iv
556    ENDIF
557!---
558  ENDDO
559!-
560! 2.4 None of the variables was yet read
561!-
562  nbvar_read(fid) = 0
563  touched_in(fid,:) = .FALSE.
564!-
565! 3.0 Reading the coordinates from the input restart file
566!-
567  lon_read = missing_val
568  lat_read = missing_val
569!-
570  IF (lon_vid < 0 .OR. lat_vid < 0) THEN
571    CALL ipslerr (3,'restopenin',&
572      & ' No variables containing longitude or latitude were ',&
573      & ' found in the restart file.',' ')
574  ELSE
575    iret = NF90_GET_VAR(ncfid,lon_vid,lon_read)
576    iret = NF90_GET_VAR(ncfid,lat_vid,lat_read)
577!---
578    IF (  (ABS( MAXVAL(lon(:,:)) &
579 &             -MINVAL(lon(:,:))) < EPSILON(MAXVAL(lon(:,:)))) &
580 &   .AND.(ABS( MAXVAL(lat(:,:)) &
581 &             -MINVAL(lat(:,:))) < EPSILON(MAXVAL(lat(:,:)))) ) THEN
582!-----
583!---- 3.1 No longitude nor latitude are provided thus
584!---- they are taken from the restart file
585!-----
586      lon(:,:) = lon_read(:,:)
587      lat(:,:) = lat_read(:,:)
588    ELSE
589!-----
590!---- 3.2 We check that the longitudes and latitudes
591!----     in the file and the model are the same
592!-----
593      mdlon = MAXVAL(ABS(lon_read-lon))
594      mdlat = MAXVAL(ABS(lat_read-lat))
595!-----
596!---- We can not test against epsilon here as the longitude
597!---- can be stored at another precision in the netCDF file.
598!---- The test here does not need to be very precise.
599!-----
600      IF (mdlon > 1.e-4 .OR. mdlat > 1.e-4) THEN
601        CALL ipslerr (3,'restopenin',&
602          & ' The longitude or latitude found in the restart ',&
603          & ' file are not the same as the ones used in the model.',&
604          & ' ')
605      ENDIF
606    ENDIF
607  ENDIF
608!------------------------
609END SUBROUTINE restopenin
610!===
611SUBROUTINE restsett (timestep,date0,itau,owrite_time_in)
612!---------------------------------------------------------------------
613!- Here we get all the time information from the file.
614!-
615!- The time information can come in three forms :
616!- -global attributes which give the time origine and the
617!-  time step is taken from the input to restinit
618!- -A physical time exists and thus the julian date from the
619!-  input is used for positioning using the itau as input
620!- -A time-step axis exists and itau is positioned on it.
621!-
622!- What takes precedence : the model
623!-
624!- itau     : Time step of the model
625!-
626!- Optional INPUT arguments
627!-
628!- owrite_time_in : logical  argument which allows to
629!-                  overwrite the time in the restart file
630!---------------------------------------------------------------------
631  IMPLICIT NONE
632!-
633  REAL :: date0,timestep
634  INTEGER :: itau
635  LOGICAL,OPTIONAL :: owrite_time_in
636!-
637! LOCAL
638!-
639  INTEGER :: ncfid,iret,it,iax,iv
640  CHARACTER(LEN=80) :: itau_orig,tax_orig,calendar
641  CHARACTER(LEN=9) :: tmp_cal
642  INTEGER :: year0,month0,day0,hours0,minutes0,seci
643  REAL :: sec0,one_day,one_year,date0_ju,ttmp
644  CHARACTER :: strc
645  LOGICAL :: ow_time
646!-
647  LOGICAL :: check = .FALSE.
648!---------------------------------------------------------------------
649  IF (PRESENT(owrite_time_in)) THEN
650    ow_time = owrite_time_in
651  ELSE
652    ow_time = .FALSE.
653  ENDIF
654!-
655  ncfid = netcdf_id(nb_fi,1)
656!-
657! Allocate the space we need for the time axes
658!-
659  CALL rest_atim (check,'restsett')
660!-
661! Get the calendar if possible. Else it will be gregorian.
662!-
663  IF (tax_size_in(nb_fi) > 0) THEN
664    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',calendar)
665    IF (iret == NF90_NOERR) THEN
666      CALL ioconf_calendar (calendar)
667      IF (check) THEN
668        WRITE(*,*) 'restsett : calendar of the restart ',calendar
669      ENDIF
670    ENDIF
671  ENDIF
672  CALL ioget_calendar (one_year,one_day)
673  IF (check) THEN
674    WRITE(*,*) 'one_year,one_day = ',one_year,one_day
675  ENDIF
676!-
677  itau_orig = 'XXXXX'
678  tax_orig  = 'XXXXX'
679!-
680! Get the time steps of the time axis if available on the restart file
681!-
682  IF (tind_varid_in(nb_fi) > 0) THEN
683    IF (ow_time) THEN
684      t_index(nb_fi,:) = itau
685      IF (check) THEN
686        WRITE(*,*) "nb_fi,t_index",nb_fi,t_index(nb_fi,:)
687      ENDIF
688      CALL ju2ymds (date0,year0,month0,day0,sec0)
689      hours0 = NINT(sec0/3600)
690      sec0 = sec0 - 3600 * hours0
691      minutes0 = NINT(sec0 / 60)
692      sec0 = sec0 - 60 * minutes0
693      seci = NINT(sec0)
694      strc=':'
695      IF (check) THEN
696        WRITE(*,*) date0
697        WRITE (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') &
698 &       year0,'-',month0,'-',day0,' ',hours0,':',minutes0,':',seci
699        WRITE(*,*) "itau_orig : ",itau_orig
700      ENDIF
701    ELSE
702      iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:))
703      IF (check) THEN
704        WRITE(*,*) "restsett, time axis : ",t_index(nb_fi,:)
705      ENDIF
706      iret = NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'units',itau_orig)
707      itau_orig = &
708 &      itau_orig(INDEX(itau_orig,'since')+6:LEN_TRIM(itau_orig))
709      iret = &
710 &      NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'tstep_sec',timestep)
711!-----
712!---- This time origin will dominate as it is linked to the time steps.
713!-----
714      READ (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') &
715 &      year0,strc,month0,strc,day0,strc, &
716 &      hours0,strc,minutes0,strc,seci
717      sec0 = REAL(seci)
718      sec0 = hours0*3600.+minutes0*60.+sec0
719      CALL ymds2ju (year0,month0,day0,sec0,date0)
720    ENDIF
721  ENDIF
722!-
723! If a julian day time axis is available then we get it
724!-
725  IF (tax_varid_in(nb_fi) > 0) THEN
726    iret = NF90_GET_VAR(ncfid,tax_varid_in(nb_fi),t_julian(nb_fi,:))
727    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'units',tax_orig)
728    tax_orig = tax_orig(INDEX(tax_orig,'since')+6:LEN_TRIM(tax_orig))
729    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',tmp_cal)
730    IF (check) THEN
731      WRITE(*,*) 'restsett : tmp_calendar of the restart ',tmp_cal
732    ENDIF
733!---
734    CALL strlowercase (tmp_cal)
735    IF (INDEX(calend_str,tmp_cal) < 0) THEN
736      IF (INDEX(calend_str,'unknown') > 0) THEN
737        calend_str = tmp_cal
738      ELSE
739        CALL ipslerr (3,'restsett', &
740 &       ' In the restart files two different calendars were found.', &
741 &       ' Please check the files you have used',' ')
742      ENDIF
743    ENDIF
744!---
745!-- We need to transform that into julian days
746!-- to get ride of the intial date.
747!---
748    IF (check) WRITE(*,*) 'tax_orig : ',TRIM(tax_orig)
749    READ (UNIT=tax_orig,FMT='(I4.4,5(a,I2.2))') &
750      year0,strc,month0,strc,day0,strc, &
751      hours0,strc,minutes0,strc,seci
752    sec0 = REAL(seci)
753    sec0 = hours0*3600.+minutes0*60.+sec0
754    CALL ymds2ju (year0,month0,day0,sec0,date0_ju)
755    t_julian(nb_fi,:) = t_julian(nb_fi,:)/one_day+date0_ju
756  ENDIF
757!-
758  IF (     (INDEX(itau_orig,'XXXXX') > 0) &
759      .AND.(INDEX(tax_orig,'XXXXX')  < 0) ) THEN
760!!- Compute the t_itau from the date read and the timestep in the input
761  ENDIF
762!-
763  IF (     (INDEX(tax_orig,'XXXXX')  > 0) &
764      .AND.(INDEX(itau_orig,'XXXXX') < 0) ) THEN
765    DO it=1,tax_size_in(nb_fi)
766      t_julian(nb_fi,it) = itau2date(t_index(nb_fi,it),date0,timestep)
767    ENDDO
768  ENDIF
769!-
770! If neither the indices or time is present then get global attributes
771! This is for compatibility reasons and should not be used.
772!-
773  IF ((tax_varid_in(nb_fi) < 0).AND.(tind_varid_in(nb_fi) < 0)) THEN
774    iax = -1
775    DO iv=1,nbvar_in(nb_fi)
776      IF (    (INDEX(varname_in(nb_fi,iv),'tsteps') > 0) &
777 &        .OR.(INDEX(varname_in(nb_fi,iv),'time_steps') > 0)) THEN
778        iax = iv
779      ENDIF
780    ENDDO
781!---
782    IF (iax < 0) THEN
783      CALL ipslerr (3,'restsett',&
784        & 'No time axis was found in the restart file. Please check',&
785        & 'that it corresponds to the convention used in restsett',&
786        & ' ')
787    ELSE
788      iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:))
789      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'delta_tstep_sec',timestep)
790      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'year0',ttmp)
791      year0 = NINT(ttmp)
792      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'month0',ttmp)
793      month0 = NINT(ttmp)
794      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'day0',ttmp)
795      day0 = NINT(ttmp)
796      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'sec0',sec0)
797!---
798      CALL ymds2ju (year0,month0,day0,sec0,date0)
799      t_julian(nb_fi,1) = itau2date(t_index(nb_fi,1),date0,timestep)
800    ENDIF
801  ENDIF
802!----------------------
803END SUBROUTINE restsett
804!===
805SUBROUTINE restopenout &
806  (fid,fname,iim,jjm, &
807   lon,lat,llm,lev,timestep,date,ncfid,domain_id)
808!---------------------------------------------------------------------
809!- Opens the restart file for output.
810!- The longitude and time variables are written.
811!---------------------------------------------------------------------
812  IMPLICIT NONE
813!-
814  INTEGER,INTENT(IN) :: fid,iim,jjm,llm
815  CHARACTER(LEN=*) :: fname
816  REAL :: date,timestep
817  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
818  INTEGER,INTENT(OUT) :: ncfid
819  INTEGER,INTENT(IN),OPTIONAL :: domain_id
820!-
821! LOCAL
822!-
823  INTEGER :: iret
824  CHARACTER(LEN=70) :: str_t
825  INTEGER :: x_id,y_id,z_id,itauid
826  INTEGER :: nlonid,nlatid,nlevid,timeid
827  INTEGER :: year,month,day,hours,minutes
828  REAL :: sec
829  CHARACTER(LEN=3),DIMENSION(12) :: &
830    cal = (/'JAN','FEB','MAR','APR','MAY','JUN', &
831            'JUL','AUG','SEP','OCT','NOV','DEC'/)
832  CHARACTER(LEN=30) :: timenow
833  LOGICAL :: check = .FALSE.
834!---------------------------------------------------------------------
835  IF (check) WRITE(*,*) "restopenout 0.0 ",TRIM(fname)
836!-
837!  If we use the same file for input and output
838!- we will not even call restopenout
839!-
840  iret = NF90_CREATE(fname,NF90_NOCLOBBER,ncfid)
841  IF (iret == -35) THEN
842    CALL ipslerr (3,'restopenout',&
843      & ' The restart file aready exists on the disc. IOIPSL ',&
844      & ' will not overwrite it. You should remove the old one or ',&
845      & ' generate the new one with another name')
846  ENDIF
847!-
848  iret = NF90_DEF_DIM(ncfid,'x',iim,x_id)
849  xax_nb(fid) = xax_nb(fid)+1
850  xax_infs(fid,xax_nb(fid),1) = iim
851  xax_infs(fid,xax_nb(fid),2) = x_id
852!-
853  iret = NF90_DEF_DIM(ncfid,'y',jjm,y_id)
854  yax_nb(fid)  = yax_nb(fid)+1
855  yax_infs(fid,yax_nb(fid),1) = jjm
856  yax_infs(fid,yax_nb(fid),2) = y_id
857!-
858  iret = NF90_DEF_DIM(ncfid,'z',llm,z_id)
859  zax_nb(fid) = zax_nb(fid)+1
860  zax_infs(fid,zax_nb(fid),1) = llm
861  zax_infs(fid,zax_nb(fid),2) = z_id
862!-
863  iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid))
864!-
865! 1.0 Longitude
866!-
867  IF (check) WRITE(*,*) "restopenout 1.0"
868!-
869  iret = NF90_DEF_VAR(ncfid,"nav_lon",NF90_FLOAT,(/x_id,y_id/),nlonid)
870  iret = NF90_PUT_ATT(ncfid,nlonid,'units',"degrees_east")
871  iret = NF90_PUT_ATT(ncfid,nlonid,'valid_min',REAL(-180.,KIND=4))
872  iret = NF90_PUT_ATT(ncfid,nlonid,'valid_max',REAL( 180.,KIND=4))
873  iret = NF90_PUT_ATT(ncfid,nlonid,'long_name',"Longitude")
874!-
875! 2.0 Latitude
876!-
877  IF (check) WRITE(*,*) "restopenout 2.0"
878!-
879  iret = NF90_DEF_VAR(ncfid,"nav_lat",NF90_FLOAT,(/x_id,y_id/),nlatid)
880  iret = NF90_PUT_ATT(ncfid,nlatid,'units',"degrees_north")
881  iret = NF90_PUT_ATT(ncfid,nlatid,'valid_min',REAL(-90.,KIND=4))
882  iret = NF90_PUT_ATT(ncfid,nlatid,'valid_max',REAL( 90.,KIND=4))
883  iret = NF90_PUT_ATT(ncfid,nlatid,'long_name',"Latitude")
884!-
885! 3.0 Levels
886!-
887  IF (check) WRITE(*,*) "restopenout 3.0"
888!-
889  iret = NF90_DEF_VAR(ncfid,"nav_lev",NF90_FLOAT,z_id,nlevid)
890  iret = NF90_PUT_ATT(ncfid,nlevid,'units',"model_levels")
891  iret = NF90_PUT_ATT(ncfid,nlevid,'valid_min', &
892 &                     REAL(MINVAL(lev),KIND=4))
893  iret = NF90_PUT_ATT(ncfid,nlevid,'valid_max', &
894 &                     REAL(MAXVAL(lev),KIND=4))
895  iret = NF90_PUT_ATT(ncfid,nlevid,'long_name',"Model levels")
896!-
897! 4.0 Time axis, this is the seconds since axis
898!-
899  IF (check) WRITE(*,*) "restopenout 4.0"
900!-
901  iret = NF90_DEF_VAR(ncfid,"time",NF90_FLOAT, &
902                       tdimid_out(fid),timeid)
903  tax_varid_out(fid) = timeid
904!-
905  timeorig(fid) = date
906  CALL ju2ymds (date,year,month,day,sec)
907  hours   = INT(sec/(60.*60.))
908  minutes = INT((sec-hours*60.*60.)/60.)
909  sec     = sec-(hours*60.*60.+minutes*60.)
910  WRITE (UNIT=str_t, &
911   FMT='("seconds since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') &
912 &  year,month,day,hours,minutes,INT(sec)
913  iret = NF90_PUT_ATT(ncfid,timeid,'units',TRIM(str_t))
914!-
915  CALL ioget_calendar (str_t)
916  iret = NF90_PUT_ATT(ncfid,timeid,'calendar',TRIM(str_t))
917  iret = NF90_PUT_ATT(ncfid,timeid,'title','Time')
918  iret = NF90_PUT_ATT(ncfid,timeid,'long_name','Time axis')
919!-
920  WRITE(UNIT=str_t, &
921   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') &
922 &  year,cal(month),day,hours,minutes,INT(sec)
923  iret = NF90_PUT_ATT(ncfid,timeid,'time_origin',TRIM(str_t))
924!-
925! 5.0 Time axis, this is the time steps since axis
926!-
927  IF (check) WRITE(*,*) "restopenout 5.0"
928!-
929  iret = NF90_DEF_VAR(ncfid,"time_steps",NF90_INT, &
930 &                    tdimid_out(fid),itauid)
931  tind_varid_out(fid) = itauid
932!-
933  CALL ju2ymds (date,year,month,day,sec)
934!-
935  hours   = INT(sec/(60.*60.))
936  minutes = INT((sec-hours*60.*60.)/60.)
937  sec     = sec-(hours*60.*60.+minutes*60.)
938!-
939  WRITE (UNIT=str_t, &
940   FMT='("timesteps since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') &
941 &  year,month,day,hours,minutes,INT(sec)
942!-
943  iret = NF90_PUT_ATT(ncfid,itauid,'units',TRIM(str_t))
944  iret = NF90_PUT_ATT(ncfid,itauid,'title','Time steps')
945  iret = NF90_PUT_ATT(ncfid,itauid,'tstep_sec',REAL(timestep,KIND=4))
946  iret = NF90_PUT_ATT(ncfid,itauid,'long_name','Time step axis')
947!-
948  WRITE(UNIT=str_t, &
949   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') &
950 &  year,cal(month),day,hours,minutes,INT(sec)
951  iret = NF90_PUT_ATT(ncfid,itauid,'time_origin',TRIM(str_t))
952!-
953!  5.2 Write global attributes
954!-
955  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'Conventions',"CF-1.1")
956  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'file_name',TRIM(fname))
957!!  TO BE DONE LATER
958!!   iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL, &
959!!                       'production',TRIM(model_name))
960!!   lock_modname = .TRUE.
961  CALL ioget_timestamp (timenow)
962  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))
963!-
964! Add DOMAIN attributes if needed
965!-
966  CALL flio_dom_att (ncfid,domain_id)
967!-
968! 6.0 The coordinates are written to the file
969!-
970  iret = NF90_ENDDEF(ncfid)
971!-
972  iret = NF90_PUT_VAR(ncfid,nlonid,lon)
973  iret = NF90_PUT_VAR(ncfid,nlatid,lat)
974  iret = NF90_PUT_VAR(ncfid,nlevid,lev)
975!-
976! 7.0 Set a few variables related to the out file
977!-
978  nbvar_out(fid) = 0
979  itau_out(fid) = -1
980  tstp_out(fid) = 0
981  touched_out(fid,:) = .FALSE.
982!-
983! 7.1 The file is put back in define mode.
984!     This will last until itau_out >= 0
985!-
986  iret = NF90_REDEF(ncfid)
987!-
988  IF (check) WRITE(*,*) "restopenout END"
989!-------------------------
990END SUBROUTINE restopenout
991!===
992SUBROUTINE restget_opp_r1d &
993 & (fid,vname_q,iim,jjm,llm,itau,def_beha, &
994 &  var,MY_OPERATOR,nbindex,ijndex)
995!---------------------------------------------------------------------
996!- This subroutine serves as an interface to restget_real
997!-
998!- Should work as restput_opp_r1d but the other way around !
999!---------------------------------------------------------------------
1000  IMPLICIT NONE
1001!-
1002  INTEGER :: fid
1003  CHARACTER(LEN=*) :: vname_q
1004  INTEGER :: iim,jjm,llm,itau
1005  LOGICAL def_beha
1006  REAL :: var(:)
1007  CHARACTER(LEN=*) :: MY_OPERATOR
1008  INTEGER :: nbindex,ijndex(nbindex)
1009!-
1010! LOCAL
1011!-
1012  INTEGER :: req_sz,siz1
1013  REAL :: scal
1014  CHARACTER(LEN=7) :: topp
1015  LOGICAL :: check = .FALSE.
1016!---------------------------------------------------------------------
1017!-
1018! 0.0 What size should be the data in the file
1019!-
1020  req_sz = 1
1021  IF (nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN
1022    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
1023    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
1024    IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1)
1025  ELSE
1026    CALL ipslerr (3,'resget_opp_r1d', &
1027      'Unable to performe an operation on this variable as it has',&
1028      'a second and third dimension',vname_q)
1029  ENDIF
1030!-
1031! 1.0 Allocate the temporary buffer we need
1032!     to put the variable in right dimension
1033!-
1034  siz1 = SIZE(var)
1035  CALL rest_alloc (1,siz1,check,'restget_opp_r1d')
1036  CALL rest_alloc (2,req_sz,check,'restget_opp_r1d')
1037!-
1038! 2.0 Here we get the variable from the restart file
1039!-
1040  CALL restget_real &
1041    (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
1042     zax_infs(fid,1,1),itau,def_beha,buff_tmp2)
1043!-
1044! 4.0 Transfer the buffer obtained from the restart file
1045!     into the variable the model expects
1046!-
1047  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
1048!-
1049  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
1050    scal = missing_val
1051    CALL mathop (topp,req_sz,buff_tmp2,missing_val, &
1052 &               nbindex,ijndex,scal,siz1,buff_tmp1)
1053    var(:) = buff_tmp1(1:siz1)
1054  ELSE
1055    CALL ipslerr (3,'resget_opp_r1d', &
1056      'The operation you wish to do on the variable for the ',&
1057      'restart file is not allowed.',topp)
1058  ENDIF
1059!-----------------------------
1060END SUBROUTINE restget_opp_r1d
1061!===
1062SUBROUTINE restget_opp_r2d &
1063 & (fid,vname_q,iim,jjm,llm,itau,def_beha, &
1064 &  var,MY_OPERATOR,nbindex,ijndex)
1065!---------------------------------------------------------------------
1066!- This subroutine serves as an interface to restget_real
1067!-
1068!- Should work as restput_opp_r2d but the other way around !
1069!---------------------------------------------------------------------
1070  IMPLICIT NONE
1071!-
1072  INTEGER :: fid
1073  CHARACTER(LEN=*) :: vname_q
1074  INTEGER :: iim,jjm,llm,itau
1075  LOGICAL def_beha
1076  REAL :: var(:,:)
1077  CHARACTER(LEN=*) :: MY_OPERATOR
1078  INTEGER :: nbindex,ijndex(nbindex)
1079!-
1080! LOCAL
1081!-
1082  INTEGER :: jj,req_sz,ist,var_sz,siz1
1083  REAL :: scal
1084  CHARACTER(LEN=7) :: topp
1085  LOGICAL :: check = .FALSE.
1086!---------------------------------------------------------------------
1087!-
1088! 0.0 What size should be the data in the file
1089!-
1090  req_sz = 1
1091  IF (nbindex == iim  .AND. llm <= 1) THEN
1092    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
1093    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
1094  ELSE
1095    CALL ipslerr (3,'resget_opp_r2d', &
1096      'Unable to performe an operation on this variable as it has', &
1097      'a second and third dimension',vname_q)
1098  ENDIF
1099!-
1100  IF (jjm < 1) THEN
1101    CALL ipslerr (3,'resget_opp_r2d', &
1102      'Please specify a second dimension which is the', &
1103      'layer on which the operations are performed',vname_q)
1104  ENDIF
1105!-
1106! 1.0 Allocate the temporary buffer we need
1107!     to put the variable in right dimension
1108!-
1109  siz1 = SIZE(var,1)
1110  CALL rest_alloc (1,siz1,check,'restget_opp_r2d')
1111  CALL rest_alloc (2,req_sz*jjm,check,'restget_opp_r2d')
1112!-
1113! 2.0 Here we get the full variable from the restart file
1114!-
1115  CALL restget_real &
1116 & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
1117 &  jjm,itau,def_beha,buff_tmp2)
1118!-
1119! 4.0 Transfer the buffer obtained from the restart file
1120!     into the variable the model expects
1121!-
1122  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
1123!-
1124  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
1125    scal = missing_val
1126    var_sz = siz1
1127    DO jj = 1,jjm
1128      ist = (jj-1)*req_sz+1
1129      CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), &
1130 &      missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1)
1131      var(:,jj) = buff_tmp1(1:siz1)
1132    ENDDO
1133  ELSE
1134    CALL ipslerr (3,'resget_opp_r2d', &
1135      'The operation you wish to do on the variable for the ',&
1136      'restart file is not allowed.',topp)
1137  ENDIF
1138!-----------------------------
1139END SUBROUTINE restget_opp_r2d
1140!===
1141SUBROUTINE restget_r1d &
1142 & (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
1143!---------------------------------------------------------------------
1144!- This subroutine serves as an interface to restget_real
1145!---------------------------------------------------------------------
1146  IMPLICIT NONE
1147!-
1148  INTEGER :: fid
1149  CHARACTER(LEN=*) :: vname_q
1150  INTEGER :: iim,jjm,llm,itau
1151  LOGICAL :: def_beha
1152  REAL :: var(:)
1153!-
1154! LOCAL
1155!-
1156  INTEGER :: ji,jl,req_sz,var_sz,siz1
1157  CHARACTER(LEN=70) :: str,str2
1158  LOGICAL :: check = .FALSE.
1159!---------------------------------------------------------------------
1160!-
1161! 1.0 Allocate the temporary buffer we need
1162!     to put the variable in right dimension
1163!-
1164  siz1 = SIZE(var)
1165  var_sz = siz1
1166  CALL rest_alloc (1,var_sz,check,'restget_r1d')
1167!-
1168! 2.0 Here we could check if the sizes specified agree
1169!     with the size of the variable provided
1170!-
1171  req_sz = 1
1172  IF (iim > 0) req_sz = req_sz*iim
1173  IF (jjm > 0) req_sz = req_sz*jjm
1174  IF (llm > 0) req_sz = req_sz*llm
1175  IF (req_sz > var_sz) THEN
1176    WRITE(str, &
1177 &    '("Size of variable requested from file should be ",I6)') req_sz
1178    WRITE(str2, &
1179 &    '("but the provided variable can only hold ",I6)') var_sz
1180    CALL ipslerr (3,'restget_r1d',str,str2,' ')
1181  ENDIF
1182  IF (req_sz < var_sz) THEN
1183    WRITE(str, &
1184 &    '("the size of variable requested from file is ",I6)') req_sz
1185    WRITE(str2, &
1186 &    '("but the provided variable can hold ",I6)') var_sz
1187    CALL ipslerr (2,'restget_r1d', &
1188      'There could be a problem here :',str,str2)
1189  ENDIF
1190!-
1191  CALL restget_real &
1192 & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
1193!-
1194! 4.0 Transfer the buffer obtained from the restart file
1195!     into the variable the model expects
1196!-
1197  jl=0
1198  DO ji=1,siz1
1199    jl=jl+1
1200    var(ji) = buff_tmp1(jl)
1201  ENDDO
1202!-------------------------
1203END SUBROUTINE restget_r1d
1204!===
1205SUBROUTINE restget_r2d &
1206 & (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
1207!---------------------------------------------------------------------
1208!- This subroutine serves as an interface to restget_real
1209!---------------------------------------------------------------------
1210  IMPLICIT NONE
1211!-
1212  INTEGER :: fid
1213  CHARACTER(LEN=*) :: vname_q
1214  INTEGER :: iim,jjm,llm,itau
1215  LOGICAL :: def_beha
1216  REAL :: var(:,:)
1217!-
1218! LOCAL
1219!-
1220  INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2
1221  CHARACTER(LEN=70) :: str,str2
1222  LOGICAL :: check = .FALSE.
1223!---------------------------------------------------------------------
1224!-
1225! 1.0 Allocate the temporary buffer we need
1226!     to put the variable in right dimension
1227!-
1228  siz1 = SIZE(var,1)
1229  siz2 = SIZE(var,2)
1230  var_sz = siz1*siz2
1231  CALL rest_alloc (1,var_sz,check,'restget_r2d')
1232!-
1233! 2.0 Here we check if the sizes specified agree
1234!     with the size of the variable provided
1235!-
1236  req_sz = 1
1237  IF (iim > 0) req_sz = req_sz*iim
1238  IF (jjm > 0) req_sz = req_sz*jjm
1239  IF (llm > 0) req_sz = req_sz*llm
1240  IF (req_sz > var_sz) THEN
1241    WRITE(str, &
1242 &    '("Size of variable ",A, &
1243 &      //" requested from file should be ",I6)') TRIM(vname_q),req_sz
1244    WRITE(str2, &
1245 &    '("but the provided variable can only hold ",I6)') var_sz
1246    CALL ipslerr (3,'restget_r2d',str,str2,' ')
1247  ENDIF
1248  IF (req_sz < var_sz) THEN
1249    WRITE(str, &
1250 &    '("Size of variable ",A, &
1251 &      //" requested from file is ",I6)') TRIM(vname_q),req_sz
1252    WRITE(str2,'("but the provided variable can hold ",I6)') var_sz
1253    CALL ipslerr (2,'restget_r2d', &
1254      'There could be a problem here :',str,str2)
1255  ENDIF
1256!-
1257  CALL restget_real &
1258 & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
1259!-
1260! 4.0 Transfer the buffer obtained from the restart file
1261!     into the variable the model expects
1262!-
1263  jl=0
1264  DO jj=1,siz2
1265    DO ji=1,siz1
1266      jl=jl+1
1267      var(ji,jj) = buff_tmp1(jl)
1268    ENDDO
1269  ENDDO
1270!-------------------------
1271END SUBROUTINE restget_r2d
1272!===
1273SUBROUTINE restget_r3d &
1274  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
1275!---------------------------------------------------------------------
1276!- This subroutine serves as an interface to restget_real
1277!---------------------------------------------------------------------
1278  IMPLICIT NONE
1279!-
1280  INTEGER :: fid
1281  CHARACTER(LEN=*) :: vname_q
1282  INTEGER :: iim,jjm,llm,itau
1283  LOGICAL def_beha
1284  REAL :: var(:,:,:)
1285!-
1286! LOCAL
1287!-
1288  INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3
1289  CHARACTER(LEN=70) :: str,str2
1290  LOGICAL :: check = .FALSE.
1291!---------------------------------------------------------------------
1292!-
1293! 1.0 Allocate the temporary buffer we need
1294!     to put the variable in right dimension
1295!-
1296  siz1 = SIZE(var,1)
1297  siz2 = SIZE(var,2)
1298  siz3 = SIZE(var,3)
1299  var_sz = siz1*siz2*siz3
1300  CALL rest_alloc (1,var_sz,check,'restget_r3d')
1301!-
1302! 2.0 Here we check if the sizes specified agree
1303!     with the size of the variable provided
1304!-
1305  req_sz = 1
1306  IF (iim > 0) req_sz = req_sz*iim
1307  IF (jjm > 0) req_sz = req_sz*jjm
1308  IF (llm > 0) req_sz = req_sz*llm
1309  IF (req_sz > var_sz) THEN
1310    WRITE(str, &
1311 &    '("Size of variable ",A, &
1312 &      //" requested from file should be ",I6)') TRIM(vname_q),req_sz
1313    WRITE(str2, &
1314 &    '("but the provided variable can only hold ",I6)') var_sz
1315    CALL ipslerr (3,'restget_r3d',str,str2,' ')
1316  ENDIF
1317  IF (req_sz < var_sz) THEN
1318    WRITE(str, &
1319 &    '("Size of variable ",A, &
1320 &      //" requested from file is ",I6)') TRIM(vname_q),req_sz
1321    WRITE(str2,'("but the provided variable can hold ",I6)') var_sz
1322    CALL ipslerr (2,'restget_r3d', &
1323      'There could be a problem here :',str,str2)
1324  ENDIF
1325!-
1326  CALL restget_real &
1327    (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
1328!-
1329! 4.0 Transfer the buffer obtained from the restart file
1330!     into the variable the model expects
1331!-
1332  jl=0
1333  DO jk=1,siz3
1334    DO jj=1,siz2
1335      DO ji=1,siz1
1336        jl=jl+1
1337        var(ji,jj,jk) = buff_tmp1(jl)
1338      ENDDO
1339    ENDDO
1340  ENDDO
1341!-------------------------
1342END SUBROUTINE restget_r3d
1343!===
1344SUBROUTINE restget_real &
1345  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
1346!---------------------------------------------------------------------
1347!- This subroutine is for getting a variable from the restart file.
1348!- A number of verifications will be made :
1349!- - Is this the first time we read this variable ?
1350!- - Are the dimensions correct ?
1351!- - Is the correct time step present in the file
1352!- - is a default behaviour possible. If not the model is stoped.
1353!- Default procedure is to write the content of val_exp on all values.
1354!-
1355!- INPUT
1356!-
1357!- fid            : Identification of the file
1358!- vname_q        : Name of the variable to be read
1359!- iim, jjm ,llm  : Dimensions of the variable that should be read
1360!- itau           : Time step at whcih we are when we want
1361!-                  to read the variable
1362!- def_beha       : If the model can restart without this variable
1363!-                  then some strange value is given.
1364!-
1365!- OUTPUT
1366!-
1367!- var            : Variable in which the data is put
1368!---------------------------------------------------------------------
1369  IMPLICIT NONE
1370!-
1371  INTEGER :: fid
1372  CHARACTER(LEN=*) :: vname_q
1373  INTEGER :: iim,jjm,llm,itau
1374  LOGICAL :: def_beha
1375  REAL :: var(:)
1376!-
1377! LOCAL
1378!-
1379  INTEGER :: vid,vnb,ncfid
1380  INTEGER :: iret,index,it,ndim,ia
1381  CHARACTER(LEN=70) str,str2
1382  CHARACTER(LEN=80) attname
1383  INTEGER,DIMENSION(4) :: corner,edge
1384!---------------------------------------------------------------------
1385!-
1386  ncfid = netcdf_id(fid,1)
1387!-
1388  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb)
1389!-
1390! 1.0 If the variable is not present then ERROR or filled up
1391!     by default values if allowed
1392!-
1393  IF (vnb < 0) THEN
1394    IF (def_beha) THEN
1395!-----
1396      lock_valexp = .TRUE.
1397      var(:) = val_exp
1398!----
1399      str = 'Variable '//TRIM(vname_q) &
1400          //' is not present in the restart file'
1401      CALL ipslerr (1,'restget', &
1402 &      str,'but default values are used to fill in',' ')
1403!----
1404      IF (nbvar_in(fid) >= max_var) THEN
1405        CALL ipslerr (3,'restget', &
1406         'Too many variables for the restcom module', &
1407         'Please increase the value of max_var',' ')
1408      ENDIF
1409      nbvar_in(fid) = nbvar_in(fid)+1
1410      vnb = nbvar_in(fid)
1411      varname_in(fid,vnb) = vname_q
1412      touched_in(fid,vnb) = .TRUE.
1413!-----
1414      CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.)
1415!-----
1416    ELSE
1417      str = 'Variable '//TRIM(vname_q) &
1418          //' is not present in the restart file'
1419      CALL ipslerr (3,'restget', &
1420 &      str,'but it is need to restart the model',' ')
1421    ENDIF
1422!---
1423  ELSE
1424!---
1425!--  2.0 Check if the variable has not yet been read
1426!--      and that the time is OK
1427!---
1428    vid = varid_in(fid,vnb)
1429!---
1430    nbvar_read(fid) = nbvar_read(fid)+1
1431!---
1432    IF (touched_in(fid,vnb)) THEN
1433      str = 'Variable '//TRIM(vname_q) &
1434          //' has already been read from file'
1435      CALL ipslerr (3,'restget',str,' ',' ')
1436    ENDIF
1437!---
1438!-- 3.0 get the time step of the restart file
1439!--     and check if it is correct
1440!---
1441    index = -1
1442    DO it=1,tax_size_in(fid)
1443      IF (t_index(fid,it) == itau)  index = it
1444    ENDDO
1445!---
1446    IF (index < 0) THEN
1447      str = 'The time step requested for variable '//TRIM(vname_q)
1448      CALL ipslerr (3,'restget', &
1449 &      str,'is not available in the current file',' ')
1450    ENDIF
1451!---
1452!-- 4.0 Read the data. Note that the variables in the restart files
1453!--     have no time axis is and thus we write -1
1454!---
1455    str='Incorrect dimension for '//TRIM(vname_q)
1456    ndim = 0
1457    IF (iim > 0) THEN
1458      ndim = ndim+1
1459      IF (vardims_in(fid,vnb,ndim) == iim) THEN
1460        corner(ndim) = 1
1461        edge(ndim) = iim
1462      ELSE
1463        WRITE (str2,'("Incompatibility for iim : ",I6,I6)') &
1464             iim,vardims_in(fid,vnb,ndim)
1465        CALL ipslerr (3,'restget',str,str2,' ')
1466      ENDIF
1467    ENDIF
1468!---
1469    IF (jjm > 0) THEN
1470      ndim = ndim+1
1471      IF (vardims_in(fid,vnb,ndim) == jjm) THEN
1472        corner(ndim) = 1
1473        edge(ndim) = jjm
1474      ELSE
1475        WRITE (str2,'("Incompatibility for jjm : ",I6,I6)') &
1476             jjm,vardims_in(fid,vnb,ndim)
1477        CALL ipslerr (3,'restget',str,str2,' ')
1478      ENDIF
1479    ENDIF
1480!---
1481    IF (llm > 0) THEN
1482      ndim = ndim+1
1483      IF (vardims_in(fid,vnb,ndim) == llm) THEN
1484        corner(ndim) = 1
1485        edge(ndim) = llm
1486      ELSE
1487        WRITE (str2,'("Incompatibility for llm : ",I6,I6)') &
1488             llm,vardims_in(fid,vnb,ndim)
1489        CALL ipslerr (3,'restget',str,str2,' ')
1490      ENDIF
1491    ENDIF
1492!---
1493!-- Time
1494!---
1495    ndim = ndim+1
1496    corner(ndim) = index
1497!!????? edge(ndim) = index
1498    edge(ndim) = 1
1499!---
1500    iret = NF90_GET_VAR(ncfid,vid,var, &
1501 &                      start=corner(1:ndim),count=edge(1:ndim))
1502!---
1503!-- 5.0 The variable we have just read is created
1504!--      in the next restart file
1505!---
1506    IF (     (netcdf_id(fid,1) /= netcdf_id(fid,2))  &
1507 &      .AND.(netcdf_id(fid,2) > 0) ) THEN
1508!-----
1509      CALL restdefv (fid,vname_q,iim,jjm,llm,.FALSE.)
1510!-----
1511      DO ia = 1,varatt_in(fid,vnb)
1512        iret = NF90_INQ_ATTNAME(ncfid,vid,ia,attname)
1513        iret = NF90_COPY_ATT(ncfid,vid,attname, &
1514 &               netcdf_id(fid,2),varid_out(fid,nbvar_out(fid)))
1515      ENDDO
1516!-----
1517      IF (itau_out(fid) >= 0) THEN
1518        iret = NF90_ENDDEF(netcdf_id(fid,2))
1519      ENDIF
1520    ENDIF
1521!---
1522  ENDIF
1523!--------------------------
1524END SUBROUTINE restget_real
1525!===
1526SUBROUTINE restput_opp_r1d &
1527 & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex)
1528!---------------------------------------------------------------------
1529!- This subroutine is the interface to restput_real which allows
1530!- to re-index data onto the original grid of the restart file.
1531!- The logic we use is still fuzzy in my mind but that is probably
1532!- only because I have not yet though through everything.
1533!-
1534!- In the case iim = nbindex it means that the user attempts
1535!- to project a vector back onto the original 2D or 3D field.
1536!- This requires that jjm and llm be equal to 1 or 0,
1537!- else I would not know what it means.
1538!---------------------------------------------------------------------
1539  IMPLICIT NONE
1540!-
1541  INTEGER :: fid
1542  CHARACTER(LEN=*) :: vname_q
1543  INTEGER :: iim,jjm,llm,itau
1544  REAL :: var(:)
1545  CHARACTER(LEN=*) :: MY_OPERATOR
1546  INTEGER :: nbindex,ijndex(nbindex)
1547!-
1548! LOCAL
1549!-
1550  INTEGER :: req_sz,siz1
1551  REAL :: scal
1552  CHARACTER(LEN=7) :: topp
1553  LOGICAL :: check = .FALSE.
1554!---------------------------------------------------------------------
1555!-
1556! 0.0 What size should be the data in the file
1557!-
1558  req_sz = 1
1559  IF ( nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN
1560    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
1561    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
1562    IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1)
1563  ELSE
1564    CALL ipslerr (3,'restput_opp_r1d', &
1565      'Unable to performe an operation on this variable as it has', &
1566      'a second and third dimension',vname_q)
1567  ENDIF
1568!-
1569! 1.0 Allocate the temporary buffer we need
1570!     to put the variable in right dimension
1571!-
1572  siz1 = SIZE(var)
1573  CALL rest_alloc (1,siz1,check,'restput_opp_r1d')
1574  CALL rest_alloc (2,req_sz,check,'restput_opp_r1d')
1575!-
1576! 2.0 We do the operation needed.
1577!     It can only be a re-indexing operation.
1578!     You would not want to change the values in a restart file or ?
1579!-
1580  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
1581!-
1582  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
1583    scal = missing_val
1584    buff_tmp1(1:siz1) = var(:)
1585    CALL mathop &
1586 &    (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, &
1587 &     scal,req_sz,buff_tmp2)
1588  ELSE
1589    CALL ipslerr (3,'restput_opp_r1d', &
1590 &    'The operation you wish to do on the variable for the ', &
1591 &    'restart file is not allowed.',topp)
1592  ENDIF
1593!-
1594  CALL restput_real &
1595 & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
1596 &  zax_infs(fid,1,1),itau,buff_tmp2)
1597!-----------------------------
1598END SUBROUTINE restput_opp_r1d
1599!===
1600SUBROUTINE restput_opp_r2d &
1601 & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex)
1602!---------------------------------------------------------------------
1603!- This subroutine is the interface to restput_real which allows
1604!- to re-index data onto the original grid of the restart file.
1605!- The logic we use is still fuzzy in my mind but that is probably
1606!- only because I have not yet though through everything.
1607!-
1608!- In the case iim = nbindex it means that the user attempts
1609!- to project the first dimension of the matrix back onto a 3D field
1610!- where jjm will be the third dimension.
1611!- Here we do not allow for 4D data, thus we will take the first
1612!- two dimensions in the file and require that llm = 1.
1613!- These are pretty heavy constraints but I do not know how
1614!- to make it more general. I need to think about it some more.
1615!---------------------------------------------------------------------
1616  IMPLICIT NONE
1617!-
1618  INTEGER :: fid
1619  CHARACTER(LEN=*) :: vname_q
1620  INTEGER :: iim,jjm,llm,itau
1621  REAL :: var(:,:)
1622  CHARACTER(LEN=*) :: MY_OPERATOR
1623  INTEGER :: nbindex,ijndex(nbindex)
1624!-
1625! LOCAL
1626!-
1627  INTEGER :: jj,req_sz,ist,siz1
1628  REAL :: scal
1629  CHARACTER(LEN=7) :: topp
1630  LOGICAL :: check = .FALSE.
1631!---------------------------------------------------------------------
1632!-
1633! 0.0 What size should be the data in the file
1634!-
1635  req_sz = 1
1636  IF ( nbindex == iim .AND. llm <= 1) THEN
1637    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
1638    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
1639  ELSE
1640    CALL ipslerr (3,'restput_opp_r2d', &
1641      'Unable to performe an operation on this variable as it has', &
1642      'a second and third dimension',vname_q)
1643  ENDIF
1644!-
1645  IF (jjm < 1) THEN
1646    CALL ipslerr (3,'restput_opp_r2d', &
1647      'Please specify a second dimension which is the', &
1648      'layer on which the operations are performed',vname_q)
1649  ENDIF
1650!-
1651! 1.0 Allocate the temporary buffer we need
1652!     to put the variable in right dimension
1653!-
1654  siz1 = SIZE(var,1)
1655  CALL rest_alloc (1,siz1,check,'restput_opp_r2d')
1656  CALL rest_alloc (2,req_sz*jjm,check,'restput_opp_r2d')
1657!-
1658! 2.0 We do the operation needed.
1659!     It can only be a re-indexing operation.
1660!     You would not want to change the values in a restart file or ?
1661!-
1662  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
1663!-
1664  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
1665    scal = missing_val
1666    DO jj = 1,jjm
1667      buff_tmp1(1:siz1) = var(:,jj)
1668      ist = (jj-1)*req_sz+1
1669      CALL mathop &
1670 &      (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, &
1671 &       scal,req_sz,buff_tmp2(ist:ist+req_sz-1))
1672    ENDDO
1673  ELSE
1674    CALL ipslerr (3,'restput_opp_r2d', &
1675 &    'The operation you wish to do on the variable for the ', &
1676 &    'restart file is not allowed.',topp)
1677  ENDIF
1678!-
1679  CALL restput_real &
1680 & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
1681 &  jjm,itau,buff_tmp2)
1682!-----------------------------
1683END SUBROUTINE restput_opp_r2d
1684!===
1685SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var)
1686!---------------------------------------------------------------------
1687!- This subroutine serves as an interface to restput_real
1688!---------------------------------------------------------------------
1689  IMPLICIT NONE
1690!-
1691  INTEGER :: fid
1692  CHARACTER(LEN=*) :: vname_q
1693  INTEGER :: iim,jjm,llm,itau
1694  REAL :: var(:)
1695!-
1696! LOCAL
1697!-
1698  INTEGER :: ji,jl,req_sz,var_sz,siz1
1699  CHARACTER(LEN=70) :: str,str2
1700  LOGICAL :: check = .FALSE.
1701!---------------------------------------------------------------------
1702!-
1703! 1.0 Allocate the temporary buffer we need
1704!     to put the variable in right dimension
1705!-
1706  siz1 = SIZE(var)
1707  var_sz = siz1
1708  CALL rest_alloc (1,var_sz,check,'restput_r1d')
1709!-
1710! 2.0 Here we could check if the sizes specified agree
1711!     with the size of the variable provided
1712!-
1713  req_sz = 1
1714  IF (iim > 0) req_sz = req_sz*iim
1715  IF (jjm > 0) req_sz = req_sz*jjm
1716  IF (llm > 0) req_sz = req_sz*llm
1717  IF (req_sz > var_sz) THEN
1718    WRITE(str, &
1719 &    '("Size of variable put to the file should be ",I6)') req_sz
1720    WRITE(str2, &
1721 &    '("but the provided variable is of size ",I6)') var_sz
1722    CALL ipslerr (3,'restput_r1d',str,str2,' ')
1723  ENDIF
1724  IF (req_sz < var_sz) THEN
1725    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
1726    WRITE(str2,'("but the provided variable is larger ",I6)') var_sz
1727    CALL ipslerr (2,'restput_r1d', &
1728      'There could be a problem here :',str,str2)
1729  ENDIF
1730!-
1731! 4.0 Transfer the buffer obtained from the restart file
1732!     into the variable the model expects
1733!-
1734  jl=0
1735  DO ji=1,siz1
1736    jl=jl+1
1737    buff_tmp1(jl) = var(ji)
1738  ENDDO
1739!-
1740  CALL restput_real (fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
1741!-------------------------
1742END SUBROUTINE restput_r1d
1743!===
1744SUBROUTINE restput_r2d (fid,vname_q,iim,jjm,llm,itau,var)
1745!---------------------------------------------------------------------
1746!- This subroutine serves as an interface to restput_real
1747!---------------------------------------------------------------------
1748  IMPLICIT NONE
1749!-
1750  INTEGER :: fid
1751  CHARACTER(LEN=*) :: vname_q
1752  INTEGER :: iim,jjm,llm,itau
1753  REAL :: var(:,:)
1754!-
1755! LOCAL
1756!-
1757  INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2
1758  CHARACTER(LEN=70) :: str,str2
1759  LOGICAL :: check = .FALSE.
1760!---------------------------------------------------------------------
1761!-
1762! 1.0 Allocate the temporary buffer we need
1763!     to put the variable in right dimension
1764!-
1765  siz1 = SIZE(var,1)
1766  siz2 = SIZE(var,2)
1767  var_sz = siz1*siz2
1768  CALL rest_alloc (1,var_sz,check,'restput_r2d')
1769!-
1770! 2.0 Here we could check if the sizes specified agree
1771!     with the size of the variable provided
1772!-
1773  req_sz = 1
1774  IF (iim > 0) req_sz = req_sz*iim
1775  IF (jjm > 0) req_sz = req_sz*jjm
1776  IF (llm > 0) req_sz = req_sz*llm
1777  IF (req_sz > var_sz) THEN
1778    WRITE(str, &
1779&         '("Size of variable put to the file should be ",I6)') req_sz
1780    WRITE(str2,'("but the provided variable is of size  ",I6)') var_sz
1781    CALL ipslerr (3,'restput_r2d',str,str2,' ')
1782  ENDIF
1783  IF (req_sz < var_sz) THEN
1784    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
1785    WRITE(str2,'("but the provided variable is larger ",I6)')  var_sz
1786    CALL ipslerr (2,'restput_r2d', &
1787      'There could be a problem here :',str,str2)
1788  ENDIF
1789!-
1790! 4.0 Transfer the buffer obtained from the restart file
1791!     into the variable the model expects
1792!-
1793  jl=0
1794  DO jj=1,siz2
1795    DO ji=1,siz1
1796      jl=jl+1
1797      buff_tmp1(jl) = var(ji,jj)
1798    ENDDO
1799  ENDDO
1800!-
1801  CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
1802!-------------------------
1803END SUBROUTINE restput_r2d
1804!===
1805SUBROUTINE restput_r3d (fid,vname_q,iim,jjm,llm,itau,var)
1806!---------------------------------------------------------------------
1807!- This subroutine serves as an interface to restput_real
1808!---------------------------------------------------------------------
1809  IMPLICIT NONE
1810!-
1811  INTEGER :: fid
1812  CHARACTER(LEN=*) :: vname_q
1813  INTEGER :: iim,jjm,llm,itau
1814  REAL :: var(:,:,:)
1815!-
1816! LOCAL
1817!-
1818  INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3
1819  CHARACTER(LEN=70) :: str,str2
1820  LOGICAL :: check = .FALSE.
1821!---------------------------------------------------------------------
1822!-
1823! 1.0 Allocate the temporary buffer we need
1824!     to put the variable in right dimension
1825!-
1826  siz1 = SIZE(var,1)
1827  siz2 = SIZE(var,2)
1828  siz3 = SIZE(var,3)
1829  var_sz = siz1*siz2*siz3
1830  CALL rest_alloc (1,var_sz,check,'restput_r3d')
1831!-
1832! 2.0 Here we could check if the sizes specified agree
1833!     with the size of the variable provided
1834!-
1835  req_sz = 1
1836  IF (iim > 0) req_sz = req_sz*iim
1837  IF (jjm > 0) req_sz = req_sz*jjm
1838  IF (llm > 0) req_sz = req_sz*llm
1839  IF (req_sz > var_sz) THEN
1840    WRITE(str, &
1841 &    '("Size of variable put to the file should be ",I6)') req_sz
1842    WRITE(str2, &
1843 &    '("but the provided variable is of size  ",I6)')  var_sz
1844    CALL ipslerr (3,'restput_r3d',str,str2,' ')
1845  ENDIF
1846  IF (req_sz < var_sz) THEN
1847    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
1848    WRITE(str2,'("but the provided variable is larger ",I6)')  var_sz
1849    CALL ipslerr (2,'restput_r3d', &
1850      'There could be a problem here :',str,str2)
1851  ENDIF
1852!-
1853! 4.0 Transfer the buffer obtained from the restart file
1854!     into the variable the model expects
1855!-
1856  jl=0
1857  DO jk=1,siz3
1858    DO jj=1,siz2
1859      DO ji=1,siz1
1860        jl=jl+1
1861        buff_tmp1(jl) = var(ji,jj,jk)
1862      ENDDO
1863    ENDDO
1864  ENDDO
1865!-
1866  CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
1867!-------------------------
1868END SUBROUTINE restput_r3d
1869!===
1870SUBROUTINE restput_real (fid,vname_q,iim,jjm,llm,itau,var)
1871!---------------------------------------------------------------------
1872!- This subroutine will put a variable into the restart file.
1873!- But it will do a lot of other things if needed :
1874!- - Open a file if non is opened for this time-step
1875!-   and all variables were written.
1876!- - Add an axis if needed
1877!- - verify that the variable has the right time step for this file
1878!- - If it is time for a new file then it is opened
1879!-   and the old one closed
1880!- This requires that variables read from the last restart file were all
1881!- written
1882!-
1883!- INPUT
1884!-
1885!- fid         : Id of the file in which we will write the variable
1886!- vname_q     : Name of the variable to be written
1887!- iim,jjm,llm : Size in 3D of the variable
1888!- itau        : Time step at which the variable is written
1889!- var         : Variable
1890!-
1891!- OUTPUT
1892!-
1893!- NONE
1894!---------------------------------------------------------------------
1895  IMPLICIT NONE
1896!-
1897  CHARACTER(LEN=*) :: vname_q
1898  INTEGER :: fid,iim,jjm,llm,itau
1899  REAL :: var(:)
1900!-
1901! LOCAL
1902!-
1903  INTEGER :: iret,vid,ncid,iv,vnb
1904  INTEGER :: ierr
1905  REAL :: secsince,one_day,one_year
1906  INTEGER :: ndims
1907  INTEGER,DIMENSION(4) :: corner,edge
1908!-
1909  LOGICAL :: check = .FALSE.
1910!---------------------------------------------------------------------
1911!-
1912! 0.0 Get some variables
1913!-
1914  ncid = netcdf_id(fid,2)
1915  IF (netcdf_id(fid,2) < 0) THEN
1916    CALL ipslerr (3,'restput', &
1917 &    'The output restart file is undefined.',' ',' ')
1918  ENDIF
1919  CALL ioget_calendar (one_year,one_day)
1920!-
1921! 1.0 Check if the variable is already present
1922!-
1923  IF (check) WRITE(*,*) 'RESTPUT 1.0 : ',TRIM(vname_q)
1924!-
1925  CALL find_str (varname_out(fid,1:nbvar_out(fid)),vname_q,vnb)
1926!-
1927  IF (check) THEN
1928    WRITE(*,*) 'RESTPUT 1.1 : ',varname_out(fid,1:nbvar_out(fid)),vnb
1929  ENDIF
1930!-
1931! 2.0 If variable is not present then declare it
1932!     and add extra dimensions if needed.
1933!-
1934  IF (vnb <= 0) THEN
1935    CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.)
1936    vnb = nbvar_out(fid)
1937  ENDIF
1938  vid = varid_out(fid,vnb)
1939!-
1940  IF (check) WRITE(*,*) 'RESTPUT 2.0 : ',vnb,vid
1941!-
1942! 2.1 Is this file already in write mode ?
1943!     If itau_out is still negative then we have
1944!     never written to it and we need to go into write mode.
1945!-
1946  IF (itau_out(fid) < 0) THEN
1947    iret = NF90_ENDDEF(ncid)
1948  ENDIF
1949!-
1950! 3.0 Is this itau already on the axis ?
1951!     If not then check that all variables of previous time is OK.
1952!-
1953  IF (check) WRITE(*,*) 'RESTPUT 3.0 : ',itau,itau_out(fid)
1954!-
1955  IF (itau /= itau_out(fid)) THEN
1956!---
1957!-- If it is the first time step written on the restart
1958!-- then we only check the number
1959!-- Else we see if every variable was written
1960!---
1961    IF (tstp_out(fid) == 0) THEN
1962      IF (nbvar_out(fid) < nbvar_read(fid)) THEN
1963        WRITE(*,*) "ERROR :",tstp_out(fid), &
1964                   nbvar_out(fid),nbvar_read(fid)
1965        CALL ipslerr (1,'restput', &
1966 &        'There are fewer variables read from the output file', &
1967 &        'than written onto the input file.', &
1968 &        'We trust you know what you are doing')
1969      ENDIF
1970    ELSE
1971      ierr = 0
1972      DO iv=1,nbvar_out(fid)
1973        IF (.NOT.touched_out(fid,iv)) ierr = ierr+1
1974      ENDDO
1975      IF (ierr > 0) THEN
1976        WRITE(*,*) "ERROR :",nbvar_out(fid)
1977        CALL ipslerr (1,'restput', &
1978 &        'There are fewer variables in the output file for this', &
1979 &        'time step than for the previous one',' ')
1980      ELSE
1981        touched_out(fid,:) = .FALSE.
1982      ENDIF
1983    ENDIF
1984!---
1985    secsince = itau*deltat(fid)
1986    corner(1) =  tstp_out(fid)+1
1987    edge(1) = 1
1988!---
1989!-- 3.1 Here we add the values to the time axes
1990!---
1991    IF (check) THEN
1992      WRITE(*,*) 'RESTPUT 3.1 : ',itau,secsince,corner(1),edge(1)
1993    ENDIF
1994!---
1995    iret = NF90_PUT_VAR(ncid,tind_varid_out(fid),itau, &
1996 &                      start=corner(1:1))
1997    iret = NF90_PUT_VAR(ncid,tax_varid_out(fid),secsince, &
1998 &                      start=corner(1:1))
1999!---
2000    tstp_out(fid) = tstp_out(fid)+1
2001    itau_out(fid) = itau
2002  ENDIF
2003!-
2004! 4.0 Variable and time step should be present
2005!     now so we can dump variable
2006!-
2007  ndims = 0
2008  IF (iim > 0) THEN
2009    ndims = ndims+1
2010    corner(ndims) = 1
2011    edge(ndims) = iim
2012  ENDIF
2013  IF (jjm > 0) THEN
2014    ndims = ndims+1
2015    corner(ndims) = 1
2016    edge(ndims) = jjm
2017  ENDIF
2018  IF (llm > 0) THEN
2019    ndims = ndims+1
2020    corner(ndims) = 1
2021    edge(ndims) = llm
2022  ENDIF
2023  ndims = ndims+1
2024  corner(ndims) = tstp_out(fid)
2025  edge(ndims) = 1
2026!-
2027  iret = NF90_PUT_VAR(ncid,vid,var, &
2028 &                    start=corner(1:ndims),count=edge(1:ndims))
2029!-
2030  IF (iret /= NF90_NOERR) THEN
2031    CALL ipslerr (2,'restput_real',NF90_STRERROR(iret), &
2032 &    'Bug in restput.',&
2033 &    'Please, verify compatibility between get and put commands.')
2034  ENDIF
2035!-
2036!  5.0 Note that the variables was treated
2037!-
2038  touched_out(fid,vnb) = .TRUE.
2039!---------------------------
2040END  SUBROUTINE restput_real
2041!===
2042SUBROUTINE restdefv (fid,varname,iim,jjm,llm,write_att)
2043!---------------------------------------------------------------------
2044! This subroutine adds a variable to the output file.
2045! The attributes are either taken from.
2046!---------------------------------------------------------------------
2047  IMPLICIT NONE
2048!-
2049  INTEGER ::fid
2050  CHARACTER(LEN=*) :: varname
2051  INTEGER :: iim,jjm,llm
2052  LOGICAL :: write_att
2053!-
2054! Local
2055!-
2056  INTEGER :: dims(4),ic,xloc,ndim,ncfid
2057  INTEGER :: iret,ax_id
2058  CHARACTER(LEN=3) :: str
2059!-
2060  LOGICAL :: check = .FALSE.
2061!---------------------------------------------------------------------
2062  ncfid = netcdf_id(fid,2)
2063  IF (nbvar_out(fid) >= max_var) THEN
2064    CALL ipslerr (3,'restdefv', &
2065      'Too many variables for the restcom module', &
2066      'Please increase the value of max_var',' ')
2067  ENDIF
2068  nbvar_out(fid) = nbvar_out(fid)+1
2069  varname_out(fid,nbvar_out(fid)) = varname
2070!-
2071! 0.0 Put the file in define mode if needed
2072!-
2073  IF (itau_out(fid) >= 0) THEN
2074    iret = NF90_REDEF(ncfid)
2075  ENDIF
2076!-
2077! 1.0 Do we have all dimensions and can we go ahead
2078!-
2079  IF (check) THEN
2080    WRITE(*,*) 'restdefv 1.0 :',TRIM(varname),nbvar_out(fid)
2081  ENDIF
2082!-
2083  ndim = 0
2084!-
2085! 1.1 Work on x
2086!-
2087  IF (iim > 0) THEN
2088    ndim = ndim+1
2089    xloc = 0
2090    DO ic=1,xax_nb(fid)
2091      IF (xax_infs(fid,ic,1) == iim) xloc = ic
2092    ENDDO
2093!---
2094    IF (xloc > 0) THEN
2095      dims(ndim) = xax_infs(fid,xloc,2)
2096    ELSE
2097      str='x_'//CHAR(96+xax_nb(fid))
2098      iret = NF90_DEF_DIM(ncfid,str,iim,ax_id)
2099      xax_nb(fid) = xax_nb(fid)+1
2100      xax_infs(fid,xax_nb(fid),1) = iim
2101      xax_infs(fid,xax_nb(fid),2) = ax_id
2102      dims(ndim) = ax_id
2103    ENDIF
2104  ENDIF
2105!-
2106! 1.2 Work on y
2107!-
2108  IF (jjm > 0) THEN
2109    ndim = ndim+1
2110    xloc = 0
2111    DO ic=1,yax_nb(fid)
2112      IF (yax_infs(fid,ic,1) == jjm) xloc = ic
2113    ENDDO
2114!---
2115    IF (xloc > 0) THEN
2116      dims(ndim) = yax_infs(fid,xloc,2)
2117    ELSE
2118      str='y_'//CHAR(96+yax_nb(fid))
2119      iret = NF90_DEF_DIM(ncfid,str,jjm,ax_id)
2120      yax_nb(fid) = yax_nb(fid)+1
2121      yax_infs(fid,yax_nb(fid),1) = jjm
2122      yax_infs(fid,yax_nb(fid),2) = ax_id
2123      dims(ndim) = ax_id
2124    ENDIF
2125  ENDIF
2126!-
2127! 1.3 Work on z
2128!-
2129  IF (llm > 0) THEN
2130    ndim = ndim+1
2131    xloc = 0
2132    DO ic=1,zax_nb(fid)
2133      IF (zax_infs(fid,ic,1) == llm) xloc = ic
2134    ENDDO
2135!---
2136    IF (xloc > 0) THEN
2137      dims(ndim) = zax_infs(fid,xloc,2)
2138    ELSE
2139      str='z_'//CHAR(96+zax_nb(fid))
2140      iret = NF90_DEF_DIM(ncfid,str,llm,ax_id)
2141      zax_nb(fid) = zax_nb(fid)+1
2142      zax_infs(fid,zax_nb(fid),1) = llm
2143      zax_infs(fid,zax_nb(fid),2) = ax_id
2144      dims(ndim) = ax_id
2145    ENDIF
2146  ENDIF
2147!-
2148! 1.4  Time needs to be added
2149!-
2150  ndim = ndim+1
2151  dims(ndim) = tdimid_out(fid)
2152!-
2153! 2.0  Declare the variable
2154!-
2155  IF (check) THEN
2156    WRITE(*,*) 'restdefv 2.0 :',ndim,' :: ',dims(1:ndim),tdimid_out(fid)
2157  ENDIF
2158!-
2159  iret = NF90_DEF_VAR(ncfid,varname,NF90_DOUBLE,dims(1:ndim), &
2160 &                    varid_out(fid,nbvar_out(fid)))
2161  IF (iret /= NF90_NOERR) THEN
2162    CALL ipslerr (3,'restdefv', &
2163      'Could not define new variable in file', &
2164      NF90_STRERROR(iret),varname)
2165  ENDIF
2166!-
2167! 3.0 Add the attributes if requested
2168!-
2169  IF (write_att) THEN
2170    IF (rest_units /= 'XXXXX') THEN
2171      iret =  NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
2172 &                         'units',TRIM(rest_units))
2173      rest_units = 'XXXXX'
2174    ENDIF
2175!---
2176    IF (rest_lname /= 'XXXXX') THEN
2177      iret =  NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
2178 &                         'long_name',TRIM(rest_lname))
2179      rest_lname = 'XXXXX'
2180    ENDIF
2181!---
2182    iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
2183 &                      'missing_value',REAL(missing_val,KIND=4))
2184!---
2185    IF (itau_out(fid) >= 0) THEN
2186      iret = NF90_ENDDEF(ncfid)
2187    ENDIF
2188  ENDIF
2189!-
2190  IF (check) THEN
2191    WRITE(*,*) &
2192 &    'restdefv 3.0 : LIST OF VARS ',varname_out(fid,1:nbvar_out(fid))
2193  ENDIF
2194!----------------------
2195END SUBROUTINE restdefv
2196!===
2197SUBROUTINE rest_atim (l_msg,c_p)
2198!---------------------------------------------------------------------
2199! Called by "c_p", [re]allocate the time axes
2200!---------------------------------------------------------------------
2201  IMPLICIT NONE
2202!-
2203  LOGICAL,INTENT(IN) :: l_msg
2204  CHARACTER(LEN=*),INTENT(IN) :: c_p
2205!-
2206  INTEGER :: i_err,tszij
2207  INTEGER,ALLOCATABLE :: tmp_index(:,:)
2208  REAL,ALLOCATABLE :: tmp_julian(:,:)
2209!---------------------------------------------------------------------
2210!-
2211!  Allocate the space we need for the time axes
2212!-
2213  IF (.NOT.ALLOCATED(t_index) .AND. .NOT.ALLOCATED(t_julian)) THEN
2214    IF (l_msg) THEN
2215      WRITE(*,*) TRIM(c_p)//' : Allocate times axes at :', &
2216 &               max_file,tax_size_in(nb_fi)
2217    ENDIF
2218!---
2219    ALLOCATE(t_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
2220    IF (i_err/=0) THEN
2221      WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err
2222      CALL ipslerr (3,TRIM(c_p), &
2223 &      'Problem in allocation of t_index','', &
2224 &      '(you must increase memory)')
2225    ENDIF
2226    t_index (:,:) = 0
2227!---
2228    ALLOCATE(t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
2229    IF (i_err/=0) THEN
2230      WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err
2231      CALL ipslerr (3,TRIM(c_p), &
2232 &      'Problem in allocation of max_file,tax_size_in','', &
2233 &      '(you must increase memory)')
2234    ENDIF
2235    t_julian (:,:) = 0.0
2236  ELSE IF (    (SIZE(t_index,DIM=2)  < tax_size_in(nb_fi)) &
2237 &         .OR.(SIZE(t_julian,DIM=2) < tax_size_in(nb_fi)) ) THEN
2238    IF (l_msg) THEN
2239      WRITE(*,*) TRIM(c_p)//' : Reallocate times axes at :', &
2240 &               max_file,tax_size_in(nb_fi)
2241    ENDIF
2242!---
2243    ALLOCATE (tmp_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
2244    IF (i_err/=0) THEN
2245      WRITE(*,*) "ERROR IN ALLOCATION of tmp_index : ",i_err
2246      CALL ipslerr (3,TRIM(c_p), &
2247 &      'Problem in allocation of tmp_index','', &
2248 &      '(you must increase memory)')
2249    ENDIF
2250    tszij = SIZE(t_index,DIM=2)
2251    tmp_index(:,1:tszij) = t_index(:,1:tszij)
2252    DEALLOCATE(t_index)
2253    ALLOCATE (t_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
2254    IF (i_err/=0) THEN
2255      WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err
2256      CALL ipslerr (3,TRIM(c_p), &
2257 &     'Problem in reallocation of t_index','', &
2258 &     '(you must increase memory)')
2259    ENDIF
2260    t_index(:,1:tszij) = tmp_index(:,1:tszij)
2261!---
2262    ALLOCATE (tmp_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
2263    IF (i_err/=0) THEN
2264      WRITE(*,*) "ERROR IN ALLOCATION of tmp_julian : ",i_err
2265      CALL ipslerr (3,TRIM(c_p), &
2266 &     'Problem in allocation of tmp_julian','', &
2267 &     '(you must increase memory)')
2268    ENDIF
2269    tszij = SIZE(t_julian,DIM=2)
2270    tmp_julian(:,1:tszij) = t_julian(:,1:tszij)
2271    DEALLOCATE(t_julian)
2272    ALLOCATE (t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
2273    IF (i_err/=0) THEN
2274      WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err
2275      CALL ipslerr (3,TRIM(c_p), &
2276 &      'Problem in reallocation of t_julian','', &
2277 &      '(you must increase memory)')
2278    ENDIF
2279    t_julian(:,1:tszij) = tmp_julian(:,1:tszij)
2280  ENDIF
2281!-----------------------
2282END SUBROUTINE rest_atim
2283!===
2284SUBROUTINE rest_alloc (i_buff,i_qsz,l_msg,c_p)
2285!---------------------------------------------------------------------
2286! Called by "c_p", allocate a temporary buffer
2287! (buff_tmp[1/2] depending on "i_buff" value) to the size "i_qsz".
2288!---------------------------------------------------------------------
2289  IMPLICIT NONE
2290!-
2291  INTEGER,INTENT(IN) :: i_buff,i_qsz
2292  LOGICAL,INTENT(IN) :: l_msg
2293  CHARACTER(LEN=*),INTENT(IN) :: c_p
2294!-
2295  INTEGER :: i_bsz,i_err
2296  LOGICAL :: l_alloc1,l_alloc2
2297  CHARACTER(LEN=9) :: cbn
2298  CHARACTER(LEN=5) :: c_err
2299!---------------------------------------------------------------------
2300  IF      (i_buff == 1) THEN
2301    IF (ALLOCATED(buff_tmp1)) THEN
2302      i_bsz = SIZE(buff_tmp1)
2303    ELSE
2304      i_bsz = 0
2305    ENDIF
2306    l_alloc1 =    (.NOT.ALLOCATED(buff_tmp1)) &
2307 &            .OR.((ALLOCATED(buff_tmp1)).AND.(i_qsz > i_bsz))
2308    l_alloc2 = .FALSE.
2309    cbn = 'buff_tmp1'
2310  ELSE IF (i_buff == 2) THEN
2311    IF (ALLOCATED(buff_tmp2)) THEN
2312      i_bsz = SIZE(buff_tmp2)
2313    ELSE
2314      i_bsz = 0
2315    ENDIF
2316    l_alloc1 = .FALSE.
2317    l_alloc2 =    (.NOT.ALLOCATED(buff_tmp2)) &
2318 &            .OR.((ALLOCATED(buff_tmp2)).AND.(i_qsz > i_bsz))
2319    cbn = 'buff_tmp2'
2320  ELSE
2321    CALL ipslerr (3,'rest_alloc', &
2322 &    'Called by '//TRIM(c_p),'with a wrong value of i_buff','')
2323  ENDIF
2324!-
2325!-
2326  IF (l_alloc1.OR.l_alloc2) THEN
2327    IF (l_msg) THEN
2328      IF (    (l_alloc1.AND.ALLOCATED(buff_tmp1)) &
2329 &        .OR.(l_alloc2.AND.ALLOCATED(buff_tmp2)) ) THEN
2330        WRITE(*,*) TRIM(c_p)//" : re_allocate "//TRIM(cbn)//"=",i_qsz
2331      ELSE
2332        WRITE(*,*) TRIM(c_p)//" : allocate "//TRIM(cbn)//"=",i_qsz
2333      ENDIF
2334    ENDIF
2335    IF (l_alloc1) THEN
2336      IF (ALLOCATED(buff_tmp1)) THEN
2337        DEALLOCATE(buff_tmp1)
2338      ENDIF
2339      ALLOCATE (buff_tmp1(i_qsz),STAT=i_err)
2340    ELSE
2341      IF (ALLOCATED(buff_tmp2)) THEN
2342        DEALLOCATE(buff_tmp2)
2343      ENDIF
2344      ALLOCATE (buff_tmp2(i_qsz),STAT=i_err)
2345    ENDIF
2346    IF (i_err /= 0) THEN
2347      WRITE (UNIT=c_err,FMT='(I5)') i_err
2348      CALL ipslerr (3,TRIM(c_p), &
2349 &      'Problem in allocation of',TRIM(cbn), &
2350 &      'Error : '//TRIM(c_err)//' (you must increase memory)')
2351    ENDIF
2352  ENDIF
2353!------------------------
2354END SUBROUTINE rest_alloc
2355!===
2356SUBROUTINE ioconf_setatt (attname,value)
2357!---------------------------------------------------------------------
2358  IMPLICIT NONE
2359!-
2360  CHARACTER(LEN=*) :: attname,value
2361!-
2362! LOCAL
2363!-
2364  CHARACTER(LEN=LEN_TRIM(attname)) :: tmp_str
2365!---------------------------------------------------------------------
2366  tmp_str = attname
2367  CALL strlowercase (tmp_str)
2368!-
2369  SELECT CASE(tmp_str)
2370    CASE('units')
2371      rest_units = value
2372    CASE('long_name')
2373      rest_lname = value
2374    CASE DEFAULT
2375      CALL ipslerr (2,'ioconf_restatt', &
2376        'The attribute name provided is unknown',attname,' ')
2377  END SELECT
2378!---------------------------
2379END SUBROUTINE ioconf_setatt
2380!===
2381SUBROUTINE ioget_vdim (fid,vname_q,varnbdim_max,varnbdim,vardims)
2382!---------------------------------------------------------------------
2383!- This routine allows the user to get the dimensions
2384!- of a field in the restart file.
2385!- This is the file which is read.
2386!---------------------------------------------------------------------
2387  IMPLICIT NONE
2388!-
2389  INTEGER,INTENT(IN) :: fid
2390  CHARACTER(LEN=*) :: vname_q
2391  INTEGER,INTENT(IN) :: varnbdim_max
2392  INTEGER,INTENT(OUT) ::  varnbdim
2393  INTEGER,DIMENSION(varnbdim_max),INTENT(OUT) :: vardims
2394!-
2395! LOCAL
2396!-
2397  INTEGER :: vnb
2398!---------------------------------------------------------------------
2399! Find the index of the variable
2400  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb)
2401!-
2402  IF (vnb > 0) THEN
2403    varnbdim = varnbdim_in(fid,vnb)
2404    IF (varnbdim_max < varnbdim) THEN
2405      CALL ipslerr (3,'ioget_vdim', &
2406        'The provided array for the variable dimensions is too small', &
2407        '','')
2408    ELSE
2409      vardims(1:varnbdim) = vardims_in(fid,vnb,1:varnbdim)
2410    ENDIF
2411  ELSE
2412    varnbdim = 0
2413    CALL ipslerr (2,'ioget_vdim', &
2414      'Variable '//TRIM(vname_q)//' not found','','')
2415  ENDIF
2416!------------------------
2417END SUBROUTINE ioget_vdim
2418!===
2419SUBROUTINE ioget_vname (fid,nbvar,varnames)
2420!---------------------------------------------------------------------
2421!- This routine allows the user to extract the list
2422!- of variables in an opened restart file.
2423!- This is the file which is read
2424!---------------------------------------------------------------------
2425  IMPLICIT NONE
2426!-
2427  INTEGER,INTENT(IN) :: fid
2428  INTEGER,INTENT(OUT) ::  nbvar
2429  CHARACTER(LEN=*),INTENT(OUT) :: varnames(:)
2430!---------------------------------------------------------------------
2431  nbvar = nbvar_in(fid)
2432!-
2433  IF (SIZE(varnames) < nbvar) THEN
2434    CALL ipslerr (3,'ioget_vname', &
2435      'The provided array for the variable names is too small','','')
2436  ELSE
2437    varnames(1:nbvar) = varname_in(fid,1:nbvar)
2438  ENDIF
2439!-------------------------
2440END SUBROUTINE ioget_vname
2441!===
2442SUBROUTINE ioconf_expval (new_exp_val)
2443!---------------------------------------------------------------------
2444!- The default value written into the variables which are not
2445!- in the restart file can only be changed once.
2446!- This avoids further complications.
2447!---------------------------------------------------------------------
2448  IMPLICIT NONE
2449!-
2450  REAL :: new_exp_val
2451!---------------------------------------------------------------------
2452  IF (.NOT.lock_valexp) THEN
2453    lock_valexp = .TRUE.
2454    val_exp = new_exp_val
2455  ELSE
2456    CALL ipslerr (2,'ioconf_expval', &
2457     'The default value for variable' &
2458   //'not available in the restart file ', &
2459     'has already been locked and can not be changed at this point', &
2460     ' ')
2461  ENDIF
2462!---------------------------
2463END SUBROUTINE ioconf_expval
2464!===
2465SUBROUTINE ioget_expval (get_exp_val)
2466!---------------------------------------------------------------------
2467!- Once the user has extracted the default value,
2468!- we lock it so that it can not be changed anymore.
2469!---------------------------------------------------------------------
2470  IMPLICIT NONE
2471!-
2472  REAL :: get_exp_val
2473!---------------------------------------------------------------------
2474  get_exp_val = val_exp
2475  lock_valexp = .TRUE.
2476!--------------------------
2477END SUBROUTINE ioget_expval
2478!===
2479SUBROUTINE restclo (fid)
2480!---------------------------------------------------------------------
2481!- This subroutine closes one or any opened restart file.
2482!-
2483!- INPUT
2484!-
2485!- fid    : File ID in the restcom system (not the netCDF ID)(optional)
2486!-
2487!- OUTPUT
2488!-
2489!- NONE
2490!---------------------------------------------------------------------
2491  IMPLICIT NONE
2492!-
2493  INTEGER,INTENT(in),OPTIONAL :: fid
2494!-
2495!- LOCAL
2496!-
2497  INTEGER :: iret,ifnc
2498  CHARACTER(LEN=6) :: n_e
2499  CHARACTER(LEN=3) :: n_f
2500  LOGICAL :: check = .FALSE.
2501!---------------------------------------------------------------------
2502  IF (PRESENT(fid)) THEN
2503!---
2504    IF (check) THEN
2505      WRITE(*,*) &
2506        'restclo : Closing specified restart file number :', &
2507        fid,netcdf_id(fid,1:2)
2508    ENDIF
2509!---
2510    IF (netcdf_id(fid,1) > 0) THEN
2511      iret = NF90_CLOSE(netcdf_id(fid,1))
2512      IF (iret /= NF90_NOERR) THEN
2513        WRITE (n_e,'(I6)') iret
2514        WRITE (n_f,'(I3)') netcdf_id(fid,1)
2515        CALL ipslerr (2,'restclo', &
2516          "Error "//n_e//" in closing file : "//n_f,'',' ')
2517      ENDIF
2518      IF (netcdf_id(fid,1) == netcdf_id(fid,2)) THEN
2519        netcdf_id(fid,2) = -1
2520      ENDIF
2521      netcdf_id(fid,1) = -1
2522    ENDIF
2523!---
2524    IF (netcdf_id(fid,2) > 0)  THEN
2525      iret = NF90_CLOSE(netcdf_id(fid,2))
2526      IF (iret /= NF90_NOERR) THEN
2527        WRITE (n_e,'(I6)') iret
2528        WRITE (n_f,'(I3)') netcdf_id(fid,2)
2529        CALL ipslerr (2,'restclo', &
2530          "Error "//n_e//" in closing file : "//n_f,'',' ')
2531      ENDIF
2532      netcdf_id(fid,2) = -1
2533    ENDIF
2534!---
2535  ELSE
2536!---
2537    IF (check) WRITE(*,*) 'restclo : Closing all files'
2538!---
2539    DO ifnc=1,nb_fi
2540      IF (netcdf_id(ifnc,1) > 0) THEN
2541        iret = NF90_CLOSE(netcdf_id(ifnc,1))
2542        IF (iret /= NF90_NOERR) THEN
2543          WRITE (n_e,'(I6)') iret
2544          WRITE (n_f,'(I3)') netcdf_id(ifnc,1)
2545          CALL ipslerr (2,'restclo', &
2546            "Error "//n_e//" in closing file : "//n_f,'',' ')
2547        ENDIF
2548        IF (netcdf_id(ifnc,1) == netcdf_id(ifnc,2)) THEN
2549          netcdf_id(ifnc,2) = -1
2550        ENDIF
2551        netcdf_id(ifnc,1) = -1
2552      ENDIF
2553!-----
2554      IF (netcdf_id(ifnc,2) > 0) THEN
2555        iret = NF90_CLOSE(netcdf_id(ifnc,2))
2556        IF (iret /= NF90_NOERR) THEN
2557          WRITE (n_e,'(I6)') iret
2558          WRITE (n_f,'(I3)') netcdf_id(ifnc,2)
2559          CALL ipslerr (2,'restclo', &
2560            "Error "//n_e//" in closing file : "//n_f,'',' ')
2561        END IF
2562        netcdf_id(ifnc,2) = -1
2563      ENDIF
2564    ENDDO
2565  ENDIF
2566!---------------------
2567END SUBROUTINE restclo
2568!===
2569!-----------------
2570END MODULE restcom
Note: See TracBrowser for help on using the repository browser.