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

Last change on this file since 845 was 845, checked in by bellier, 13 years ago

Update to FORTRAN 90

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