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

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

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

Restcom:

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

Histcom:

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

getincom and stringop:

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

flincom

  • Enable filenames longer than 80 chars to any
  • Deallocate buffers at the end of any flinget subroutine
  • Property svn:keywords set to Id
File size: 81.7 KB
Line 
1MODULE histcom
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!-
8  USE netcdf
9!-
10  USE stringop, ONLY : nocomma,cmpblank,findpos,find_str,strlowercase
11  USE mathelp,  ONLY : mathop,moycum,moycum_index,buildop
12  USE fliocom,  ONLY : flio_dom_file,flio_dom_att
13  USE calendar
14  USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout
15!-
16  IMPLICIT NONE
17!-
18  PRIVATE
19  PUBLIC :: histbeg,histdef,histhori,histvert,histend, &
20 &          histwrite,histclo,histsync,ioconf_modname, histglobal_attr
21!---------------------------------------------------------------------
22!- Some confusing vocabulary in this code !
23!- =========================================
24!-
25!- A REGULAR grid is a grid which is i,j indexes
26!- and thus it is stored in a 2D matrix.
27!- This is opposed to a IRREGULAR grid which is only in a vector
28!- and where we do not know which neighbors we have.
29!- As a consequence we need the bounds for each grid-cell.
30!-
31!- A RECTILINEAR grid is a special case of a regular grid
32!- in which all longitudes for i constant are equal
33!- and all latitudes for j constant.
34!- In other words we do not need the full 2D matrix
35!- to describe the grid, just two vectors.
36!---------------------------------------------------------------------
37!-
38  INTERFACE histbeg
39    MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg
40  END INTERFACE
41!-
42  INTERFACE histhori
43    MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg
44  END INTERFACE
45!-
46  INTERFACE histwrite
47!---------------------------------------------------------------------
48!- The "histwrite" routines will give the data to the I/O system.
49!- It will trigger the operations to be performed,
50!- and the writting to the file if needed
51!-
52!- We test for the work to be done at this time here so that at a
53!- later stage we can call different operation and write subroutine
54!- for the REAL and INTEGER interfaces
55!-
56!- INPUT
57!- idf      : The ID of the file on which this variable is to be,
58!-            written. The variable should have been defined in
59!-            this file before.
60!- pvarname : The short name of the variable
61!- pitau    : Current timestep
62!- pdata    : The variable, I mean the real data !
63!- nbindex  : The number of indexes provided. If it is equal to
64!-            the size of the full field as provided in histdef
65!-            then nothing is done.
66!- nindex   : The indices used to expand the variable (pdata)
67!-            onto the full field.
68!---------------------------------------------------------------------
69!- histwrite - we have to prepare different type of fields :
70!-             real and integer, 1,2 or 3D
71    MODULE PROCEDURE histwrite_r1d,histwrite_r2d,histwrite_r3d
72  END INTERFACE
73!-
74! Fixed parameter
75!-
76  INTEGER,PARAMETER :: nb_files_max=20,nb_var_max=1000, &
77 &                     nb_hax_max=5,nb_zax_max=30,nbopp_max=10
78  REAL,PARAMETER :: missing_val=nf90_fill_real
79  INTEGER,PARAMETER,PUBLIC :: &
80 &  hist_r4=nf90_real4, hist_r8=nf90_real8
81!-
82! Variable derived type
83!-
84TYPE T_D_V
85  INTEGER :: ncvid
86  INTEGER :: nbopp
87  CHARACTER(LEN=20)  :: v_name,unit_name
88  CHARACTER(LEN=256) :: title,std_name
89  CHARACTER(LEN=80)  :: fullop
90  CHARACTER(LEN=7)   :: topp
91  CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp
92  REAL,DIMENSION(nbopp_max) :: scal
93!-External type (for R4/R8)
94  INTEGER :: v_typ
95!-Sizes of the associated grid and zommed area
96  INTEGER,DIMENSION(3) :: scsize,zorig,zsize
97!-Sizes for the data as it goes through the various math operations
98  INTEGER,DIMENSION(3) :: datasz_in = -1
99  INTEGER :: datasz_max = -1
100!-
101  INTEGER :: h_axid,z_axid,t_axid
102!-
103  REAL,DIMENSION(2) :: hist_minmax
104  LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE.
105!-Book keeping of the axes
106  INTEGER :: tdimid,tbndid=-1,tax_last
107  LOGICAL :: l_bnd
108  CHARACTER(LEN=40) :: tax_name
109!-
110  REAL :: freq_opp,freq_wrt
111  INTEGER :: &
112 &  last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt
113!- For future optimization
114  REAL,POINTER,DIMENSION(:) :: t_bf
115!#  REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D
116!#  REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D
117!#  REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D
118END TYPE T_D_V
119!-
120! File derived type
121!-
122TYPE :: T_D_F
123!-NETCDF IDs for file
124  INTEGER :: ncfid=-1
125!-Name of the file
126  CHARACTER(LEN=120) :: name
127!-Time variables
128  INTEGER :: itau0=0
129  REAL :: date0,deltat
130!-Counter of elements (variables, time-horizontal-vertical axis
131  INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0
132!-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude
133  INTEGER :: tid,bid,xid,yid
134!-General definitions in the NETCDF file
135  INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz
136!-The horizontal axes
137  CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name
138!-The vertical axes
139  INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids
140  CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name
141!-
142  LOGICAL :: regular=.TRUE.
143!-DOMAIN ID
144  INTEGER :: dom_id_svg=-1
145!-
146  TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V
147END TYPE T_D_F
148!-
149TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F
150!-
151! A list of functions which require special action
152! (Needs to be updated when functions are added
153!  but they are well located here)
154!-
155  CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill'
156!- Some configurable variables with locks
157  CHARACTER(LEN=80),SAVE :: model_name='An IPSL model'
158  LOGICAL,SAVE :: lock_modname=.FALSE.
159!-
160!===
161CONTAINS
162!===
163!-
164SUBROUTINE histb_reg1d                 &
165 & (pfilename,pim,plon,pjm,plat,       &
166 &  par_orix,par_szx,par_oriy,par_szy, &
167 &  pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
168!---------------------------------------------------------------------
169!- histbeg for 1D regular horizontal coordinates (see histb_all)
170!---------------------------------------------------------------------
171  IMPLICIT NONE
172!-
173  CHARACTER(LEN=*) :: pfilename
174  INTEGER,INTENT(IN) :: pim,pjm
175  REAL,DIMENSION(pim),INTENT(IN) :: plon
176  REAL,DIMENSION(pjm),INTENT(IN) :: plat
177  INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy
178  INTEGER,INTENT(IN) :: pitau0
179  REAL,INTENT(IN) :: pdate0,pdeltat
180  INTEGER,INTENT(OUT) :: idf,phoriid
181  INTEGER,INTENT(IN),OPTIONAL :: domain_id
182  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
183!---------------------------------------------------------------------
184  CALL histb_all &
185 & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, &
186 &  x_1d=plon,y_1d=plat, &
187 &  k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, &
188 &  domain_id=domain_id,mode=mode)
189!-------------------------
190END SUBROUTINE histb_reg1d
191!===
192SUBROUTINE histb_reg2d &
193 & (pfilename,pim,plon,pjm,plat,       &
194 &  par_orix,par_szx,par_oriy,par_szy, &
195 &  pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
196!---------------------------------------------------------------------
197!- histbeg for 2D regular horizontal coordinates (see histb_all)
198!---------------------------------------------------------------------
199  IMPLICIT NONE
200!-
201  CHARACTER(LEN=*) :: pfilename
202  INTEGER,INTENT(IN) :: pim,pjm
203  REAL,DIMENSION(pim,pjm),INTENT(IN) :: plon,plat
204  INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy
205  INTEGER,INTENT(IN) :: pitau0
206  REAL,INTENT(IN) :: pdate0,pdeltat
207  INTEGER,INTENT(OUT) :: idf,phoriid
208  INTEGER,INTENT(IN),OPTIONAL :: domain_id
209  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
210!---------------------------------------------------------------------
211  CALL histb_all &
212 & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf,  &
213 &  x_2d=plon,y_2d=plat, &
214 &  k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy,    &
215 &  domain_id=domain_id,mode=mode)
216!-------------------------
217END SUBROUTINE histb_reg2d
218!===
219SUBROUTINE histb_irreg &
220 &  (pfilename,pim,plon,plon_bounds,plat,plat_bounds, &
221 &   pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
222!---------------------------------------------------------------------
223!- histbeg for irregular horizontal coordinates (see histb_all)
224!---------------------------------------------------------------------
225  IMPLICIT NONE
226!-
227  CHARACTER(LEN=*) :: pfilename
228  INTEGER,INTENT(IN) :: pim
229  REAL,DIMENSION(pim),INTENT(IN) :: plon,plat
230  REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds
231  INTEGER,INTENT(IN) :: pitau0
232  REAL,INTENT(IN) :: pdate0,pdeltat
233  INTEGER,INTENT(OUT) :: idf,phoriid
234  INTEGER,INTENT(IN),OPTIONAL :: domain_id
235  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
236!---------------------------------------------------------------------
237  CALL histb_all &
238 & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf,  &
239 &  x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, &
240 &  domain_id=domain_id,mode=mode)
241!-------------------------
242END SUBROUTINE histb_irreg
243!===
244SUBROUTINE histb_all &
245 & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, &
246 &  x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, &
247 &  x_bnds,y_bnds,domain_id,mode)
248!---------------------------------------------------------------------
249!- General interface for horizontal grids.
250!- This subroutine initializes a netcdf file and returns the ID.
251!- It will set up the geographical space on which the data will be
252!- stored and offers the possibility of seting a zoom.
253!- In the case of irregular grids, all the data comes in as vectors
254!- and for the grid we have the coordinates of the 4 corners.
255!- It also gets the global parameters into the I/O subsystem.
256!-
257!- INPUT
258!-
259!- k_typ    : Type of the grid (1 rectilinear, 2 regular, 3 irregular)
260!- nc_name  : Name of the netcdf file to be created
261!- pim      : Size of arrays in longitude direction
262!- pjm      : Size of arrays in latitude direction (pjm=pim for type 3)
263!-
264!- pitau0   : time step at which the history tape starts
265!- pdate0   : The Julian date at which the itau was equal to 0
266!- pdeltat  : Time step, in seconds, of the counter itau
267!-            used in histwrite for instance
268!-
269!- OUTPUT
270!-
271!- phoriid  : Identifier of the horizontal grid
272!- idf      : Identifier of the file
273!-
274!- Optional INPUT arguments
275!-
276!- For rectilinear or irregular grid
277!- x_1d  : The longitudes
278!- y_1d  : The latitudes
279!- For regular grid
280!- x_2d  : The longitudes
281!- y_2d  : The latitudes
282!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied.
283!-
284!- For regular grid (reg1d or reg2d),
285!- the next 4 arguments allow to define a horizontal zoom
286!- for this file. It is assumed that all variables to come
287!- have the same index space. This can not be assumed for
288!- the z axis and thus we define the zoom in histdef.
289!- k_orx  : Origin of the slab of data within the X axis (pim)
290!- k_szx  : Size of the slab of data in X
291!- k_ory  : Origin of the slab of data within the Y axis (pjm)
292!- k_szy  : Size of the slab of data in Y
293!-
294!- For irregular grid.
295!- x_bnds : The boundaries of the grid in longitude
296!- y_bnds : The boundaries of the grid in latitude
297!-
298!- For all grids.
299!-
300!- domain_id  : Domain identifier
301!-
302!- mode       : String of (case insensitive) blank-separated words
303!-              defining the mode used to create the file.
304!-              Supported keywords : 32, 64
305!-              "32/64" defines the offset mode.
306!-              The default offset mode is 64 bits.
307!-              Keywords "NETCDF4" and "CLASSIC" are reserved
308!-              for future use.
309!---------------------------------------------------------------------
310  IMPLICIT NONE
311!-
312  INTEGER,INTENT(IN) :: k_typ
313  CHARACTER(LEN=*),INTENT(IN) :: nc_name
314  INTEGER,INTENT(IN) :: pim,pjm
315  INTEGER,INTENT(IN) :: pitau0
316  REAL,INTENT(IN) :: pdate0,pdeltat
317  INTEGER,INTENT(OUT) :: idf,phoriid
318  REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d
319  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d
320  INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy
321  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds
322  INTEGER,INTENT(IN),OPTIONAL :: domain_id
323  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
324!-
325  INTEGER :: nfid,iret,m_c
326  CHARACTER(LEN=120) :: file
327  CHARACTER(LEN=30) :: timenow
328  CHARACTER(LEN=11) :: c_nam
329  LOGICAL :: l_dbg
330!---------------------------------------------------------------------
331  CALL ipsldbg (old_status=l_dbg)
332!-
333  IF     (k_typ == 1) THEN
334    c_nam = 'histb_reg1d'
335  ELSEIF (k_typ == 2) THEN
336    c_nam = 'histb_reg2d'
337  ELSEIF (k_typ == 3) THEN
338    c_nam = 'histb_irreg'
339  ELSE
340    CALL ipslerr (3,"histbeg", &
341 &    'Illegal value of k_typ argument','in internal interface','?')
342  ENDIF
343!-
344  IF (l_dbg) WRITE(ipslout,*) c_nam//" 0.0"
345!-
346! Search for a free index
347!-
348  idf = -1
349  DO nfid=1,nb_files_max
350    IF (W_F(nfid)%ncfid < 0) THEN
351      idf = nfid; EXIT;
352    ENDIF
353  ENDDO
354  IF (idf < 0) THEN
355    CALL ipslerr (3,"histbeg", &
356   &  'Table of files too small. You should increase nb_files_max', &
357   &  'in histcom.f90 in order to accomodate all these files',' ')
358  ENDIF
359!-
360! 1.0 Transfering into the common for future use
361!-
362  IF (l_dbg) WRITE(ipslout,*) c_nam//" 1.0"
363!-
364  W_F(idf)%itau0  = pitau0
365  W_F(idf)%date0  = pdate0
366  W_F(idf)%deltat = pdeltat
367!-
368! 2.0 Initializes all variables for this file
369!-
370  IF (l_dbg) WRITE(ipslout,*) c_nam//" 2.0"
371!-
372  W_F(idf)%n_var = 0
373  W_F(idf)%n_tax = 0
374  W_F(idf)%n_hax = 0
375  W_F(idf)%n_zax = 0
376!-
377  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
378    W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /)
379    W_F(idf)%slab_siz(1:2)  = (/ k_szx,k_szy /)
380  ELSE
381    W_F(idf)%slab_ori(1:2) = (/ 1,1 /)
382    W_F(idf)%slab_siz(1:2) = (/ pim,1 /)
383  ENDIF
384!-
385! 3.0 Opening netcdf file and defining dimensions
386!-
387  IF (l_dbg) WRITE(ipslout,*) c_nam//" 3.0"
388!-
389! Add DOMAIN number and ".nc" suffix in file name if needed
390!-
391  file = nc_name
392  CALL flio_dom_file (file,domain_id)
393!-
394! Check the mode
395!? See fliocom for HDF4 ????????????????????????????????????????????????
396!-
397  IF (PRESENT(mode)) THEN
398    SELECT CASE (TRIM(mode))
399    CASE('32')
400      m_c = NF90_CLOBBER
401    CASE('64')
402      m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)
403    CASE DEFAULT
404      CALL ipslerr (3,"histbeg", &
405 &      'Invalid argument mode for file :',TRIM(file), &
406 &      'Supported values are 32 or 64')
407    END SELECT
408  ELSE
409    m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)
410  ENDIF
411!-
412! Create file
413!-
414  iret = NF90_CREATE(file,m_c,nfid)
415!-
416  IF     (k_typ == 1) THEN
417    iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid)
418    iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid)
419  ELSEIF (k_typ == 2) THEN
420    iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid)
421    iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid)
422  ELSEIF (k_typ == 3) THEN
423    iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid)
424    W_F(idf)%yid = W_F(idf)%xid
425  ENDIF
426!-
427! 4.0 Declaring the geographical coordinates and other attributes
428!-
429  IF (l_dbg) WRITE(ipslout,*) c_nam//" 4.0"
430!-
431  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1')
432  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file))
433  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name))
434  lock_modname = .TRUE.
435  CALL ioget_timestamp (timenow)
436  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))
437!-
438! 5.0 Saving some important information on this file in the common
439!-
440  IF (l_dbg) WRITE(ipslout,*) c_nam//" 5.0"
441!-
442  IF (PRESENT(domain_id)) THEN
443    W_F(idf)%dom_id_svg = domain_id
444  ENDIF
445  W_F(idf)%name = TRIM(nc_name)
446  W_F(idf)%ncfid = nfid
447  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
448    W_F(idf)%full_size(1:2) = (/ pim,pjm /)
449    W_F(idf)%regular=.TRUE.
450  ELSEIF (k_typ == 3) THEN
451    W_F(idf)%full_size(1:2) = (/ pim,1 /)
452    W_F(idf)%regular=.FALSE.
453  ENDIF
454!-
455! 6.0 storing the geographical coordinates
456!-
457  IF     (k_typ == 1) THEN
458    CALL histh_all &
459 &   (k_typ,idf,pim,pjm,' ','Default grid',phoriid, &
460 &    x_1d=x_1d,y_1d=y_1d)
461  ELSEIF (k_typ == 2) THEN
462    CALL histh_all &
463 &   (k_typ,idf,pim,pjm,' ','Default grid',phoriid, &
464 &    x_2d=x_2d,y_2d=y_2d)
465  ELSEIF (k_typ == 3) THEN
466    CALL histh_all &
467 &   (k_typ,idf,pim,pim,' ','Default grid',phoriid, &
468 &    x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds)
469  ENDIF
470!-----------------------
471END SUBROUTINE histb_all
472!===
473SUBROUTINE histglobal_attr &
474 & (idf,string_attr,glob_attr)
475!---------------------------------------------------------------------
476!- Definition of GLOBAL attribute for history files.
477!-
478!- INPUT
479!-
480!- idf     : The id of the file to which the grid should be added
481!- string_attr : name of the global attribute to be added
482!- glob_attr : global_attribute to be added
483!---------------------------------------------------------------------
484  IMPLICIT NONE
485!-
486  INTEGER,INTENT(IN) :: idf
487  CHARACTER(len=*),INTENT(IN) :: string_attr
488  CHARACTER(len=*),INTENT(IN) :: glob_attr
489
490  INTEGER :: iret,nfid
491  LOGICAL :: l_dbg
492!---------------------------------------------------------------------
493  CALL ipsldbg (old_status=l_dbg)
494
495  nfid = W_F(idf)%ncfid
496  IF (l_dbg) WRITE(ipslout,*) "New global attribute : ",glob_attr
497  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,string_attr,glob_attr)
498!-----------------------
499END SUBROUTINE histglobal_attr
500!===
501SUBROUTINE histh_reg1d &
502 &  (idf,pim,plon,pjm,plat,phname,phtitle,phid)
503!---------------------------------------------------------------------
504!- histhori for 1d regular grid (see histh_all)
505!---------------------------------------------------------------------
506  IMPLICIT NONE
507!-
508  INTEGER,INTENT(IN) :: idf,pim,pjm
509  REAL,INTENT(IN),DIMENSION(:) :: plon,plat
510  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
511  INTEGER,INTENT(OUT) :: phid
512!---------------------------------------------------------------------
513  CALL histh_all &
514 & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat)
515!-------------------------
516END SUBROUTINE histh_reg1d
517!===
518SUBROUTINE histh_reg2d &
519 & (idf,pim,plon,pjm,plat,phname,phtitle,phid)
520!---------------------------------------------------------------------
521!- histhori for 2d regular grid (see histh_all)
522!---------------------------------------------------------------------
523  IMPLICIT NONE
524!-
525  INTEGER,INTENT(IN) :: idf,pim,pjm
526  REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat
527  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
528  INTEGER,INTENT(OUT) :: phid
529!---------------------------------------------------------------------
530  CALL histh_all &
531 & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat)
532!-------------------------
533END SUBROUTINE histh_reg2d
534!===
535SUBROUTINE histh_irreg &
536 & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid)
537!---------------------------------------------------------------------
538!- histhori for irregular grid (see histh_all)
539!---------------------------------------------------------------------
540  IMPLICIT NONE
541!-
542  INTEGER,INTENT(IN) :: idf,pim
543  REAL,DIMENSION(:),INTENT(IN) :: plon,plat
544  REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds
545  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
546  INTEGER,INTENT(OUT) :: phid
547!---------------------------------------------------------------------
548  CALL histh_all &
549 & (3,idf,pim,pim,phname,phtitle,phid, &
550 &  x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds)
551!-------------------------
552END SUBROUTINE histh_irreg
553!===
554SUBROUTINE histh_all &
555 & (k_typ,idf,pim,pjm,phname,phtitle,phid, &
556 &  x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds)
557!---------------------------------------------------------------------
558!- General interface for horizontal grids.
559!- This subroutine is made to declare a new horizontal grid.
560!- It has to have the same number of points as
561!- the original and thus in this routine we will only
562!- add two variable (longitude and latitude).
563!- Any variable in the file can thus point to this pair
564!- through an attribute. This routine is very usefull
565!- to allow staggered grids.
566!-
567!- INPUT
568!-
569!- k_typ   : Type of the grid (1 rectilinear, 2 regular, 3 irregular)
570!- idf     : The id of the file to which the grid should be added
571!- pim     : Size in the longitude direction
572!- pjm     : Size in the latitude direction (pjm=pim for type 3)
573!- phname  : The name of grid
574!- phtitle : The title of the grid
575!-
576!- OUTPUT
577!-
578!- phid    : Id of the created grid
579!-
580!- Optional INPUT arguments
581!-
582!- For rectilinear or irregular grid
583!- x_1d  : The longitudes
584!- y_1d  : The latitudes
585!- For regular grid
586!- x_2d  : The longitudes
587!- y_2d  : The latitudes
588!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied.
589!-
590!- For irregular grid.
591!- x_bnds : The boundaries of the grid in longitude
592!- y_bnds : The boundaries of the grid in latitude
593!---------------------------------------------------------------------
594  IMPLICIT NONE
595!-
596  INTEGER,INTENT(IN) :: k_typ
597  INTEGER,INTENT(IN) :: idf,pim,pjm
598  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
599  INTEGER,INTENT(OUT) :: phid
600  REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d
601  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d
602  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds
603!-
604  CHARACTER(LEN=25) :: lon_name,lat_name
605  CHARACTER(LEN=30) :: lonbound_name,latbound_name
606  INTEGER :: i_s,i_e
607  INTEGER,DIMENSION(2) :: dims,dims_b
608  INTEGER :: nbbounds
609  INTEGER :: nlonidb,nlatidb,twoid
610  LOGICAL :: transp = .FALSE.
611  REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans
612  REAL :: wmn,wmx
613  INTEGER :: nlonid,nlatid
614  INTEGER :: o_x,o_y,s_x,s_y
615  INTEGER :: iret,nfid
616  CHARACTER(LEN=11) :: c_nam
617  LOGICAL :: l_dbg
618!---------------------------------------------------------------------
619  CALL ipsldbg (old_status=l_dbg)
620!-
621  IF     (k_typ == 1) THEN
622    c_nam = 'histh_reg1d'
623  ELSEIF (k_typ == 2) THEN
624    c_nam = 'histh_reg2d'
625  ELSEIF (k_typ == 3) THEN
626    c_nam = 'histh_irreg'
627  ELSE
628    CALL ipslerr (3,"histhori", &
629 &    'Illegal value of k_typ argument','in internal interface','?')
630  ENDIF
631!-
632! 1.0 Check that all fits in the buffers
633!-
634  IF (    (pim /= W_F(idf)%full_size(1)) &
635 &    .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2)))  &
636 &    .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN
637    CALL ipslerr (3,"histhori", &
638 &   'The new horizontal grid does not have the same size', &
639 &   'as the one provided to histbeg. This is not yet ', &
640 &   'possible in the hist package.')
641  ENDIF
642!-
643! 1.1 Create all the variables needed
644!-
645  IF (l_dbg) WRITE(ipslout,*) c_nam//" 1.0"
646!-
647  nfid = W_F(idf)%ncfid
648!-
649  IF (k_typ == 3) THEN
650    IF     (SIZE(x_bnds,DIM=1) == pim) THEN
651      nbbounds = SIZE(x_bnds,DIM=2)
652      transp = .TRUE.
653    ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN
654      nbbounds = SIZE(x_bnds,DIM=1)
655      transp = .FALSE.
656    ELSE
657      CALL ipslerr (3,"histhori", &
658 &     'The boundary variable does not have any axis corresponding', &
659 &     'to the size of the longitude or latitude variable','.')
660    ENDIF
661    ALLOCATE(bounds_trans(nbbounds,pim))
662    iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid)
663    dims_b(1:2) = (/ twoid,W_F(idf)%xid /)
664  ENDIF
665!-
666  dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /)
667!-
668  IF     (k_typ == 1) THEN
669    IF (W_F(idf)%n_hax == 0) THEN
670      lon_name = 'lon'
671      lat_name = 'lat'
672    ELSE
673      lon_name = 'lon_'//TRIM(phname)
674      lat_name = 'lat_'//TRIM(phname)
675    ENDIF
676  ELSEIF (k_typ == 2) THEN
677    IF (W_F(idf)%n_hax == 0) THEN
678      lon_name = 'nav_lon'
679      lat_name = 'nav_lat'
680    ELSE
681      lon_name = 'nav_lon_'//TRIM(phname)
682      lat_name = 'nav_lat_'//TRIM(phname)
683    ENDIF
684  ELSEIF (k_typ == 3) THEN
685    IF (W_F(idf)%n_hax == 0) THEN
686      lon_name = 'nav_lon'
687      lat_name = 'nav_lat'
688    ELSE
689      lon_name = 'nav_lon_'//TRIM(phname)
690      lat_name = 'nav_lat_'//TRIM(phname)
691    ENDIF
692    lonbound_name = TRIM(lon_name)//'_bounds'
693    latbound_name = TRIM(lat_name)//'_bounds'
694  ENDIF
695!-
696! 1.2 Save the informations
697!-
698  phid = W_F(idf)%n_hax+1
699  W_F(idf)%n_hax = phid
700  W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /)
701!-
702! 2.0 Longitude
703!-
704  IF (l_dbg) WRITE(ipslout,*) c_nam//" 2.0"
705!-
706  i_s = 1;
707  IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN
708    i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d);
709  ELSEIF (k_typ == 2) THEN
710    i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d);
711  ENDIF
712  iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid)
713  IF (k_typ == 1) THEN
714    iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X")
715  ENDIF
716  iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude")
717  iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east")
718  iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4))
719  iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4))
720  iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude")
721  iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle))
722!-
723  IF (k_typ == 3) THEN
724!---
725!-- 2.1 Longitude bounds
726!---
727    iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name))
728    iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb)
729    iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', &
730 &          'Boundaries for coordinate variable '//TRIM(lon_name))
731  ENDIF
732!-
733! 3.0 Latitude
734!-
735  IF (l_dbg) WRITE(ipslout,*) c_nam//" 3.0"
736!-
737  i_e = 2;
738  IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN
739    i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d);
740  ELSEIF (k_typ == 2) THEN
741    i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d);
742  ENDIF
743  iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid)
744  IF (k_typ == 1) THEN
745    iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y")
746  ENDIF
747!-
748  iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude")
749  iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north")
750  iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4))
751  iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4))
752  iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude")
753  iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle))
754!-
755  IF (k_typ == 3) THEN
756!---
757!-- 3.1 Latitude bounds
758!---
759    iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name))
760    iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb)
761    iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', &
762 &          'Boundaries for coordinate variable '//TRIM(lat_name))
763  ENDIF
764!-
765  iret = NF90_ENDDEF(nfid)
766!-
767! 4.0 storing the geographical coordinates
768!-
769  IF (l_dbg) WRITE(ipslout,*) c_nam//" 4.0"
770!-
771  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
772    o_x = W_F(idf)%slab_ori(1)
773    o_y = W_F(idf)%slab_ori(2)
774    s_x = W_F(idf)%slab_siz(1)
775    s_y = W_F(idf)%slab_siz(2)
776!---
777!-- Transfer the longitude and  the latitude
778!---
779    IF     (k_typ == 1) THEN
780      iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1))
781      iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1))
782    ELSEIF (k_typ == 2) THEN
783      iret = NF90_PUT_VAR(nfid,nlonid, &
784 &            x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1))
785      iret = NF90_PUT_VAR(nfid,nlatid, &
786 &            y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1))
787    ENDIF
788  ELSEIF (k_typ == 3) THEN
789!---
790!-- Transfer the longitude and the longitude bounds
791!---
792    iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim))
793!---
794    IF (transp) THEN
795      bounds_trans = TRANSPOSE(x_bnds)
796    ELSE
797      bounds_trans = x_bnds
798    ENDIF
799    iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim))
800!---
801!-- Transfer the latitude and the latitude bounds
802!---
803    iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim))
804!---
805    IF (transp) THEN
806      bounds_trans = TRANSPOSE(y_bnds)
807    ELSE
808      bounds_trans = y_bnds
809    ENDIF
810    iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim))
811!---
812    DEALLOCATE(bounds_trans)
813  ENDIF
814!-
815  iret = NF90_REDEF(nfid)
816!-----------------------
817END SUBROUTINE histh_all
818!===
819SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, &
820 &                   pzsize,pzvalues,pzaxid,pdirect)
821!---------------------------------------------------------------------
822!- This subroutine defines a vertical axis and returns it s id.
823!- It gives the user the possibility to the user to define many
824!- different vertical axes. For each variable defined with histdef a
825!- vertical axis can be specified with by it s ID.
826!-
827!- INPUT
828!-
829!- idf      : ID of the file the variable should be archived in
830!- pzaxname : Name of the vertical axis
831!- pzaxtitle: title of the vertical axis
832!- pzaxunit : Units of the vertical axis (no units if blank string)
833!- pzsize   : size of the vertical axis
834!- pzvalues : Coordinate values of the vetical axis
835!-
836!- pdirect  : is an optional argument which allows to specify the
837!-            the positive direction of the axis : up or down.
838!- OUTPUT
839!-
840!- pzaxid   : Returns the ID of the axis.
841!-            Note that this is not the netCDF ID !
842!-
843!- VERSION
844!-
845!---------------------------------------------------------------------
846  IMPLICIT NONE
847!-
848  INTEGER,INTENT(IN) :: idf,pzsize
849  CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle
850  REAL,INTENT(IN) :: pzvalues(pzsize)
851  INTEGER,INTENT(OUT) :: pzaxid
852  CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: pdirect
853!-
854  INTEGER :: pos,iv,zdimid,zaxid_tmp
855  CHARACTER(LEN=70) :: str71
856  CHARACTER(LEN=20) :: direction
857  INTEGER :: iret,leng,nfid
858  LOGICAL :: l_dbg
859!---------------------------------------------------------------------
860  CALL ipsldbg (old_status=l_dbg)
861!-
862! 1.0 Verifications :
863!    Do we have enough space for an extra axis ?
864!    Is the name already in use ?
865!-
866  IF (l_dbg) WRITE(ipslout,*) "histvert : 1.0 Verifications", &
867 &                      pzaxname,'---',pzaxunit,'---',pzaxtitle
868!-
869! Direction of the vertical axis. Can we get if from the user.
870!-
871  IF (PRESENT(pdirect)) THEN
872    direction = TRIM(pdirect)
873    CALL strlowercase (direction)
874  ELSE
875    direction = 'unknown'
876  ENDIF
877!-
878! Check the consistency of the attribute
879!-
880  IF (     PRESENT(pdirect)    &
881 &    .AND.(direction /= 'up') &
882 &    .AND.(direction /= 'down') ) THEN
883    direction = 'unknown'
884    CALL ipslerr (2,"histvert",&
885 & "The specified positive direction for the vertical axis is invalid.",&
886 & "The value must be up or down.","The attribute will not be written.")
887  ENDIF
888!-
889  IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN
890    CALL ipslerr (3,"histvert", &
891   &  'Table of vertical axes too small. You should increase ',&
892   &  'nb_zax_max in histcom.f90 in order to accomodate all ', &
893   &  'these variables ')
894  ENDIF
895!-
896  iv = W_F(idf)%n_zax
897  IF (iv > 1) THEN
898    CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos)
899  ELSE
900    pos = 0
901  ENDIF
902!-
903  IF (pos > 0) THEN
904    WRITE(str71,'("Check variable ",A," in file",I3)') &
905 &    TRIM(pzaxname),idf
906    CALL ipslerr (3,"histvert", &
907 &    "Vertical axis already exists",TRIM(str71), &
908 &    "Can also be a wrong file ID in another declaration")
909  ENDIF
910!-
911  iv = W_F(idf)%n_zax+1
912!-
913! 2.0 Add the information to the file
914!-
915  IF (l_dbg) &
916 &  WRITE(ipslout,*) "histvert : 2.0 Add the information to the file"
917!-
918  nfid = W_F(idf)%ncfid
919!-
920  leng = MIN(LEN_TRIM(pzaxname),20)
921  iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp)
922  iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, &
923 &                     zaxid_tmp,zdimid)
924  iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z")
925  iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number")
926  leng = MIN(LEN_TRIM(pzaxunit),20)
927  IF (leng > 0) THEN
928    iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng))
929  ENDIF
930  IF (direction /= 'unknown') THEN
931    iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction))
932  ENDIF
933  iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', &
934 &                     REAL(MINVAL(pzvalues(1:pzsize)),KIND=4))
935  iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', &
936 &                     REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4))
937  leng = MIN(LEN_TRIM(pzaxname),20)
938  iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng))
939  leng = MIN(LEN_TRIM(pzaxtitle),80)
940  iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng))
941!-
942  iret = NF90_ENDDEF (nfid)
943!-
944  iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize))
945!-
946  iret = NF90_REDEF (nfid)
947!-
948!- 3.0 add the information to the common
949!-
950  IF (l_dbg) &
951  &  WRITE(ipslout,*) "histvert : 3.0 add the information to the common"
952!-
953  W_F(idf)%n_zax = iv
954  W_F(idf)%zax_size(iv) = pzsize
955  W_F(idf)%zax_name(iv) = pzaxname
956  W_F(idf)%zax_ids(iv) = zaxid_tmp
957  pzaxid = iv
958!----------------------
959END SUBROUTINE histvert
960!===
961SUBROUTINE histdef &
962 &  (idf,pvarname,ptitle,punit, &
963 &   pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, &
964 &   xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name)
965!---------------------------------------------------------------------
966!- With this subroutine each variable to be archived on the history
967!- tape should be declared.
968!-
969!- It gives the user the choise of operation
970!- to be performed on the variables, the frequency of this operation
971!- and finaly the frequency of the archiving.
972!-
973!- INPUT
974!-
975!- idf      : ID of the file the variable should be archived in
976!- pvarname : Name of the variable, short and easy to remember
977!- ptitle   : Full name of the variable
978!- punit    : Units of the variable (no units if blank string)
979!-
980!- The next 3 arguments give the size of that data
981!- that will be passed to histwrite. The zoom will be
982!- done there with the horizontal information obtained
983!- in histbeg and the vertical information to follow.
984!-
985!- pxsize   : Size in X direction (size of the data that will be
986!-            given to histwrite)
987!- pysize   : Size in Y direction
988!- phoriid  : ID of the horizontal axis
989!-
990!- The next two arguments give the vertical zoom to use.
991!-
992!- pzsize   : Size in Z direction (If 1 then no axis is declared
993!-            for this variable and pzid is not used)
994!- par_oriz : Off set of the zoom
995!- par_szz  : Size of the zoom
996!-
997!- pzid     : ID of the vertical axis to use. It has to have
998!-            the size of the zoom.
999!- xtype    : External netCDF type (hist_r4/hist_r8)
1000!- popp     : Operation to be performed. The following options
1001!-            exist today :
1002!- inst : keeps instantaneous values for writting
1003!- ave  : Computes the average from call between writes
1004!- pfreq_opp: Frequency of this operation (in seconds)
1005!- pfreq_wrt: Frequency at which the variable should be
1006!-            written (in seconds)
1007!- var_range: Range of the variable.
1008!-            If the minimum is greater than the maximum,
1009!-            the values will be calculated.
1010!-
1011!- VERSION
1012!---------------------------------------------------------------------
1013  IMPLICIT NONE
1014!-
1015  INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid
1016  INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid
1017  CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle
1018  REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt
1019  REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range
1020  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name
1021!-
1022  INTEGER :: iv
1023  CHARACTER(LEN=70) :: str70,str71,str72
1024  CHARACTER(LEN=20) :: tmp_name
1025  CHARACTER(LEN=40) :: str40
1026  CHARACTER(LEN=10) :: str10
1027  CHARACTER(LEN=120) :: ex_topps
1028  REAL :: un_an,un_jour,test_fopp,test_fwrt
1029  INTEGER :: pos,buff_sz
1030  LOGICAL :: l_dbg
1031!---------------------------------------------------------------------
1032  CALL ipsldbg (old_status=l_dbg)
1033!-
1034  ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min'
1035!-
1036  W_F(idf)%n_var = W_F(idf)%n_var+1
1037  iv = W_F(idf)%n_var
1038!-
1039  IF (iv > nb_var_max) THEN
1040    CALL ipslerr (3,"histdef", &
1041   &  'Table of variables too small. You should increase nb_var_max',&
1042   &  'in histcom.f90 in order to accomodate all these variables', &
1043   &  ' ')
1044  ENDIF
1045!-
1046! 1.0 Transfer informations on the variable to the common
1047!     and verify that it does not already exist
1048!-
1049  IF (l_dbg) WRITE(ipslout,*) "histdef : 1.0"
1050!-
1051  IF (iv > 1) THEN
1052    CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos)
1053  ELSE
1054    pos = 0
1055  ENDIF
1056!-
1057  IF (pos > 0) THEN
1058    str70 = "Variable already exists"
1059    WRITE(str71,'("Check variable  ",a," in file",I3)') &
1060 &    TRIM(pvarname),idf
1061    str72 = "Can also be a wrong file ID in another declaration"
1062    CALL ipslerr (3,"histdef",str70,str71,str72)
1063  ENDIF
1064!-
1065  W_F(idf)%W_V(iv)%v_name = pvarname
1066  W_F(idf)%W_V(iv)%title = ptitle
1067  W_F(idf)%W_V(iv)%unit_name = punit
1068  IF (PRESENT(standard_name)) THEN
1069    W_F(idf)%W_V(iv)%std_name = standard_name
1070  ELSE
1071    W_F(idf)%W_V(iv)%std_name = ptitle
1072  ENDIF
1073  tmp_name = W_F(idf)%W_V(iv)%v_name
1074!-
1075! 1.1 decode the operations
1076!-
1077  W_F(idf)%W_V(iv)%fullop = popp
1078  CALL buildop &
1079 &  (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, &
1080 &   W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, &
1081 &   W_F(idf)%W_V(iv)%nbopp)
1082!-
1083! 1.2 If we have an even number of operations
1084!     then we need to add identity
1085!-
1086  IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN
1087    W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1
1088    W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident'
1089    W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val
1090  ENDIF
1091!-
1092! 1.3 External type of the variable
1093!-
1094  IF (xtype == hist_r8) THEN
1095    W_F(idf)%W_V(iv)%v_typ = hist_r8
1096  ELSE
1097    W_F(idf)%W_V(iv)%v_typ = hist_r4
1098  ENDIF
1099!-
1100! 2.0 Put the size of the variable in the common and check
1101!-
1102  IF (l_dbg) THEN
1103    WRITE(ipslout,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, &
1104 &    W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), &
1105 &    W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp)
1106  ENDIF
1107!-
1108  W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /)
1109  W_F(idf)%W_V(iv)%zorig(1:3) = &
1110 &  (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /)
1111  W_F(idf)%W_V(iv)%zsize(1:3) = &
1112 &  (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /)
1113!-
1114! Is the size of the full array the same as that of the coordinates ?
1115!-
1116  IF (    (pxsize > W_F(idf)%full_size(1)) &
1117 &    .OR.(pysize > W_F(idf)%full_size(2)) ) THEN
1118!-
1119    str70 = "The size of the variable is different "// &
1120 &          "from the one of the coordinates"
1121    WRITE(str71,'("Size of coordinates :",2I4)') &
1122 &   W_F(idf)%full_size(1),W_F(idf)%full_size(2)
1123    WRITE(str72,'("Size declared for variable ",a," :",2I4)') &
1124 &   TRIM(tmp_name),pxsize,pysize
1125    CALL ipslerr (3,"histdef",str70,str71,str72)
1126  ENDIF
1127!-
1128! Is the size of the zoom smaller than the coordinates ?
1129!-
1130  IF (    (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) &
1131 &    .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN
1132    str70 = &
1133 &   "Size of variable should be greater or equal to those of the zoom"
1134    WRITE(str71,'("Size of XY zoom :",2I4)') &
1135 &   W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2)
1136    WRITE(str72,'("Size declared for variable ",A," :",2I4)') &
1137 &   TRIM(tmp_name),pxsize,pysize
1138    CALL ipslerr (3,"histdef",str70,str71,str72)
1139  ENDIF
1140!-
1141! 2.1 We store the horizontal grid information with minimal
1142!     and a fall back onto the default grid
1143!-
1144  IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN
1145    W_F(idf)%W_V(iv)%h_axid = phoriid
1146  ELSE
1147    W_F(idf)%W_V(iv)%h_axid = 1
1148    CALL ipslerr (2,"histdef", &
1149   &  'We use the default grid for variable as an invalide',&
1150   &  'ID was provided for variable : ',TRIM(pvarname))
1151  ENDIF
1152!-
1153! 2.2 Check the vertical coordinates if needed
1154!-
1155  IF (par_szz > 1) THEN
1156!-
1157!-- Does the vertical coordinate exist ?
1158!-
1159    IF (pzid > W_F(idf)%n_zax) THEN
1160      WRITE(str70, &
1161 &    '("The vertical coordinate chosen for variable ",A)') &
1162 &     TRIM(tmp_name)
1163      str71 = " Does not exist."
1164      CALL ipslerr (3,"histdef",str70,str71," ")
1165    ENDIF
1166!-
1167!-- Is the vertical size of the variable equal to that of the axis ?
1168!-
1169    IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN
1170      str70 = "The size of the zoom does not correspond "// &
1171 &            "to the size of the chosen vertical axis"
1172      WRITE(str71,'("Size of zoom in z :",I4)') par_szz
1173      WRITE(str72,'("Size declared for axis ",A," :",I4)') &
1174 &     TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid)
1175      CALL ipslerr (3,"histdef",str70,str71,str72)
1176    ENDIF
1177!-
1178!-- Is the zoom smaller that the total size of the variable ?
1179!-
1180    IF (pzsize < par_szz) THEN
1181      str70 = "The vertical size of variable "// &
1182 &            "is smaller than that of the zoom."
1183      WRITE(str71,'("Declared vertical size of data :",I5)') pzsize
1184      WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') &
1185 &     TRIM(tmp_name),par_szz
1186      CALL ipslerr (3,"histdef",str70,str71,str72)
1187    ENDIF
1188    W_F(idf)%W_V(iv)%z_axid = pzid
1189  ELSE
1190    W_F(idf)%W_V(iv)%z_axid = -99
1191  ENDIF
1192!-
1193! 3.0 We get the size of the arrays histwrite will get
1194!     and eventually allocate the time_buffer
1195!-
1196  IF (l_dbg) THEN
1197    WRITE(ipslout,*) "histdef : 3.0"
1198  ENDIF
1199!-
1200  buff_sz = W_F(idf)%W_V(iv)%zsize(1) &
1201 &         *W_F(idf)%W_V(iv)%zsize(2) &
1202 &         *W_F(idf)%W_V(iv)%zsize(3)
1203!-
1204  IF (     (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") &
1205 &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") &
1206 &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN
1207    ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz))
1208    W_F(idf)%W_V(iv)%t_bf(:) = missing_val
1209    IF (l_dbg) THEN
1210      WRITE(ipslout,*) "histdef : 3.0 allocating time_buffer for", &
1211 &      " idf = ",idf," iv = ",iv," size = ",buff_sz
1212    ENDIF
1213  ENDIF
1214!-
1215! 4.0 Transfer the frequency of the operations and check
1216!     for validity. We have to pay attention to negative values
1217!     of the frequency which indicate monthly time-steps.
1218!     The strategy is to bring it back to seconds for the tests
1219!-
1220  IF (l_dbg) WRITE(ipslout,*) "histdef : 4.0"
1221!-
1222  W_F(idf)%W_V(iv)%freq_opp = pfreq_opp
1223  W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt
1224!-
1225  CALL ioget_calendar(un_an,un_jour)
1226  IF (pfreq_opp < 0) THEN
1227    CALL ioget_calendar(un_an)
1228    test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour
1229  ELSE
1230    test_fopp = pfreq_opp
1231  ENDIF
1232  IF (pfreq_wrt < 0) THEN
1233    CALL ioget_calendar(un_an)
1234    test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour
1235  ELSE
1236    test_fwrt = pfreq_wrt
1237  ENDIF
1238!-
1239! 4.1 Frequency of operations and output should be larger than deltat !
1240!-
1241  IF (test_fopp < W_F(idf)%deltat) THEN
1242    str70 = 'Frequency of operations should be larger than deltat'
1243    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
1244 &   TRIM(tmp_name),pfreq_opp
1245    str72 = "PATCH : frequency set to deltat"
1246!-
1247    CALL ipslerr (2,"histdef",str70,str71,str72)
1248!-
1249    W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat
1250  ENDIF
1251!-
1252  IF (test_fwrt < W_F(idf)%deltat) THEN
1253    str70 = 'Frequency of output should be larger than deltat'
1254    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
1255 &   TRIM(tmp_name),pfreq_wrt
1256    str72 = "PATCH : frequency set to deltat"
1257!-
1258    CALL ipslerr (2,"histdef",str70,str71,str72)
1259!-
1260    W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat
1261  ENDIF
1262!-
1263! 4.2 First the existence of the operation is tested and then
1264!     its compaticility with the choice of frequencies
1265!-
1266  IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN
1267    IF (test_fopp /= test_fwrt) THEN
1268      str70 = 'For instantaneous output the frequency '// &
1269 &            'of operations and output'
1270      WRITE(str71, &
1271 &     '("should be the same, this was not case for variable ",a)') &
1272 &      TRIM(tmp_name)
1273      str72 = "PATCH : The smalest frequency of both is used"
1274      CALL ipslerr (2,"histdef",str70,str71,str72)
1275      IF (test_fopp < test_fwrt) THEN
1276        W_F(idf)%W_V(iv)%freq_opp = pfreq_opp
1277        W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp
1278      ELSE
1279        W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt
1280        W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt
1281      ENDIF
1282    ENDIF
1283  ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN
1284    IF (test_fopp > test_fwrt) THEN
1285      str70 = 'For averages the frequency of operations '// &
1286 &            'should be smaller or equal'
1287      WRITE(str71, &
1288 &     '("to that of output. It is not the case for variable ",a)') &
1289 &     TRIM(tmp_name)
1290      str72 = 'PATCH : The output frequency is used for both'
1291      CALL ipslerr (2,"histdef",str70,str71,str72)
1292      W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt
1293    ENDIF
1294  ELSE
1295    WRITE (str70,'("Operation on variable ",A," is unknown")') &
1296 &   TRIM(tmp_name)
1297    WRITE (str71,'("operation requested is :",A)') &
1298 &   W_F(idf)%W_V(iv)%topp
1299    WRITE (str72,'("File ID :",I3)') idf
1300    CALL ipslerr (3,"histdef",str70,str71,str72)
1301  ENDIF
1302!-
1303! 5.0 Initialize other variables of the common
1304!-
1305  IF (l_dbg) WRITE(ipslout,*) "histdef : 5.0"
1306!-
1307  W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range))
1308  IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN
1309    W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2))
1310    IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN
1311      W_F(idf)%W_V(iv)%hist_minmax(1:2) = &
1312 &      (/ ABS(missing_val),-ABS(missing_val) /)
1313    ELSE
1314      W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2)
1315    ENDIF
1316  ENDIF
1317!-
1318! - freq_opp(idf,iv)/2./deltat(idf)
1319  W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0
1320! - freq_wrt(idf,iv)/2./deltat(idf)
1321  W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0
1322! - freq_opp(idf,iv)/2./deltat(idf)
1323  W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0
1324! - freq_wrt(idf,iv)/2./deltat(idf)
1325  W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0
1326  W_F(idf)%W_V(iv)%nb_opp = 0
1327  W_F(idf)%W_V(iv)%nb_wrt = 0
1328!-
1329! 6.0 Get the time axis for this variable
1330!-
1331  IF (l_dbg) WRITE(ipslout,*) "histdef : 6.0"
1332!-
1333! No time axis for once, l_max, l_min or never operation
1334!-
1335  IF (     (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once')  &
1336 &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') &
1337 &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') &
1338 &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN
1339    IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN
1340      str10 = 't_inst_'
1341    ELSE
1342      str10 = 't_op_'
1343    ENDIF
1344    IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN
1345      WRITE (UNIT=str40,FMT='(A,I8.8)') &
1346&      TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt)
1347    ELSE
1348      WRITE (UNIT=str40,FMT='(A,I2.2,"month")') &
1349&      TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt))
1350    ENDIF
1351    CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos)
1352    IF (pos < 0) THEN
1353      W_F(idf)%n_tax = W_F(idf)%n_tax+1
1354      W_F(idf)%W_V(iv)%l_bnd = &
1355 &      (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst')
1356      W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40
1357      W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0
1358      W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax
1359    ELSE
1360      W_F(idf)%W_V(iv)%t_axid = pos
1361    ENDIF
1362  ELSE
1363    IF (l_dbg) THEN
1364      WRITE(ipslout,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----'
1365    ENDIF
1366    W_F(idf)%W_V(iv)%t_axid = -99
1367  ENDIF
1368!-
1369! 7.0 prepare frequence of writing and operation
1370!     for never or once operation
1371!-
1372  IF (    (TRIM(W_F(idf)%W_V(iv)%topp) == 'once')  &
1373 &    .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN
1374    W_F(idf)%W_V(iv)%freq_opp = 0.
1375    W_F(idf)%W_V(iv)%freq_wrt = 0.
1376  ENDIF
1377!---------------------
1378END SUBROUTINE histdef
1379!===
1380SUBROUTINE histend (idf)
1381!---------------------------------------------------------------------
1382!- This subroutine end the decalaration of variables and sets the
1383!- time axes in the netcdf file and puts it into the write mode.
1384!-
1385!- INPUT
1386!-
1387!- idf : ID of the file to be worked on
1388!-
1389!- VERSION
1390!-
1391!---------------------------------------------------------------------
1392  IMPLICIT NONE
1393!-
1394  INTEGER,INTENT(IN) :: idf
1395!-
1396  INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt
1397  INTEGER,DIMENSION(4) :: dims
1398  INTEGER :: year,month,day,hours,minutes
1399  REAL :: sec
1400  REAL :: rtime0
1401  CHARACTER(LEN=30) :: str30
1402  CHARACTER(LEN=35) :: str35
1403  CHARACTER(LEN=120) :: assoc
1404  CHARACTER(LEN=70) :: str70
1405  CHARACTER(LEN=3),DIMENSION(12) :: cal =   &
1406 &  (/ 'JAN','FEB','MAR','APR','MAY','JUN', &
1407 &     'JUL','AUG','SEP','OCT','NOV','DEC' /)
1408  CHARACTER(LEN=7) :: tmp_opp
1409  LOGICAL :: l_b
1410  LOGICAL :: l_dbg
1411!---------------------------------------------------------------------
1412  CALL ipsldbg (old_status=l_dbg)
1413!-
1414  nfid = W_F(idf)%ncfid
1415!-
1416! 1.0 Create the time axes
1417!-
1418  IF (l_dbg) WRITE(ipslout,*) "histend : 1.0"
1419!-
1420! 1.1 Define the time dimensions needed for this file
1421!-
1422  iret = NF90_DEF_DIM (nfid,'time_counter', &
1423 &                     NF90_UNLIMITED,W_F(idf)%tid)
1424  DO iv=1,W_F(idf)%n_var
1425    IF (W_F(idf)%W_V(iv)%l_bnd) THEN
1426      iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid)
1427      EXIT
1428    ENDIF
1429  ENDDO
1430!-
1431! 1.2 Define all the time axes needed for this file
1432!-
1433  DO itx=1,W_F(idf)%n_tax
1434    dims(1) = W_F(idf)%tid
1435    l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1)
1436    IF (itx > 1) THEN
1437      str30 = W_F(idf)%W_V(itx)%tax_name
1438    ELSE
1439      str30 = "time_counter"
1440    ENDIF
1441    IF (l_b) THEN
1442      str35 = TRIM(str30)//'_bnds'
1443    ENDIF
1444    iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, &
1445 &          dims(1),W_F(idf)%W_V(itx)%tdimid)
1446    IF (itx <= 1) THEN
1447      iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T")
1448    ENDIF
1449    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1450 &          'standard_name',"time")
1451!---
1452!   To transform the current itau into a real date and take it
1453!   as the origin of the file requires the time counter to change.
1454!   Thus it is an operation the user has to ask for.
1455!   This function should thus only be re-instated
1456!   if there is a ioconf routine to control it.
1457!---
1458!-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf))
1459    rtime0 = W_F(idf)%date0
1460!-
1461    CALL ju2ymds(rtime0,year,month,day,sec)
1462!---
1463!   Catch any error induced by a change in calendar !
1464!---
1465    IF (year < 0) THEN
1466      year = 2000+year
1467    ENDIF
1468!-
1469    hours = INT(sec/(60.*60.))
1470    minutes = INT((sec-hours*60.*60.)/60.)
1471    sec = sec-(hours*60.*60.+minutes*60.)
1472!-
1473    WRITE (UNIT=str70, &
1474 &   FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
1475 &    'seconds since ',year,month,day,hours,minutes,INT(sec)
1476    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1477 &           'units',TRIM(str70))
1478!-
1479    CALL ioget_calendar (str30)
1480    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1481 &           'calendar',TRIM(str30))
1482!-
1483    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1484 &           'title','Time')
1485!-
1486    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1487 &           'long_name','Time axis')
1488!-
1489    WRITE (UNIT=str70, &
1490 &   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
1491 &    year,cal(month),day,hours,minutes,INT(sec)
1492    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1493 &           'time_origin',TRIM(str70))
1494!---
1495    IF (l_b) THEN
1496      iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
1497 &             'bounds',TRIM(str35))
1498      dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /)
1499      iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, &
1500 &            dims(1:2),W_F(idf)%W_V(itx)%tbndid)
1501    ENDIF
1502  ENDDO
1503!-
1504! 2.0 declare the variables
1505!-
1506  IF (l_dbg) WRITE(ipslout,*) "histend : 2.0"
1507!-
1508  DO iv=1,W_F(idf)%n_var
1509!---
1510    itax = W_F(idf)%W_V(iv)%t_axid
1511!---
1512    IF (W_F(idf)%regular) THEN
1513      dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /)
1514      dim_cnt = 2
1515    ELSE
1516      dims(1) = W_F(idf)%xid
1517      dim_cnt = 1
1518    ENDIF
1519!---
1520    tmp_opp = W_F(idf)%W_V(iv)%topp
1521    ziv = W_F(idf)%W_V(iv)%z_axid
1522!---
1523!   2.1 dimension of field
1524!---
1525    IF ((TRIM(tmp_opp) /= 'never')) THEN
1526      IF (     (TRIM(tmp_opp) /= 'once')  &
1527     &    .AND.(TRIM(tmp_opp) /= 'l_max') &
1528     &    .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN
1529        IF (ziv == -99) THEN
1530          ndim = dim_cnt+1
1531          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /)
1532        ELSE
1533          ndim = dim_cnt+2
1534          dims(dim_cnt+1:dim_cnt+2) = &
1535 &         (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /)
1536        ENDIF
1537      ELSE
1538        IF (ziv == -99) THEN
1539          ndim = dim_cnt
1540          dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /)
1541        ELSE
1542          ndim = dim_cnt+1
1543          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /)
1544        ENDIF
1545      ENDIF
1546!-
1547      iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), &
1548 &             W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid)
1549!-
1550      W_F(idf)%W_V(iv)%ncvid = nvid
1551!-
1552      IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN
1553        iret = NF90_PUT_ATT (nfid,nvid,'units', &
1554 &                           TRIM(W_F(idf)%W_V(iv)%unit_name))
1555      ENDIF
1556      iret = NF90_PUT_ATT (nfid,nvid,'standard_name', &
1557 &                         TRIM(W_F(idf)%W_V(iv)%std_name))
1558!-
1559      IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN
1560        iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8)
1561      ELSE
1562        iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4)
1563      ENDIF
1564      IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN
1565        IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN
1566          iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
1567 &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8))
1568          iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
1569 &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8))
1570        ELSE
1571          iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
1572 &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4))
1573          iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
1574 &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4))
1575        ENDIF
1576      ENDIF
1577      iret = NF90_PUT_ATT (nfid,nvid,'long_name', &
1578 &                         TRIM(W_F(idf)%W_V(iv)%title))
1579      iret = NF90_PUT_ATT (nfid,nvid,'online_operation', &
1580 &                         TRIM(W_F(idf)%W_V(iv)%fullop))
1581!-
1582      SELECT CASE(ndim)
1583      CASE(-3,2:4)
1584      CASE DEFAULT
1585        CALL ipslerr (3,"histend", &
1586       &  'less than 2 or more than 4 dimensions are not', &
1587       &  'allowed at this stage',' ')
1588      END SELECT
1589!-
1590      assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) &
1591 &   //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1))
1592!-
1593      ziv = W_F(idf)%W_V(iv)%z_axid
1594      IF (ziv > 0) THEN
1595        str30 = W_F(idf)%zax_name(ziv)
1596        assoc = TRIM(str30)//' '//TRIM(assoc)
1597      ENDIF
1598!-
1599      IF (itax > 0) THEN
1600        IF (itax > 1) THEN
1601          str30 = W_F(idf)%W_V(itax)%tax_name
1602        ELSE
1603          str30 = "time_counter"
1604        ENDIF
1605        assoc = TRIM(str30)//' '//TRIM(assoc)
1606!-
1607        IF (l_dbg) THEN
1608          WRITE(ipslout,*) "histend : 2.0.n, freq_opp, freq_wrt", &
1609 &          W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt
1610        ENDIF
1611!-
1612        iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', &
1613 &                           REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4))
1614        iret = NF90_PUT_ATT (nfid,nvid,'interval_write', &
1615 &                           REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4))
1616      ENDIF
1617      iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc))
1618    ENDIF
1619  ENDDO
1620!-
1621! 2.2 Add DOMAIN attributes if needed
1622!-
1623  IF (W_F(idf)%dom_id_svg >= 0) THEN
1624    CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg)
1625  ENDIF
1626!-
1627! 3.0 Put the netcdf file into write mode
1628!-
1629  IF (l_dbg) WRITE(ipslout,*) "histend : 3.0"
1630!-
1631  iret = NF90_ENDDEF (nfid)
1632!-
1633! 4.0 Give some informations to the user
1634!-
1635  IF (l_dbg) WRITE(ipslout,*) "histend : 4.0"
1636!-
1637  WRITE(str70,'("All variables have been initialized on file :",I3)') idf
1638  CALL ipslerr (1,'histend',str70,'',' ')
1639!---------------------
1640END SUBROUTINE histend
1641!===
1642SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex)
1643!---------------------------------------------------------------------
1644  IMPLICIT NONE
1645!-
1646  INTEGER,INTENT(IN) :: idf,pitau,nbindex
1647  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1648  REAL,DIMENSION(:),INTENT(IN) :: pdata
1649  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1650!---------------------------------------------------------------------
1651  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata)
1652!---------------------------
1653END SUBROUTINE histwrite_r1d
1654!===
1655SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex)
1656!---------------------------------------------------------------------
1657  IMPLICIT NONE
1658!-
1659  INTEGER,INTENT(IN) :: idf,pitau,nbindex
1660  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1661  REAL,DIMENSION(:,:),INTENT(IN) :: pdata
1662  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1663!---------------------------------------------------------------------
1664  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata)
1665!---------------------------
1666END SUBROUTINE histwrite_r2d
1667!===
1668SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex)
1669!---------------------------------------------------------------------
1670  IMPLICIT NONE
1671!-
1672  INTEGER,INTENT(IN) :: idf,pitau,nbindex
1673  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1674  REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
1675  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1676!---------------------------------------------------------------------
1677  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata)
1678!---------------------------
1679END SUBROUTINE histwrite_r3d
1680!===
1681SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, &
1682  &                   pdata_1d,pdata_2d,pdata_3d)
1683!---------------------------------------------------------------------
1684  IMPLICIT NONE
1685!-
1686  INTEGER,INTENT(IN) :: idf,pitau,nbindex
1687  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1688  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1689  REAL,DIMENSION(:),INTENT(IN),OPTIONAL     :: pdata_1d
1690  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL   :: pdata_2d
1691  REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d
1692!-
1693  LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d
1694  INTEGER :: iv,io,nbpt_out
1695  INTEGER              :: nbpt_in1
1696  INTEGER,DIMENSION(2) :: nbpt_in2
1697  INTEGER,DIMENSION(3) :: nbpt_in3
1698  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1
1699  CHARACTER(LEN=7) :: tmp_opp
1700  CHARACTER(LEN=13) :: c_nam
1701  CHARACTER(LEN=20) :: tmpstr, tmpstr2
1702  LOGICAL :: l_dbg
1703  INTEGER :: initzdim, varzdim
1704!---------------------------------------------------------------------
1705  CALL ipsldbg (old_status=l_dbg)
1706!-
1707  l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d);
1708  IF      (l1d) THEN
1709    c_nam = 'histwrite_r1d'
1710  ELSE IF (l2d) THEN
1711    c_nam = 'histwrite_r2d'
1712  ELSE IF (l3d) THEN
1713    c_nam = 'histwrite_r3d'
1714  ENDIF
1715!-
1716  IF (l_dbg) THEN
1717    WRITE(ipslout,*) "histwrite : ",c_nam
1718  ENDIF
1719!-
1720! 1.0 Try to catch errors like specifying the wrong file ID.
1721!     Thanks Marine for showing us what errors users can make !
1722!-
1723  IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN
1724    CALL ipslerr (3,"histwrite", &
1725 &    'Illegal file ID in the histwrite of variable',pvarname,' ')
1726  ENDIF
1727!-
1728! 1.1 Find the id of the variable to be written and the real time
1729!-
1730  CALL histvar_seq (idf,pvarname,iv)
1731!-
1732! 1.2 Check for variable dimension is the same as declared
1733!-
1734  IF (PRESENT(pdata_2d) .OR. PRESENT(pdata_3d)) THEN
1735      IF (PRESENT(pdata_2d)) varzdim = SIZE(pdata_2d, DIM=2)
1736      IF (PRESENT(pdata_3d)) varzdim = SIZE(pdata_3d, DIM=2)
1737
1738      initzdim = W_F(idf)%W_V(iv)%zsize(3)
1739      IF (initzdim .NE. varzdim) THEN
1740        WRITE(tmpstr,  *) initzdim
1741        WRITE(tmpstr2, *) varzdim
1742        CALL ipslerr(3, "histwrite", "Variable="//pvarname,         &
1743                        "Expected 3rd dimension size: "//TRIM(tmpstr),  &
1744                        "But found: "//TRIM(tmpstr2))
1745      ENDIF
1746  ENDIF
1747!-
1748! 2.0 do nothing for never operation
1749!-
1750  tmp_opp = W_F(idf)%W_V(iv)%topp
1751!-
1752  IF (TRIM(tmp_opp) == "never") THEN
1753    W_F(idf)%W_V(iv)%last_opp_chk = -99
1754    W_F(idf)%W_V(iv)%last_wrt_chk = -99
1755  ENDIF
1756!-
1757! 3.0 We check if we need to do an operation
1758!-
1759  IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN
1760    CALL ipslerr (3,"histwrite", &
1761 &    'This variable has already been analysed at the present', &
1762 &    'time step',TRIM(pvarname))
1763  ENDIF
1764!-
1765  CALL isittime &
1766 &  (pitau,W_F(idf)%date0,W_F(idf)%deltat, &
1767 &   W_F(idf)%W_V(iv)%freq_opp, &
1768 &   W_F(idf)%W_V(iv)%last_opp, &
1769 &   W_F(idf)%W_V(iv)%last_opp_chk,do_oper)
1770!-
1771! 4.0 We check if we need to write the data
1772!-
1773  IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN
1774    CALL ipslerr (3,"histwrite", &
1775 &    'This variable as already been written for the present', &
1776 &    'time step',' ')
1777  ENDIF
1778!-
1779  CALL isittime &
1780 &  (pitau,W_F(idf)%date0,W_F(idf)%deltat, &
1781 &   W_F(idf)%W_V(iv)%freq_wrt, &
1782 &   W_F(idf)%W_V(iv)%last_wrt, &
1783 &   W_F(idf)%W_V(iv)%last_wrt_chk,do_write)
1784!-
1785! 5.0 histwrite called
1786!-
1787  IF (do_oper.OR.do_write) THEN
1788!-
1789!-- 5.1 Get the sizes of the data we will handle
1790!-
1791    IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN
1792!---- There is the risk here that the user has over-sized the array.
1793!---- But how can we catch this ?
1794!---- In the worst case we will do impossible operations
1795!---- on part of the data !
1796      W_F(idf)%W_V(iv)%datasz_in(1:3) = -1
1797      IF      (l1d) THEN
1798        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d)
1799      ELSE IF (l2d) THEN
1800        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1)
1801        W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2)
1802      ELSE IF (l3d) THEN
1803        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1)
1804        W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2)
1805        W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3)
1806      ENDIF
1807    ENDIF
1808!-
1809!-- 5.2 The maximum size of the data will give the size of the buffer
1810!-
1811    IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN
1812      largebuf = .FALSE.
1813      DO io=1,W_F(idf)%W_V(iv)%nbopp
1814        IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN
1815          largebuf = .TRUE.
1816        ENDIF
1817      ENDDO
1818      IF (largebuf) THEN
1819        W_F(idf)%W_V(iv)%datasz_max = &
1820 &        W_F(idf)%W_V(iv)%scsize(1) &
1821 &       *W_F(idf)%W_V(iv)%scsize(2) &
1822 &       *W_F(idf)%W_V(iv)%scsize(3)
1823      ELSE
1824        IF      (l1d) THEN
1825          W_F(idf)%W_V(iv)%datasz_max = &
1826 &          W_F(idf)%W_V(iv)%datasz_in(1)
1827        ELSE IF (l2d) THEN
1828          W_F(idf)%W_V(iv)%datasz_max = &
1829 &          W_F(idf)%W_V(iv)%datasz_in(1) &
1830 &         *W_F(idf)%W_V(iv)%datasz_in(2)
1831        ELSE IF (l3d) THEN
1832          W_F(idf)%W_V(iv)%datasz_max = &
1833 &          W_F(idf)%W_V(iv)%datasz_in(1) &
1834 &         *W_F(idf)%W_V(iv)%datasz_in(2) &
1835 &         *W_F(idf)%W_V(iv)%datasz_in(3)
1836        ENDIF
1837      ENDIF
1838    ENDIF
1839!-
1840    IF (.NOT.ALLOCATED(tbf_1)) THEN
1841      IF (l_dbg) THEN
1842        WRITE(ipslout,*) &
1843 &       c_nam//" : allocate tbf_1 for size = ", &
1844 &       W_F(idf)%W_V(iv)%datasz_max
1845      ENDIF
1846      ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max))
1847    ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN
1848      IF (l_dbg) THEN
1849        WRITE(ipslout,*) &
1850 &       c_nam//" : re-allocate tbf_1 for size = ", &
1851 &       W_F(idf)%W_V(iv)%datasz_max
1852      ENDIF
1853      DEALLOCATE(tbf_1)
1854      ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max))
1855    ENDIF
1856!-
1857!-- We have to do the first operation anyway.
1858!-- Thus we do it here and change the ranke
1859!-- of the data at the same time. This should speed up things.
1860!-
1861    nbpt_out = W_F(idf)%W_V(iv)%datasz_max
1862    IF      (l1d) THEN
1863      nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1)
1864      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, &
1865 &                 missing_val,nbindex,nindex, &
1866 &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
1867    ELSE IF (l2d) THEN
1868      nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2)
1869      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, &
1870 &                 missing_val,nbindex,nindex, &
1871 &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
1872    ELSE IF (l3d) THEN
1873      nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3)
1874      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, &
1875 &                 missing_val,nbindex,nindex, &
1876 &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
1877    ENDIF
1878    CALL histwrite_real (idf,iv,pitau,nbpt_out, &
1879 &            tbf_1,nbindex,nindex,do_oper,do_write)
1880  ENDIF
1881!-
1882! 6.0 Manage time steps
1883!-
1884  IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
1885    W_F(idf)%W_V(iv)%last_opp_chk = pitau
1886    W_F(idf)%W_V(iv)%last_wrt_chk = pitau
1887  ELSE
1888    W_F(idf)%W_V(iv)%last_opp_chk = -99
1889    W_F(idf)%W_V(iv)%last_wrt_chk = -99
1890  ENDIF
1891!-----------------------
1892END SUBROUTINE histw_rnd
1893!===
1894SUBROUTINE histwrite_real &
1895 & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write)
1896!---------------------------------------------------------------------
1897!- This subroutine is internal and does the calculations and writing
1898!- if needed. At a later stage it should be split into an operation
1899!- and writing subroutines.
1900!---------------------------------------------------------------------
1901  IMPLICIT NONE
1902!-
1903  INTEGER,INTENT(IN) :: idf,pitau,iv, &
1904 &                      nbindex,nindex(nbindex),nbdpt
1905  REAL,DIMENSION(:)  :: tbf_1
1906  LOGICAL,INTENT(IN) :: do_oper,do_write
1907!-
1908  INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout
1909  INTEGER :: nx,ny,nz,ky,kz,kt,kc
1910  INTEGER,DIMENSION(4) :: corner,edges
1911  INTEGER :: itime
1912  LOGICAL :: flag
1913!-
1914  REAL :: rtime
1915  REAL,DIMENSION(2) :: t_bnd
1916  CHARACTER(LEN=7) :: tmp_opp
1917  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2
1918  LOGICAL :: l_dbg
1919!---------------------------------------------------------------------
1920  CALL ipsldbg (old_status=l_dbg)
1921!-
1922  IF (l_dbg) THEN
1923    WRITE(ipslout,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name
1924    WRITE(ipslout,*) "histwrite 0.0 : nbindex :",nbindex
1925    WRITE(ipslout,*) "histwrite 0.0 : nindex  :",nindex(1:MIN(3,nbindex)),'...'
1926  ENDIF
1927!-
1928! The sizes which can be encoutered
1929!-
1930  tsz =  W_F(idf)%W_V(iv)%zsize(1) &
1931 &      *W_F(idf)%W_V(iv)%zsize(2) &
1932 &      *W_F(idf)%W_V(iv)%zsize(3)
1933!-
1934! 1.0 We allocate and the temporary space needed for operations.
1935!     The buffers are only deallocated when more space is needed.
1936!     This reduces the umber of allocates but increases memory needs.
1937!-
1938  IF (.NOT.ALLOCATED(tbf_2)) THEN
1939    IF (l_dbg) THEN
1940      WRITE(ipslout,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1)
1941    ENDIF
1942    ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max))
1943  ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN
1944    IF (l_dbg) THEN
1945      WRITE(ipslout,*) "histwrite_real 1.2 re-allocate tbf_2 : ", &
1946     & SIZE(tbf_1)," instead of ",SIZE(tbf_2)
1947    ENDIF
1948    DEALLOCATE(tbf_2)
1949    ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max))
1950  ENDIF
1951!-
1952  rtime = pitau*W_F(idf)%deltat
1953  tmp_opp = W_F(idf)%W_V(iv)%topp
1954!-
1955! 3.0 Do the operations or transfer the slab of data into tbf_1
1956!-
1957  IF (l_dbg) THEN
1958    WRITE(ipslout,*) "histwrite: 3.0",idf
1959  ENDIF
1960!-
1961! 3.1 DO the Operations only if needed
1962!-
1963  IF (do_oper) THEN
1964    nbout = nbdpt
1965!-
1966!-- 3.4 We continue the sequence of operations
1967!--     we started in the interface routine
1968!-
1969    DO io=2,W_F(idf)%W_V(iv)%nbopp,2
1970      nbin = nbout
1971      nbout = W_F(idf)%W_V(iv)%datasz_max
1972      CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, &
1973 &      missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), &
1974 &      nbout,tbf_2)
1975      IF (l_dbg) THEN
1976        WRITE(ipslout,*) &
1977 &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io)
1978      ENDIF
1979!-
1980      nbin = nbout
1981      nbout = W_F(idf)%W_V(iv)%datasz_max
1982      CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, &
1983 &      missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), &
1984 &      nbout,tbf_1)
1985      IF (l_dbg) THEN
1986        WRITE(ipslout,*) &
1987 &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1)
1988      ENDIF
1989    ENDDO
1990!-
1991!   3.5 Zoom into the data
1992!-
1993    IF (l_dbg) THEN
1994      WRITE(ipslout,*) &
1995 &     "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1)
1996      WRITE(ipslout,*) &
1997 &     "histwrite: 3.5 slab in X :", &
1998 &     W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1)
1999      WRITE(ipslout,*) &
2000 &     "histwrite: 3.5 slab in Y :", &
2001 &     W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2)
2002      WRITE(ipslout,*) &
2003 &     "histwrite: 3.5 slab in Z :", &
2004 &     W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3)
2005      WRITE(ipslout,*) &
2006 &     "histwrite: 3.5 slab of input:", &
2007 &     W_F(idf)%W_V(iv)%scsize(1), &
2008 &     W_F(idf)%W_V(iv)%scsize(2), &
2009 &     W_F(idf)%W_V(iv)%scsize(3)
2010    ENDIF
2011!---
2012!-- We have to consider blocks of contiguous data
2013!---
2014    nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1)
2015    ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1)
2016    nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1)
2017    IF     (     (W_F(idf)%W_V(iv)%zorig(1) == 1) &
2018 &          .AND.(   W_F(idf)%W_V(iv)%zsize(1) &
2019 &                == W_F(idf)%W_V(iv)%scsize(1)) &
2020 &          .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) &
2021 &          .AND.(   W_F(idf)%W_V(iv)%zsize(2) &
2022 &                == W_F(idf)%W_V(iv)%scsize(2))) THEN
2023      kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny
2024      tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz)
2025    ELSEIF (     (W_F(idf)%W_V(iv)%zorig(1) == 1) &
2026 &          .AND.(   W_F(idf)%W_V(iv)%zsize(1) &
2027 &                == W_F(idf)%W_V(iv)%scsize(1))) THEN
2028      kc = -nx*ny
2029      DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1
2030        kc = kc+nx*ny
2031        kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) &
2032 &            +W_F(idf)%W_V(iv)%zorig(2)-1)*nx
2033        tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny)
2034      ENDDO
2035    ELSE
2036      kc = -nx
2037      DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1
2038        DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1
2039          kc = kc+nx
2040          kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) &
2041 &            *W_F(idf)%W_V(iv)%scsize(1) &
2042 &            +W_F(idf)%W_V(iv)%zorig(1)-1
2043          tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx)
2044        ENDDO
2045      ENDDO
2046    ENDIF
2047!-
2048!-- 4.0 Get the min and max of the field
2049!-
2050    IF (l_dbg) THEN
2051      WRITE(ipslout,*) "histwrite: 4.0 tbf_1",idf,iv, &
2052 &      TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex
2053    ENDIF
2054!-
2055    IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN
2056      W_F(idf)%W_V(iv)%hist_minmax(1) = &
2057 &      MIN(W_F(idf)%W_V(iv)%hist_minmax(1), &
2058 &      MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val))
2059      W_F(idf)%W_V(iv)%hist_minmax(2) = &
2060 &      MAX(W_F(idf)%W_V(iv)%hist_minmax(2), &
2061 &      MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val))
2062    ENDIF
2063!-
2064!-- 5.0 Do the operations if needed. In the case of instantaneous
2065!--     output we do not transfer to the time_buffer.
2066!-
2067    IF (l_dbg) THEN
2068      WRITE(ipslout,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz
2069    ENDIF
2070!-
2071    IF (     (TRIM(tmp_opp) /= "inst") &
2072 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2073
2074!-
2075!------ 5.1 Check if scatter operation is performed
2076!-     
2077       flag = .FALSE. 
2078       DO io = 1, nbopp_max
2079          IF ( INDEX(TRIM(W_F(idf)%W_V(iv)%sopp(io)),'scatter') > 0 ) THEN
2080             flag = .TRUE. 
2081          END IF
2082       END DO
2083
2084       IF ( flag ) THEN
2085!-
2086!------ 5.2  Enter moycum_index only if a scatter operation is performed
2087!-         
2088          IF (l_dbg) &
2089               & WRITE(ipslout,*) "histwrite: 5.2 moycum_index",nbindex,nx,ny,nz
2090          CALL moycum_index(tmp_opp, W_F(idf)%W_V(iv)%t_bf, &
2091 &             tbf_2, W_F(idf)%W_V(iv)%nb_opp, nbindex, nindex)
2092       ELSE
2093!-
2094!------ 5.3  Enter moycum otherwise
2095!-
2096          IF (l_dbg) &
2097               & WRITE(ipslout,*) "histwrite: 5.3 moycum",nbindex,nx,ny
2098          CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, &
2099               &           tbf_2,W_F(idf)%W_V(iv)%nb_opp)
2100       END IF
2101
2102    ENDIF
2103!-
2104    W_F(idf)%W_V(iv)%last_opp = pitau
2105    W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1
2106!-
2107  ENDIF
2108!-
2109! 6.0 Write to file if needed
2110!-
2111  IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.0",idf
2112!-
2113  IF (do_write) THEN
2114!-
2115    nfid = W_F(idf)%ncfid
2116    nvid = W_F(idf)%W_V(iv)%ncvid
2117!-
2118!-- 6.1 Do the operations that are needed before writting
2119!-
2120    IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.1",idf
2121!-
2122    IF (     (TRIM(tmp_opp) /= "inst") &
2123 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2124      t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /)
2125      rtime = (t_bnd(1)+t_bnd(2))/2.0
2126    ENDIF
2127!-
2128!-- 6.2 Add a value to the time axis of this variable if needed
2129!-
2130    IF (     (TRIM(tmp_opp) /= "l_max") &
2131 &      .AND.(TRIM(tmp_opp) /= "l_min") &
2132 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2133!-
2134      IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.2",idf
2135!-
2136      itax  = W_F(idf)%W_V(iv)%t_axid
2137      itime = W_F(idf)%W_V(iv)%nb_wrt+1
2138!-
2139      IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN
2140        iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, &
2141 &               (/ rtime /),start=(/ itime /),count=(/ 1 /))
2142        IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN
2143          iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, &
2144 &                 t_bnd,start=(/ 1,itime /),count=(/ 2,1 /))
2145        ENDIF
2146        W_F(idf)%W_V(itax)%tax_last = itime
2147      ENDIF
2148    ELSE
2149      itime=1
2150    ENDIF
2151!-
2152!-- 6.3 Write the data. Only in the case of instantaneous output
2153!       we do not write the buffer.
2154!-
2155    IF (l_dbg) THEN
2156      WRITE(ipslout,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime
2157    ENDIF
2158!-
2159    IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN
2160      IF (W_F(idf)%regular) THEN
2161        corner(1:4) = (/ 1,1,itime,0 /)
2162        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
2163 &                      W_F(idf)%W_V(iv)%zsize(2),1,0 /)
2164      ELSE
2165        corner(1:4) = (/ 1,itime,0,0 /)
2166        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /)
2167      ENDIF
2168    ELSE
2169      IF (W_F(idf)%regular) THEN
2170        corner(1:4) = (/ 1,1,1,itime /)
2171        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
2172 &                      W_F(idf)%W_V(iv)%zsize(2), &
2173 &                      W_F(idf)%W_V(iv)%zsize(3),1 /)
2174      ELSE
2175        corner(1:4) = (/ 1,1,itime,0 /)
2176        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
2177 &                      W_F(idf)%W_V(iv)%zsize(3),1,0 /)
2178      ENDIF
2179    ENDIF
2180!-
2181    IF (     (TRIM(tmp_opp) /= "inst") &
2182 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2183      iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, &
2184 &                         start=corner(1:4),count=edges(1:4))
2185    ELSE
2186      iret = NF90_PUT_VAR (nfid,nvid,tbf_2, &
2187 &                         start=corner(1:4),count=edges(1:4))
2188    ENDIF
2189!-
2190    W_F(idf)%W_V(iv)%last_wrt = pitau
2191    W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1
2192    W_F(idf)%W_V(iv)%nb_opp = 0
2193!---
2194!   After the write the file can be synchronized so that no data is
2195!   lost in case of a crash. This feature gives up on the benefits of
2196!   buffering and should only be used in debuging mode. A flag is
2197!   needed here to switch to this mode.
2198!---
2199!   iret = NF90_SYNC (nfid)
2200!-
2201  ENDIF
2202!----------------------------
2203END SUBROUTINE histwrite_real
2204!===
2205SUBROUTINE histvar_seq (idf,pvarname,idv)
2206!---------------------------------------------------------------------
2207!- This subroutine optimize the search for the variable in the table.
2208!- In a first phase it will learn the succession of the variables
2209!- called and then it will use the table to guess what comes next.
2210!- It is the best solution to avoid lengthy searches through array
2211!- vectors.
2212!-
2213!- ARGUMENTS :
2214!-
2215!- idf      : id of the file on which we work
2216!- pvarname : The name of the variable we are looking for
2217!- idv      : The var id we found
2218!---------------------------------------------------------------------
2219  IMPLICIT NONE
2220!-
2221  INTEGER,INTENT(in)  :: idf
2222  CHARACTER(LEN=*),INTENT(IN) :: pvarname
2223  INTEGER,INTENT(out) :: idv
2224!-
2225  LOGICAL,SAVE :: learning(nb_files_max)=.TRUE.
2226  INTEGER,SAVE :: overlap(nb_files_max) = -1
2227  INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3)
2228  INTEGER,SAVE :: varseq_len(nb_files_max) = 0
2229  INTEGER,SAVE :: varseq_pos(nb_files_max)
2230  INTEGER,SAVE :: varseq_err(nb_files_max) = 0
2231  INTEGER      :: ib,sp,nn,pos
2232  CHARACTER(LEN=70) :: str70
2233  LOGICAL :: l_dbg
2234!---------------------------------------------------------------------
2235  CALL ipsldbg (old_status=l_dbg)
2236!-
2237  IF (l_dbg) THEN
2238    WRITE(ipslout,*) 'histvar_seq, start of the subroutine :',learning(idf)
2239  ENDIF
2240!-
2241  IF (learning(idf)) THEN
2242!-
2243!-- 1.0 We compute the length over which we are going
2244!--     to check the overlap
2245!-
2246    IF (overlap(idf) <= 0) THEN
2247      IF (W_F(idf)%n_var > 6) THEN
2248        overlap(idf) = W_F(idf)%n_var/3*2
2249      ELSE
2250        overlap(idf) = W_F(idf)%n_var
2251      ENDIF
2252    ENDIF
2253!-
2254!-- 1.1 Find the position of this string
2255!-
2256    CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos)
2257    IF (pos > 0) THEN
2258      idv = pos
2259    ELSE
2260      CALL ipslerr (3,"histvar_seq", &
2261 &      'The name of the variable you gave has not been declared', &
2262 &      'You should use subroutine histdef for declaring variable', &
2263 &      TRIM(pvarname))
2264    ENDIF
2265!-
2266!-- 1.2 If we have not given up we store the position
2267!--     in the sequence of calls
2268!-
2269    IF (varseq_err(idf) >= 0) THEN
2270      sp = varseq_len(idf)+1
2271      IF (sp <= nb_var_max*3) THEN
2272        varseq(idf,sp) = idv
2273        varseq_len(idf) = sp
2274      ELSE
2275        CALL ipslerr (2,"histvar_seq",&
2276 &       'The learning process has failed and we give up. '// &
2277 &       'Either you sequence is',&
2278 &       'too complex or I am too dumb. '// &
2279 &       'This will only affect the efficiency',&
2280 &       'of your code. Thus if you wish to save time'// &
2281 &       ' contact the IOIPSL team. ')
2282        WRITE(ipslout,*) 'The sequence we have found up to now :'
2283        WRITE(ipslout,*) varseq(idf,1:sp-1)
2284        varseq_err(idf) = -1
2285      ENDIF
2286!-
2287!---- 1.3 Check if we have found the right overlap
2288!-
2289      IF (varseq_len(idf) >= overlap(idf)*2) THEN
2290!-
2291!------ We skip a few variables if needed as they could come
2292!------ from the initialisation of the model.
2293!-
2294        DO ib = 0,sp-overlap(idf)*2
2295          IF ( learning(idf) .AND.&
2296            & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -&
2297            & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN
2298            learning(idf) = .FALSE.
2299            varseq_len(idf) = sp-overlap(idf)-ib
2300            varseq_pos(idf) = overlap(idf)+ib
2301            varseq(idf,1:varseq_len(idf)) = &
2302 &            varseq(idf,ib+1:ib+varseq_len(idf))
2303          ENDIF
2304        ENDDO
2305      ENDIF
2306    ENDIF
2307  ELSE
2308!-
2309!-- 2.0 Now we know how the calls to histwrite are sequenced
2310!--     and we can get a guess at the var ID
2311!-
2312    nn = varseq_pos(idf)+1
2313    IF (nn > varseq_len(idf)) nn = 1
2314!-
2315    idv = varseq(idf,nn)
2316!-
2317    IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN
2318      CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos)
2319      IF (pos > 0) THEN
2320        idv = pos
2321      ELSE
2322        CALL ipslerr (3,"histvar_seq", &
2323 &  'The name of the variable you gave has not been declared',&
2324 &  'You should use subroutine histdef for declaring variable', &
2325 &  TRIM(pvarname))
2326      ENDIF
2327      varseq_err(idf) = varseq_err(idf)+1
2328      IF (l_dbg) &
2329           WRITE(ipslout,*) "Error history file ",W_F(idf)%name," names : ", &
2330 &           TRIM(W_F(idf)%W_V(idv)%v_name),TRIM(pvarname)," id : ",idv
2331    ELSE
2332!-
2333!---- We only keep the new position if we have found the variable
2334!---- this way. This way an out of sequence call to histwrite does
2335!---- not defeat the process.
2336!-
2337      varseq_pos(idf) = nn
2338    ENDIF
2339!-
2340    IF (varseq_err(idf) >= 10) THEN
2341      WRITE(str70,'("for file ",I3)') idf
2342      CALL ipslerr (2,"histvar_seq", &
2343 &  'There were 10 errors in the learned sequence of variables',&
2344 &  str70,'This looks like a bug, please report it.')
2345         varseq_err(idf) = 0
2346    ENDIF
2347  ENDIF
2348!-
2349  IF (l_dbg) THEN
2350    WRITE(ipslout,*) &
2351 &   'histvar_seq, end of the subroutine :',TRIM(pvarname),idv
2352  ENDIF
2353!-------------------------
2354END SUBROUTINE histvar_seq
2355!===
2356SUBROUTINE histsync (idf)
2357!---------------------------------------------------------------------
2358!- This subroutine will synchronise all
2359!- (or one if defined) opened files.
2360!-
2361!- VERSION
2362!-
2363!---------------------------------------------------------------------
2364  IMPLICIT NONE
2365!-
2366! idf  : optional argument for fileid
2367  INTEGER,INTENT(in),OPTIONAL :: idf
2368!-
2369  INTEGER :: ifile,iret,i_s,i_e
2370!-
2371  LOGICAL :: l_dbg
2372!---------------------------------------------------------------------
2373  CALL ipsldbg (old_status=l_dbg)
2374!-
2375  IF (l_dbg) THEN
2376    WRITE(ipslout,*) "->histsync"
2377  ENDIF
2378!-
2379  IF (PRESENT(idf)) THEN
2380    IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN
2381      IF (W_F(idf)%ncfid > 0) THEN
2382        i_s = idf
2383        i_e = idf
2384      ELSE
2385        i_s = 1
2386        i_e = 0
2387        CALL ipslerr (2,'histsync', &
2388 &       'Unable to synchronise the file :','probably','not opened')
2389      ENDIF
2390    ELSE
2391      CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ')
2392    ENDIF
2393  ELSE
2394    i_s = 1
2395    i_e = nb_files_max
2396  ENDIF
2397!-
2398  DO ifile=i_s,i_e
2399    IF (W_F(ifile)%ncfid > 0) THEN
2400      IF (l_dbg) THEN
2401        WRITE(ipslout,*) '  histsync - synchronising file number ',ifile
2402      ENDIF
2403      iret = NF90_SYNC(W_F(ifile)%ncfid)
2404    ENDIF
2405  ENDDO
2406!-
2407  IF (l_dbg) THEN
2408    WRITE(ipslout,*) "<-histsync"
2409  ENDIF
2410!----------------------
2411END SUBROUTINE histsync
2412!===
2413SUBROUTINE histclo (idf)
2414!---------------------------------------------------------------------
2415!- This subroutine will close all (or one if defined) opened files
2416!-
2417!- VERSION
2418!-
2419!---------------------------------------------------------------------
2420  IMPLICIT NONE
2421!-
2422! idf  : optional argument for fileid
2423  INTEGER,INTENT(in),OPTIONAL :: idf
2424!-
2425  INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e
2426  LOGICAL :: l_dbg
2427!---------------------------------------------------------------------
2428  CALL ipsldbg (old_status=l_dbg)
2429!-
2430  IF (l_dbg) THEN
2431    WRITE(ipslout,*) "->histclo"
2432  ENDIF
2433!-
2434  IF (PRESENT(idf)) THEN
2435    IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN
2436      IF (W_F(idf)%ncfid > 0) THEN
2437        i_s = idf
2438        i_e = idf
2439      ELSE
2440        i_s = 1
2441        i_e = 0
2442        CALL ipslerr (2,'histclo', &
2443 &       'Unable to close the file :','probably','not opened')
2444      ENDIF
2445    ELSE
2446      CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ')
2447    ENDIF
2448  ELSE
2449    i_s = 1
2450    i_e = nb_files_max
2451  ENDIF
2452!-
2453  DO ifile=i_s,i_e
2454    IF (W_F(ifile)%ncfid > 0) THEN
2455      IF (l_dbg) THEN
2456        WRITE(ipslout,*) '  histclo - closing specified file number :',ifile
2457      ENDIF
2458      nfid = W_F(ifile)%ncfid
2459      iret = NF90_REDEF(nfid)
2460!-----
2461!---- 1. Loop on the number of variables to add some final information
2462!-----
2463      IF (l_dbg) THEN
2464        WRITE(ipslout,*) '  Entering loop on vars : ',W_F(ifile)%n_var
2465      ENDIF
2466      DO iv=1,W_F(ifile)%n_var
2467!------ Extrema
2468        IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN
2469          IF (l_dbg) THEN
2470            WRITE(ipslout,*) 'min value for file :',ifile,' var n. :',iv, &
2471 &                     ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1)
2472            WRITE(ipslout,*) 'max value for file :',ifile,' var n. :',iv, &
2473 &                     ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2)
2474          ENDIF
2475          IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN
2476!---------- Put the min and max values on the file
2477            nvid = W_F(ifile)%W_V(iv)%ncvid
2478            IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN
2479              iret = NF90_PUT_ATT(nfid,nvid,'valid_min', &
2480 &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8))
2481              iret = NF90_PUT_ATT(nfid,nvid,'valid_max', &
2482 &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8))
2483            ELSE
2484              iret = NF90_PUT_ATT(nfid,nvid,'valid_min', &
2485 &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4))
2486              iret = NF90_PUT_ATT(nfid,nvid,'valid_max', &
2487 &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4))
2488            ENDIF
2489          ENDIF
2490        ENDIF
2491!------ Time-Buffers
2492        IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN
2493          DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf)
2494        ENDIF
2495!------ Reinitialize the sizes
2496        W_F(ifile)%W_V(iv)%datasz_in(:) = -1
2497        W_F(ifile)%W_V(iv)%datasz_max = -1
2498      ENDDO
2499!-----
2500!---- 2. Close the file
2501!-----
2502      IF (l_dbg) WRITE(ipslout,*) '  close file :',nfid
2503      iret = NF90_CLOSE(nfid)
2504      W_F(ifile)%ncfid = -1
2505      W_F(ifile)%dom_id_svg = -1
2506    ENDIF
2507  ENDDO
2508!-
2509  IF (l_dbg) THEN
2510    WRITE(ipslout,*) "<-histclo"
2511  ENDIF
2512!---------------------
2513END SUBROUTINE histclo
2514!===
2515SUBROUTINE ioconf_modname (str)
2516!---------------------------------------------------------------------
2517!- This subroutine allows to configure the name
2518!- of the model written into the file
2519!---------------------------------------------------------------------
2520  IMPLICIT NONE
2521!-
2522  CHARACTER(LEN=*),INTENT(IN) :: str
2523!---------------------------------------------------------------------
2524  IF (.NOT.lock_modname) THEN
2525    model_name = str(1:MIN(LEN_TRIM(str),80))
2526    lock_modname = .TRUE.
2527  ELSE
2528    CALL ipslerr (2,"ioconf_modname", &
2529   &  'The model name can only be changed once and only', &
2530   &  'before it is used. It is now set to :',model_name)
2531  ENDIF
2532!----------------------------
2533END SUBROUTINE ioconf_modname
2534!-
2535!===
2536!-
2537!-----------------
2538END MODULE histcom
Note: See TracBrowser for help on using the repository browser.