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

Last change on this file since 4863 was 4863, checked in by jgipsl, 4 years ago

Following changes have been done by A.Jornet/LSCE. No change is results and no change in usage have been seen. Some more error checking might stop the model for example if dimensions are not correct in call to histcom module.

Restcom:

  • Define a new var size length (20 to 100 )→ pbs found without no errors
  • Raise an error when var name is too long
  • Deallocate any buffer at the end of all restput/restcget calls → buffers only increase size. After loading/saving nothing is done with this memory

Histcom:

  • Raise an error if given history declared variables do not match with given dimensions from histwrite

getincom and stringop:

  • Enable any length character for the run.def → useful for long filepaths

flincom

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