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

Last change on this file since 4747 was 4747, checked in by jgipsl, 5 years ago

As done in [4746]: Corrected bug when reading/writing restart variables with 4 or 5 dimensions. Note that this option is not used in the current reference versions of the modeles.

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