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

Last change on this file since 1378 was 1378, checked in by mmaipsl, 11 years ago

Enhancement : use ipslout number from errioipsl to redirect all prints of IOIPSL
in the local process when use with parallelization.
This variable ipslout can be modified with ipslnlf function of errioipsl module.

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