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

Last change on this file since 3190 was 3190, checked in by jgipsl, 7 years ago
  • Removed _FillValue added in previous commit
  • Correction on list_dims: only 1 dimension must be passed

/ A. Jornet-Puig, LSCE

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