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

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

Added optional argument "standard_name" to histdef

  • 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) :: sopps
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=80) :: tmp_str80
1161  CHARACTER(LEN=7) :: tmp_topp,tmp_sopp(nbopp_max)
1162  CHARACTER(LEN=120) :: ex_topps
1163  REAL :: tmp_scal(nbopp_max),un_an,un_jour,test_fopp,test_fwrt
1164  INTEGER :: pos,buff_sz
1165  LOGICAL :: l_dbg
1166!---------------------------------------------------------------------
1167  CALL ipsldbg (old_status=l_dbg)
1168!-
1169  ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min'
1170!-
1171  W_F(pfileid)%n_var = W_F(pfileid)%n_var+1
1172  iv = W_F(pfileid)%n_var
1173!-
1174  IF (iv > nb_var_max) THEN
1175    CALL ipslerr (3,"histdef", &
1176   &  'Table of variables too small. You should increase nb_var_max',&
1177   &  'in histcom.f90 in order to accomodate all these variables', &
1178   &  ' ')
1179  ENDIF
1180!-
1181! 1.0 Transfer informations on the variable to the common
1182!     and verify that it does not already exist
1183!-
1184  IF (l_dbg) WRITE(*,*) "histdef : 1.0"
1185!-
1186  IF (iv > 1) THEN
1187    CALL find_str (W_F(pfileid)%W_V(1:iv-1)%v_name,pvarname,pos)
1188  ELSE
1189    pos = 0
1190  ENDIF
1191!-
1192  IF (pos > 0) THEN
1193    str70 = "Variable already exists"
1194    WRITE(str71,'("Check variable  ",a," in file",I3)') &
1195 &    TRIM(pvarname),pfileid
1196    str72 = "Can also be a wrong file ID in another declaration"
1197    CALL ipslerr (3,"histdef",str70,str71,str72)
1198  ENDIF
1199!-
1200  W_F(pfileid)%W_V(iv)%v_name = pvarname
1201  W_F(pfileid)%W_V(iv)%title = ptitle
1202  W_F(pfileid)%W_V(iv)%unit_name = punit
1203  IF (PRESENT(standard_name)) THEN
1204    W_F(pfileid)%W_V(iv)%std_name = standard_name
1205  ELSE
1206    W_F(pfileid)%W_V(iv)%std_name = ptitle
1207  ENDIF
1208  tmp_name = W_F(pfileid)%W_V(iv)%v_name
1209!-
1210! 1.1 decode the operations
1211!-
1212  W_F(pfileid)%W_V(iv)%fullop = popp
1213  tmp_str80 = popp
1214  CALL buildop &
1215 &  (tmp_str80,ex_topps,tmp_topp,nbopp_max,missing_val, &
1216 &   tmp_sopp,tmp_scal,W_F(pfileid)%W_V(iv)%nbopp)
1217!-
1218  W_F(pfileid)%W_V(iv)%topp = tmp_topp
1219  DO i=1,W_F(pfileid)%W_V(iv)%nbopp
1220    W_F(pfileid)%W_V(iv)%sopps(i) = tmp_sopp(i)
1221    W_F(pfileid)%W_V(iv)%scal(i) = tmp_scal(i)
1222  ENDDO
1223!-
1224! 1.2 If we have an even number of operations
1225!     then we need to add identity
1226!-
1227  IF (    2*INT(W_F(pfileid)%W_V(iv)%nbopp/2.0) &
1228 &     == W_F(pfileid)%W_V(iv)%nbopp) THEN
1229    W_F(pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+1
1230    W_F(pfileid)%W_V(iv)%sopps(W_F(pfileid)%W_V(iv)%nbopp) = 'ident'
1231    W_F(pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val
1232  ENDIF
1233!-
1234! 1.3 External type of the variable
1235!-
1236  IF (xtype == hist_r8) THEN
1237    W_F(pfileid)%W_V(iv)%v_typ = hist_r8
1238  ELSE
1239    W_F(pfileid)%W_V(iv)%v_typ = hist_r4
1240  ENDIF
1241!-
1242! 2.0 Put the size of the variable in the common and check
1243!-
1244  IF (l_dbg) THEN
1245    WRITE(*,*) "histdef : 2.0",pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, &
1246 &    W_F(pfileid)%W_V(iv)%sopps(1:W_F(pfileid)%W_V(iv)%nbopp), &
1247 &    W_F(pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp)
1248  ENDIF
1249!-
1250  W_F(pfileid)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /)
1251  W_F(pfileid)%W_V(iv)%zorig(1:3) = &
1252 &  (/ W_F(pfileid)%slab_ori(1),W_F(pfileid)%slab_ori(2),par_oriz /)
1253  W_F(pfileid)%W_V(iv)%zsize(1:3) = &
1254 &  (/ W_F(pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2),par_szz /)
1255!-
1256! Is the size of the full array the same as that of the coordinates ?
1257!-
1258  IF (    (pxsize > W_F(pfileid)%full_size(1)) &
1259 &    .OR.(pysize > W_F(pfileid)%full_size(2)) ) THEN
1260!-
1261    str70 = "The size of the variable is different "// &
1262 &          "from the one of the coordinates"
1263    WRITE(str71,'("Size of coordinates :",2I4)') &
1264 &   W_F(pfileid)%full_size(1),W_F(pfileid)%full_size(2)
1265    WRITE(str72,'("Size declared for variable ",a," :",2I4)') &
1266 &   TRIM(tmp_name),pxsize,pysize
1267    CALL ipslerr (3,"histdef",str70,str71,str72)
1268  ENDIF
1269!-
1270! Is the size of the zoom smaller than the coordinates ?
1271!-
1272  IF (    (W_F(pfileid)%full_size(1) < W_F(pfileid)%slab_sz(1)) &
1273 &    .OR.(W_F(pfileid)%full_size(2) < W_F(pfileid)%slab_sz(2)) ) THEN
1274    str70 = &
1275 &   "Size of variable should be greater or equal to those of the zoom"
1276    WRITE(str71,'("Size of XY zoom :",2I4)') &
1277 &   W_F(pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2)
1278    WRITE(str72,'("Size declared for variable ",A," :",2I4)') &
1279 &   TRIM(tmp_name),pxsize,pysize
1280    CALL ipslerr (3,"histdef",str70,str71,str72)
1281  ENDIF
1282!-
1283! 2.1 We store the horizontal grid information with minimal
1284!     and a fall back onto the default grid
1285!-
1286  IF ( (phoriid > 0).AND.(phoriid <= W_F(pfileid)%n_hax) ) THEN
1287    W_F(pfileid)%W_V(iv)%h_axid = phoriid
1288  ELSE
1289    W_F(pfileid)%W_V(iv)%h_axid = 1
1290    CALL ipslerr (2,"histdef", &
1291   &  'We use the default grid for variable as an invalide',&
1292   &  'ID was provided for variable : ',TRIM(pvarname))
1293  ENDIF
1294!-
1295! 2.2 Check the vertical coordinates if needed
1296!-
1297  IF (par_szz > 1) THEN
1298!-
1299!-- Does the vertical coordinate exist ?
1300!-
1301    IF (pzid > W_F(pfileid)%n_zax) THEN
1302      WRITE(str70, &
1303 &    '("The vertical coordinate chosen for variable ",a)') &
1304 &     TRIM(tmp_name)
1305      str71 = " Does not exist."
1306      CALL ipslerr (3,"histdef",str70,str71," ")
1307    ENDIF
1308!-
1309!-- Is the vertical size of the variable equal to that of the axis ?
1310!-
1311    IF (par_szz /= W_F(pfileid)%zax_size(pzid)) THEN
1312      str70 = "The size of the zoom does not correspond "// &
1313 &            "to the size of the chosen vertical axis"
1314      WRITE(str71,'("Size of zoom in z :",I4)') par_szz
1315      WRITE(str72,'("Size declared for axis ",A," :",I4)') &
1316 &     TRIM(W_F(pfileid)%zax_name(pzid)),W_F(pfileid)%zax_size(pzid)
1317      CALL ipslerr (3,"histdef",str70,str71,str72)
1318    ENDIF
1319!-
1320!-- Is the zoom smaller that the total size of the variable ?
1321!-
1322    IF (pzsize < par_szz) THEN
1323      str70 = "The vertical size of variable "// &
1324 &            "is smaller than that of the zoom."
1325      WRITE(str71,'("Declared vertical size of data :",I5)') pzsize
1326      WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') &
1327 &     TRIM(tmp_name),par_szz
1328      CALL ipslerr (3,"histdef",str70,str71,str72)
1329    ENDIF
1330    W_F(pfileid)%W_V(iv)%z_axid = pzid
1331  ELSE
1332    W_F(pfileid)%W_V(iv)%z_axid = -99
1333  ENDIF
1334!-
1335! 3.0 Determine the position of the variable in the buffer
1336!     If it is instantaneous output then we do not use the buffer
1337!-
1338  IF (l_dbg) WRITE(*,*) "histdef : 3.0"
1339!-
1340! 3.1 We get the size of the arrays histwrite will get and check
1341!     that they fit into the tmp_buffer
1342!-
1343  buff_sz = W_F(pfileid)%W_V(iv)%zsize(1) &
1344 &         *W_F(pfileid)%W_V(iv)%zsize(2) &
1345 &         *W_F(pfileid)%W_V(iv)%zsize(3)
1346!-
1347! 3.2 move the pointer of the buffer array for operation
1348!     which need bufferisation
1349!-
1350  IF (     (TRIM(tmp_topp) /= "inst") &
1351 &    .AND.(TRIM(tmp_topp) /= "once") &
1352 &    .AND.(TRIM(tmp_topp) /= "never") )THEN
1353    W_F(pfileid)%W_V(iv)%point = buff_pos+1
1354    buff_pos = buff_pos+buff_sz
1355    IF (l_dbg) THEN
1356      WRITE(*,*) "histdef : 3.2 bufpos for iv = ",iv, &
1357 &      " pfileid = ",pfileid," is = ",W_F(pfileid)%W_V(iv)%point
1358    ENDIF
1359  ENDIF
1360!-
1361! 4.0 Transfer the frequency of the operations and check
1362!     for validity. We have to pay attention to negative values
1363!     of the frequency which indicate monthly time-steps.
1364!     The strategy is to bring it back to seconds for the tests
1365!-
1366  IF (l_dbg) WRITE(*,*) "histdef : 4.0"
1367!-
1368  W_F(pfileid)%W_V(iv)%freq_opp = pfreq_opp
1369  W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_wrt
1370!-
1371  CALL ioget_calendar(un_an,un_jour)
1372  IF (pfreq_opp < 0) THEN
1373    CALL ioget_calendar(un_an)
1374    test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour
1375  ELSE
1376    test_fopp = pfreq_opp
1377  ENDIF
1378  IF (pfreq_wrt < 0) THEN
1379    CALL ioget_calendar(un_an)
1380    test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour
1381  ELSE
1382    test_fwrt = pfreq_wrt
1383  ENDIF
1384!-
1385! 4.1 Frequency of operations and output should be larger than deltat !
1386!-
1387  IF (test_fopp < W_F(pfileid)%deltat) THEN
1388    str70 = 'Frequency of operations should be larger than deltat'
1389    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
1390 &   TRIM(tmp_name),pfreq_opp
1391    str72 = "PATCH : frequency set to deltat"
1392!-
1393    CALL ipslerr (2,"histdef",str70,str71,str72)
1394!-
1395    W_F(pfileid)%W_V(iv)%freq_opp = W_F(pfileid)%deltat
1396  ENDIF
1397!-
1398  IF (test_fwrt < W_F(pfileid)%deltat) THEN
1399    str70 = 'Frequency of output should be larger than deltat'
1400    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
1401 &   TRIM(tmp_name),pfreq_wrt
1402    str72 = "PATCH : frequency set to deltat"
1403!-
1404    CALL ipslerr (2,"histdef",str70,str71,str72)
1405!-
1406    W_F(pfileid)%W_V(iv)%freq_wrt = W_F(pfileid)%deltat
1407  ENDIF
1408!-
1409! 4.2 First the existence of the operation is tested and then
1410!     its compaticility with the choice of frequencies
1411!-
1412  IF (TRIM(tmp_topp) == "inst") THEN
1413    IF (test_fopp /= test_fwrt) THEN
1414      str70 = 'For instantaneous output the frequency '// &
1415 &            'of operations and output'
1416      WRITE(str71, &
1417 &     '("should be the same, this was not case for variable ",a)') &
1418 &      TRIM(tmp_name)
1419      str72 = "PATCH : The smalest frequency of both is used"
1420      CALL ipslerr (2,"histdef",str70,str71,str72)
1421      IF (test_fopp < test_fwrt) THEN
1422        W_F(pfileid)%W_V(iv)%freq_opp = pfreq_opp
1423        W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_opp
1424      ELSE
1425        W_F(pfileid)%W_V(iv)%freq_opp = pfreq_wrt
1426        W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_wrt
1427      ENDIF
1428    ENDIF
1429  ELSE IF (INDEX(ex_topps,TRIM(tmp_topp)) > 0) THEN
1430    IF (test_fopp > test_fwrt) THEN
1431      str70 = 'For averages the frequency of operations '// &
1432&             'should be smaller or equal'
1433      WRITE(str71, &
1434 &     '("to that of output. It is not the case for variable ",a)') &
1435 &     TRIM(tmp_name)
1436      str72 = 'PATCH : The output frequency is used for both'
1437      CALL ipslerr (2,"histdef",str70,str71,str72)
1438      W_F(pfileid)%W_V(iv)%freq_opp = pfreq_wrt
1439    ENDIF
1440  ELSE
1441    WRITE (str70,'("Operation on variable ",a," is unknown")') &
1442&    TRIM(tmp_name)
1443    WRITE (str71,'("operation requested is :",a)') tmp_topp
1444    WRITE (str72,'("File ID :",I3)') pfileid
1445    CALL ipslerr (3,"histdef",str70,str71,str72)
1446  ENDIF
1447!-
1448! 5.0 Initialize other variables of the common
1449!-
1450  IF (l_dbg) WRITE(*,*) "histdef : 5.0"
1451!-
1452  W_F(pfileid)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range))
1453  IF (W_F(pfileid)%W_V(iv)%hist_wrt_rng) THEN
1454    W_F(pfileid)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2))
1455    IF (W_F(pfileid)%W_V(iv)%hist_calc_rng) THEN
1456      W_F(pfileid)%W_V(iv)%hist_minmax(1:2) = &
1457 &      (/ ABS(missing_val),-ABS(missing_val) /)
1458    ELSE
1459      W_F(pfileid)%W_V(iv)%hist_minmax(1:2) = var_range(1:2)
1460    ENDIF
1461  ENDIF
1462!-
1463! - freq_opp(pfileid,iv)/2./deltat(pfileid)
1464  W_F(pfileid)%W_V(iv)%last_opp = W_F(pfileid)%itau0
1465! - freq_wrt(pfileid,iv)/2./deltat(pfileid)
1466  W_F(pfileid)%W_V(iv)%last_wrt = W_F(pfileid)%itau0
1467! - freq_opp(pfileid,iv)/2./deltat(pfileid)
1468  W_F(pfileid)%W_V(iv)%last_opp_chk = W_F(pfileid)%itau0
1469! - freq_wrt(pfileid,iv)/2./deltat(pfileid)
1470  W_F(pfileid)%W_V(iv)%last_wrt_chk = W_F(pfileid)%itau0
1471  W_F(pfileid)%W_V(iv)%nb_opp = 0
1472  W_F(pfileid)%W_V(iv)%nb_wrt = 0
1473!-
1474! 6.0 Get the time axis for this variable
1475!-
1476  IF (l_dbg) WRITE(*,*) "histdef : 6.0"
1477!-
1478  IF (W_F(pfileid)%W_V(iv)%freq_wrt > 0) THEN
1479    WRITE(str10,'(I8.8)') INT(W_F(pfileid)%W_V(iv)%freq_wrt)
1480    str40 = TRIM(tmp_topp)//"_"//TRIM(str10)
1481  ELSE
1482    WRITE(str10,'(I2.2,"month")') ABS(INT(W_F(pfileid)%W_V(iv)%freq_wrt))
1483    str40 = TRIM(tmp_topp)//"_"//TRIM(str10)
1484  ENDIF
1485  CALL find_str (W_F(pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos)
1486!-
1487! No time axis for once, l_max, l_min or never operation
1488!-
1489  IF (     (TRIM(tmp_topp) /= 'once')  &
1490 &    .AND.(TRIM(tmp_topp) /= 'never') &
1491 &    .AND.(TRIM(tmp_topp) /= 'l_max') &
1492 &    .AND.(TRIM(tmp_topp) /= 'l_min') ) THEN
1493    IF (pos < 0) THEN
1494      W_F(pfileid)%n_tax = W_F(pfileid)%n_tax+1
1495      W_F(pfileid)%W_V(W_F(pfileid)%n_tax)%tax_name = str40
1496      W_F(pfileid)%W_V(W_F(pfileid)%n_tax)%tax_last = 0
1497      W_F(pfileid)%W_V(iv)%t_axid = W_F(pfileid)%n_tax
1498    ELSE
1499      W_F(pfileid)%W_V(iv)%t_axid = pos
1500    ENDIF
1501  ELSE
1502    IF (l_dbg)   WRITE(*,*) "histdef : 7.0 ",TRIM(tmp_topp),'----'
1503    W_F(pfileid)%W_V(iv)%t_axid = -99
1504  ENDIF
1505!-
1506! 7.0 prepare frequence of writing and operation
1507!     for never or once operation
1508!-
1509  IF (    (TRIM(tmp_topp) == 'once')  &
1510 &    .OR.(TRIM(tmp_topp) == 'never') ) THEN
1511    W_F(pfileid)%W_V(iv)%freq_opp = 0.
1512    W_F(pfileid)%W_V(iv)%freq_wrt = 0.
1513  ENDIF
1514!---------------------
1515END SUBROUTINE histdef
1516!===
1517SUBROUTINE histend (pfileid)
1518!---------------------------------------------------------------------
1519!- This subroutine end the decalaration of variables and sets the
1520!- time axes in the netcdf file and puts it into the write mode.
1521!-
1522!- INPUT
1523!-
1524!- pfileid : ID of the file to be worked on
1525!-
1526!- VERSION
1527!-
1528!---------------------------------------------------------------------
1529  IMPLICIT NONE
1530!-
1531  INTEGER,INTENT(IN) :: pfileid
1532!-
1533  INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt
1534  INTEGER,DIMENSION(4) :: dims
1535  INTEGER :: year,month,day,hours,minutes
1536  REAL :: sec
1537  REAL :: rtime0
1538  CHARACTER(LEN=30) :: str30
1539  CHARACTER(LEN=120) :: assoc
1540  CHARACTER(LEN=70) :: str70
1541  CHARACTER(LEN=3),DIMENSION(12) :: cal =   &
1542 &  (/ 'JAN','FEB','MAR','APR','MAY','JUN', &
1543 &     'JUL','AUG','SEP','OCT','NOV','DEC' /)
1544  CHARACTER(LEN=7) :: tmp_opp
1545  LOGICAL :: l_dbg
1546!---------------------------------------------------------------------
1547  CALL ipsldbg (old_status=l_dbg)
1548!-
1549  nfid = W_F(pfileid)%ncfid
1550!-
1551! 1.0 Create the time axes
1552!-
1553  IF (l_dbg) WRITE(*,*) "histend : 1.0"
1554!---
1555  iret = NF90_DEF_DIM (nfid,'time_counter', &
1556 &                     NF90_UNLIMITED,W_F(pfileid)%tid)
1557!-
1558! 1.1 Define all the time axes needed for this file
1559!-
1560  DO itx=1,W_F(pfileid)%n_tax
1561    dims(1) = W_F(pfileid)%tid
1562    IF (W_F(pfileid)%n_tax > 1) THEN
1563      str30 = "t_"//W_F(pfileid)%W_V(itx)%tax_name
1564    ELSE
1565      str30 = "time_counter"
1566    ENDIF
1567    iret = NF90_DEF_VAR (nfid,str30,NF90_DOUBLE, &
1568 &           dims(1),W_F(pfileid)%W_V(itx)%tdimid)
1569    IF (W_F(pfileid)%n_tax <= 1) THEN
1570      iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid,'axis',"T")
1571    ENDIF
1572    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1573 &           'standard_name',"time")
1574!---
1575!   To transform the current itau into a real date and take it
1576!   as the origin of the file requires the time counter to change.
1577!   Thus it is an operation the user has to ask for.
1578!   This function should thus only be re-instated
1579!   if there is a ioconf routine to control it.
1580!---
1581!-- rtime0 = itau2date(itau0(pfileid),date0(pfileid),deltat(pfileid))
1582    rtime0 = W_F(pfileid)%date0
1583!-
1584    CALL ju2ymds(rtime0,year,month,day,sec)
1585!---
1586!   Catch any error induced by a change in calendar !
1587!---
1588    IF (year < 0) THEN
1589      year = 2000+year
1590    ENDIF
1591!-
1592    hours = INT(sec/(60.*60.))
1593    minutes = INT((sec-hours*60.*60.)/60.)
1594    sec = sec-(hours*60.*60.+minutes*60.)
1595!-
1596    WRITE (UNIT=str70, &
1597 &   FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
1598 &    'seconds since ',year,month,day,hours,minutes,INT(sec)
1599    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1600 &           'units',TRIM(str70))
1601!-
1602    CALL ioget_calendar (str30)
1603    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1604 &           'calendar',TRIM(str30))
1605!-
1606    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1607 &           'title','Time')
1608!-
1609    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1610 &           'long_name','Time axis')
1611!-
1612    WRITE (UNIT=str70, &
1613 &   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
1614 &    year,cal(month),day,hours,minutes,INT(sec)
1615    iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, &
1616 &           'time_origin',TRIM(str70))
1617  ENDDO
1618!-
1619! 2.0 declare the variables
1620!-
1621  IF (l_dbg) WRITE(*,*) "histend : 2.0"
1622!-
1623  DO iv=1,W_F(pfileid)%n_var
1624!---
1625    itax = W_F(pfileid)%W_V(iv)%t_axid
1626!---
1627    IF (W_F(pfileid)%regular) THEN
1628      dims(1:2) = (/ W_F(pfileid)%xid,W_F(pfileid)%yid /)
1629      dim_cnt = 2
1630    ELSE
1631      dims(1) = W_F(pfileid)%xid
1632      dim_cnt = 1
1633    ENDIF
1634!---
1635    tmp_opp = W_F(pfileid)%W_V(iv)%topp
1636    ziv = W_F(pfileid)%W_V(iv)%z_axid
1637!---
1638!   2.1 dimension of field
1639!---
1640    IF ((TRIM(tmp_opp) /= 'never')) THEN
1641      IF (     (TRIM(tmp_opp) /= 'once')  &
1642     &    .AND.(TRIM(tmp_opp) /= 'l_max') &
1643     &    .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN
1644        IF (ziv == -99) THEN
1645          ndim = dim_cnt+1
1646          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(pfileid)%tid,0 /)
1647        ELSE
1648          ndim = dim_cnt+2
1649          dims(dim_cnt+1:dim_cnt+2) = &
1650 &         (/ W_F(pfileid)%zax_ids(ziv),W_F(pfileid)%tid /)
1651        ENDIF
1652      ELSE
1653        IF (ziv == -99) THEN
1654          ndim = dim_cnt
1655          dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /)
1656        ELSE
1657          ndim = dim_cnt+1
1658          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(pfileid)%zax_ids(ziv),0 /)
1659        ENDIF
1660      ENDIF
1661!-
1662      iret = NF90_DEF_VAR (nfid,TRIM(W_F(pfileid)%W_V(iv)%v_name), &
1663 &             W_F(pfileid)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid)
1664!-
1665      W_F(pfileid)%W_V(iv)%ncvid = nvid
1666!-
1667      IF (LEN_TRIM(W_F(pfileid)%W_V(iv)%unit_name) > 0) THEN
1668        iret = NF90_PUT_ATT (nfid,nvid,'units', &
1669 &                           TRIM(W_F(pfileid)%W_V(iv)%unit_name))
1670      ENDIF
1671      iret = NF90_PUT_ATT (nfid,nvid,'standard_name', &
1672 &                         TRIM(W_F(pfileid)%W_V(iv)%std_name))
1673!-
1674      iret = NF90_PUT_ATT (nfid,nvid,'_FillValue', &
1675 &                         REAL(missing_val,KIND=4))
1676      IF (W_F(pfileid)%W_V(iv)%hist_wrt_rng) THEN
1677        iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
1678 &               REAL(W_F(pfileid)%W_V(iv)%hist_minmax(1),KIND=4))
1679        iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
1680 &               REAL(W_F(pfileid)%W_V(iv)%hist_minmax(2),KIND=4))
1681      ENDIF
1682      iret = NF90_PUT_ATT (nfid,nvid,'long_name', &
1683 &                         TRIM(W_F(pfileid)%W_V(iv)%title))
1684      iret = NF90_PUT_ATT (nfid,nvid,'online_operation', &
1685 &                         TRIM(W_F(pfileid)%W_V(iv)%fullop))
1686!-
1687      SELECT CASE(ndim)
1688      CASE(-3,2:4)
1689      CASE DEFAULT
1690        CALL ipslerr (3,"histend", &
1691       &  'less than 2 or more than 4 dimensions are not', &
1692       &  'allowed at this stage',' ')
1693      END SELECT
1694!-
1695      assoc=TRIM(W_F(pfileid)%hax_name(W_F(pfileid)%W_V(iv)%h_axid,2)) &
1696 &   //' '//TRIM(W_F(pfileid)%hax_name(W_F(pfileid)%W_V(iv)%h_axid,1))
1697!-
1698      ziv = W_F(pfileid)%W_V(iv)%z_axid
1699      IF (ziv > 0) THEN
1700        str30 = W_F(pfileid)%zax_name(ziv)
1701        assoc = TRIM(str30)//' '//TRIM(assoc)
1702      ENDIF
1703!-
1704      IF (itax > 0) THEN
1705        IF (W_F(pfileid)%n_tax > 1) THEN
1706          str30 = "t_"//W_F(pfileid)%W_V(itax)%tax_name
1707        ELSE
1708          str30 = "time_counter"
1709        ENDIF
1710        assoc = TRIM(str30)//' '//TRIM(assoc)
1711!-
1712        IF (l_dbg) THEN
1713          WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", &
1714 &          W_F(pfileid)%W_V(iv)%freq_opp,W_F(pfileid)%W_V(iv)%freq_wrt
1715        ENDIF
1716!-
1717        iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', &
1718 &                           REAL(W_F(pfileid)%W_V(iv)%freq_opp,KIND=4))
1719        iret = NF90_PUT_ATT (nfid,nvid,'interval_write', &
1720 &                           REAL(W_F(pfileid)%W_V(iv)%freq_wrt,KIND=4))
1721      ENDIF
1722      iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc))
1723    ENDIF
1724  ENDDO
1725!-
1726! 2.2 Add DOMAIN attributes if needed
1727!-
1728  IF (W_F(pfileid)%dom_id_svg >= 0) THEN
1729    CALL flio_dom_att (nfid,W_F(pfileid)%dom_id_svg)
1730  ENDIF
1731!-
1732! 3.0 Put the netcdf file into write mode
1733!-
1734  IF (l_dbg) WRITE(*,*) "histend : 3.0"
1735!-
1736  iret = NF90_ENDDEF (nfid)
1737!-
1738! 4.0 Give some informations to the user
1739!-
1740  IF (l_dbg) WRITE(*,*) "histend : 4.0"
1741!-
1742  WRITE(str70,'("All variables have been initialized on file :",I3)') pfileid
1743  CALL ipslerr (1,'histend',str70,'',' ')
1744!---------------------
1745END SUBROUTINE histend
1746!===
1747SUBROUTINE histwrite_r1d (pfileid,pvarname,pitau,pdata,nbindex,nindex)
1748!---------------------------------------------------------------------
1749  IMPLICIT NONE
1750!-
1751  INTEGER,INTENT(IN) :: pfileid,pitau,nbindex
1752  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1753  REAL,DIMENSION(:),INTENT(IN) :: pdata
1754  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1755!---------------------------------------------------------------------
1756  CALL histw_rnd (pfileid,pvarname,pitau,nbindex,nindex,pdata_1d=pdata)
1757!---------------------------
1758END SUBROUTINE histwrite_r1d
1759!===
1760SUBROUTINE histwrite_r2d (pfileid,pvarname,pitau,pdata,nbindex,nindex)
1761!---------------------------------------------------------------------
1762  IMPLICIT NONE
1763!-
1764  INTEGER,INTENT(IN) :: pfileid,pitau,nbindex
1765  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1766  REAL,DIMENSION(:,:),INTENT(IN) :: pdata
1767  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1768!---------------------------------------------------------------------
1769  CALL histw_rnd (pfileid,pvarname,pitau,nbindex,nindex,pdata_2d=pdata)
1770!---------------------------
1771END SUBROUTINE histwrite_r2d
1772!===
1773SUBROUTINE histwrite_r3d (pfileid,pvarname,pitau,pdata,nbindex,nindex)
1774!---------------------------------------------------------------------
1775  IMPLICIT NONE
1776!-
1777  INTEGER,INTENT(IN) :: pfileid,pitau,nbindex
1778  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1779  REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
1780  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1781!---------------------------------------------------------------------
1782  CALL histw_rnd (pfileid,pvarname,pitau,nbindex,nindex,pdata_3d=pdata)
1783!---------------------------
1784END SUBROUTINE histwrite_r3d
1785!===
1786SUBROUTINE histw_rnd (pfileid,pvarname,pitau,nbindex,nindex, &
1787  &                   pdata_1d,pdata_2d,pdata_3d)
1788!---------------------------------------------------------------------
1789  IMPLICIT NONE
1790!-
1791  INTEGER,INTENT(IN) :: pfileid,pitau,nbindex
1792  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
1793  CHARACTER(LEN=*),INTENT(IN) :: pvarname
1794  REAL,DIMENSION(:),INTENT(IN),OPTIONAL     :: pdata_1d
1795  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL   :: pdata_2d
1796  REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d
1797!-
1798  LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d
1799  INTEGER :: varid,io,nbpt_out
1800  INTEGER              :: nbpt_in1
1801  INTEGER,DIMENSION(2) :: nbpt_in2
1802  INTEGER,DIMENSION(3) :: nbpt_in3
1803  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp
1804  INTEGER,SAVE :: buff_tmp_sz
1805  CHARACTER(LEN=7) :: tmp_opp
1806  CHARACTER(LEN=13) :: c_nam
1807  LOGICAL :: l_dbg
1808!---------------------------------------------------------------------
1809  CALL ipsldbg (old_status=l_dbg)
1810!-
1811  l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d);
1812  IF      (l1d) THEN
1813    c_nam = 'histwrite_r1d'
1814  ELSE IF (l2d) THEN
1815    c_nam = 'histwrite_r2d'
1816  ELSE IF (l3d) THEN
1817    c_nam = 'histwrite_r3d'
1818  ENDIF
1819!-
1820! 1.0 Try to catch errors like specifying the wrong file ID.
1821!     Thanks Marine for showing us what errors users can make !
1822!-
1823  IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN
1824    CALL ipslerr (3,"histwrite", &
1825 &    'Illegal file ID in the histwrite of variable',pvarname,' ')
1826  ENDIF
1827!-
1828! 1.1 Find the id of the variable to be written and the real time
1829!-
1830  CALL histvar_seq (pfileid,pvarname,varid)
1831!-
1832! 2.0 do nothing for never operation
1833!-
1834  tmp_opp = W_F(pfileid)%W_V(varid)%topp
1835!-
1836  IF (TRIM(tmp_opp) == "never") THEN
1837    W_F(pfileid)%W_V(varid)%last_opp_chk = -99
1838    W_F(pfileid)%W_V(varid)%last_wrt_chk = -99
1839  ENDIF
1840!-
1841! 3.0 We check if we need to do an operation
1842!-
1843  IF (W_F(pfileid)%W_V(varid)%last_opp_chk == pitau) THEN
1844    CALL ipslerr (3,"histwrite", &
1845 &    'This variable has already been analysed at the present', &
1846 &    'time step',TRIM(pvarname))
1847  ENDIF
1848!-
1849  CALL isittime &
1850 &  (pitau,W_F(pfileid)%date0,W_F(pfileid)%deltat, &
1851 &   W_F(pfileid)%W_V(varid)%freq_opp, &
1852 &   W_F(pfileid)%W_V(varid)%last_opp, &
1853 &   W_F(pfileid)%W_V(varid)%last_opp_chk,do_oper)
1854!-
1855! 4.0 We check if we need to write the data
1856!-
1857  IF (W_F(pfileid)%W_V(varid)%last_wrt_chk == pitau) THEN
1858    CALL ipslerr (3,"histwrite", &
1859 &    'This variable as already been written for the present', &
1860 &    'time step',' ')
1861  ENDIF
1862!-
1863  CALL isittime &
1864 &  (pitau,W_F(pfileid)%date0,W_F(pfileid)%deltat, &
1865 &   W_F(pfileid)%W_V(varid)%freq_wrt, &
1866 &   W_F(pfileid)%W_V(varid)%last_wrt, &
1867 &   W_F(pfileid)%W_V(varid)%last_wrt_chk,do_write)
1868!-
1869! 5.0 histwrite called
1870!-
1871  IF (do_oper.OR.do_write) THEN
1872!-
1873!-- 5.1 Get the sizes of the data we will handle
1874!-
1875    IF (W_F(pfileid)%W_V(varid)%datasz_in(1) <= 0) THEN
1876!---- There is the risk here that the user has over-sized the array.
1877!---- But how can we catch this ?
1878!---- In the worst case we will do impossible operations
1879!---- on part of the data !
1880      W_F(pfileid)%W_V(varid)%datasz_in(1:3) = -1
1881      IF      (l1d) THEN
1882        W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_1d)
1883      ELSE IF (l2d) THEN
1884        W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_2d,DIM=1)
1885        W_F(pfileid)%W_V(varid)%datasz_in(2) = SIZE(pdata_2d,DIM=2)
1886      ELSE IF (l3d) THEN
1887        W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_3d,DIM=1)
1888        W_F(pfileid)%W_V(varid)%datasz_in(2) = SIZE(pdata_3d,DIM=2)
1889        W_F(pfileid)%W_V(varid)%datasz_in(3) = SIZE(pdata_3d,DIM=3)
1890      ENDIF
1891    ENDIF
1892!-
1893!-- 5.2 The maximum size of the data will give the size of the buffer
1894!-
1895    IF (W_F(pfileid)%W_V(varid)%datasz_max <= 0) THEN
1896      largebuf = .FALSE.
1897      DO io=1,W_F(pfileid)%W_V(varid)%nbopp
1898        IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopps(io)) > 0) THEN
1899          largebuf = .TRUE.
1900        ENDIF
1901      ENDDO
1902      IF (largebuf) THEN
1903        W_F(pfileid)%W_V(varid)%datasz_max = &
1904 &        W_F(pfileid)%W_V(varid)%scsize(1) &
1905 &       *W_F(pfileid)%W_V(varid)%scsize(2) &
1906 &       *W_F(pfileid)%W_V(varid)%scsize(3)
1907      ELSE
1908        IF      (l1d) THEN
1909          W_F(pfileid)%W_V(varid)%datasz_max = &
1910 &          W_F(pfileid)%W_V(varid)%datasz_in(1)
1911        ELSE IF (l2d) THEN
1912          W_F(pfileid)%W_V(varid)%datasz_max = &
1913 &          W_F(pfileid)%W_V(varid)%datasz_in(1) &
1914 &         *W_F(pfileid)%W_V(varid)%datasz_in(2)
1915        ELSE IF (l3d) THEN
1916          W_F(pfileid)%W_V(varid)%datasz_max = &
1917 &          W_F(pfileid)%W_V(varid)%datasz_in(1) &
1918 &         *W_F(pfileid)%W_V(varid)%datasz_in(2) &
1919 &         *W_F(pfileid)%W_V(varid)%datasz_in(3)
1920        ENDIF
1921      ENDIF
1922    ENDIF
1923!-
1924    IF (.NOT.ALLOCATED(buff_tmp)) THEN
1925      IF (l_dbg) THEN
1926        WRITE(*,*) &
1927 &       c_nam//" : allocate buff_tmp for buff_sz = ", &
1928 &       W_F(pfileid)%W_V(varid)%datasz_max
1929      ENDIF
1930      ALLOCATE(buff_tmp(W_F(pfileid)%W_V(varid)%datasz_max))
1931      buff_tmp_sz = W_F(pfileid)%W_V(varid)%datasz_max
1932    ELSE IF (W_F(pfileid)%W_V(varid)%datasz_max > buff_tmp_sz) THEN
1933      IF (l_dbg) THEN
1934        WRITE(*,*) &
1935 &       c_nam//" : re-allocate buff_tmp for buff_sz = ", &
1936 &       W_F(pfileid)%W_V(varid)%datasz_max
1937      ENDIF
1938      DEALLOCATE(buff_tmp)
1939      ALLOCATE(buff_tmp(W_F(pfileid)%W_V(varid)%datasz_max))
1940      buff_tmp_sz = W_F(pfileid)%W_V(varid)%datasz_max
1941    ENDIF
1942!-
1943!-- We have to do the first operation anyway.
1944!-- Thus we do it here and change the ranke
1945!-- of the data at the same time. This should speed up things.
1946!-
1947    nbpt_out = W_F(pfileid)%W_V(varid)%datasz_max
1948    IF      (l1d) THEN
1949      nbpt_in1 = W_F(pfileid)%W_V(varid)%datasz_in(1)
1950      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in1,pdata_1d, &
1951 &                 missing_val,nbindex,nindex, &
1952 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
1953    ELSE IF (l2d) THEN
1954      nbpt_in2(1:2) = W_F(pfileid)%W_V(varid)%datasz_in(1:2)
1955      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in2,pdata_2d, &
1956 &                 missing_val,nbindex,nindex, &
1957 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
1958    ELSE IF (l3d) THEN
1959      nbpt_in3(1:3) = W_F(pfileid)%W_V(varid)%datasz_in(1:3)
1960      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in3,pdata_3d, &
1961 &                 missing_val,nbindex,nindex, &
1962 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
1963    ENDIF
1964    CALL histwrite_real (pfileid,varid,pitau,nbpt_out, &
1965 &            buff_tmp,nbindex,nindex,do_oper,do_write)
1966  ENDIF
1967!-
1968! 6.0 Manage time steps
1969!-
1970  IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
1971    W_F(pfileid)%W_V(varid)%last_opp_chk = pitau
1972    W_F(pfileid)%W_V(varid)%last_wrt_chk = pitau
1973  ELSE
1974    W_F(pfileid)%W_V(varid)%last_opp_chk = -99
1975    W_F(pfileid)%W_V(varid)%last_wrt_chk = -99
1976  ENDIF
1977!-----------------------
1978END SUBROUTINE histw_rnd
1979!===
1980SUBROUTINE histwrite_real &
1981 & (pfileid,varid,pitau,nbdpt,buff_tmp,nbindex,nindex,do_oper,do_write)
1982!---------------------------------------------------------------------
1983!- This subroutine is internal and does the calculations and writing
1984!- if needed. At a later stage it should be split into an operation
1985!- and writing subroutines.
1986!---------------------------------------------------------------------
1987  IMPLICIT NONE
1988!-
1989  INTEGER,INTENT(IN) :: pfileid,pitau,varid, &
1990 &                      nbindex,nindex(nbindex),nbdpt
1991  REAL,DIMENSION(:)  :: buff_tmp
1992  LOGICAL,INTENT(IN) :: do_oper,do_write
1993!-
1994  INTEGER :: tsz,nfid,nvid,i,iret,ipt,itax,io,nbin,nbout
1995  INTEGER :: nx,ny,nz,ky,kz,kt,kc
1996  INTEGER,DIMENSION(4) :: corner,edges
1997  INTEGER :: itime
1998!-
1999  REAL :: rtime
2000  CHARACTER(LEN=7) :: tmp_opp
2001  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp2,buffer_used
2002  INTEGER,SAVE :: buff_tmp2_sz,buffer_sz
2003  LOGICAL :: l_dbg
2004!---------------------------------------------------------------------
2005  CALL ipsldbg (old_status=l_dbg)
2006!-
2007  IF (l_dbg) THEN
2008    WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(pfileid)%W_V(varid)%v_name
2009    WRITE(*,*) "histwrite 0.0 : nbindex,nindex :", &
2010 &  nbindex,nindex(1:MIN(3,nbindex)),'...',nindex(MAX(1,nbindex-3):nbindex)
2011  ENDIF
2012!-
2013! The sizes which can be encoutered
2014!-
2015  tsz =  W_F(pfileid)%W_V(varid)%zsize(1) &
2016 &      *W_F(pfileid)%W_V(varid)%zsize(2) &
2017 &      *W_F(pfileid)%W_V(varid)%zsize(3)
2018!-
2019! 1.0 We allocate the memory needed to store the data between write
2020!     and the temporary space needed for operations.
2021!     We have to keep precedent buffer if needed
2022!-
2023  IF (.NOT. ALLOCATED(buffer)) THEN
2024    IF (l_dbg) WRITE(*,*) "histwrite_real 1.0 allocate buffer ",buff_pos
2025    ALLOCATE(buffer(buff_pos))
2026    buffer_sz = buff_pos
2027    buffer(:)=0.0
2028  ELSE IF (buffer_sz < buff_pos) THEN
2029    IF (l_dbg) THEN
2030      WRITE(*,*) "histwrite_real 1.0.1 re-allocate buffer for ", &
2031 &      buff_pos," instead of ",SIZE(buffer)
2032    ENDIF
2033    IF (SUM(buffer)/=0.0) THEN
2034      IF (l_dbg) WRITE (*,*) 'histwrite : buffer has been used. ', &
2035 &      'We have to save it before re-allocating.'
2036      ALLOCATE(buffer_used(buffer_sz))
2037      buffer_used(:)=buffer(:)
2038      DEALLOCATE(buffer)
2039      ALLOCATE(buffer(buff_pos))
2040      buffer_sz = buff_pos
2041      buffer(:)=0.0
2042      buffer(:SIZE(buffer_used))=buffer_used
2043      DEALLOCATE(buffer_used)
2044    ELSE
2045      IF (l_dbg) WRITE (*,*) 'histwrite : buffer has not been used. ', &
2046 &      'We have just to re-allocate it.'
2047      DEALLOCATE(buffer)
2048      ALLOCATE(buffer(buff_pos))
2049      buffer_sz = buff_pos
2050      buffer(:)=0.0
2051    ENDIF
2052  ENDIF
2053!-
2054! The buffers are only deallocated when more space is needed. This
2055! reduces the umber of allocates but increases memory needs.
2056!-
2057  IF (.NOT.ALLOCATED(buff_tmp2)) THEN
2058    IF (l_dbg) THEN
2059      WRITE(*,*) "histwrite_real 1.1 allocate buff_tmp2 ",SIZE(buff_tmp)
2060    ENDIF
2061    ALLOCATE(buff_tmp2(W_F(pfileid)%W_V(varid)%datasz_max))
2062    buff_tmp2_sz = W_F(pfileid)%W_V(varid)%datasz_max
2063  ELSE IF (W_F(pfileid)%W_V(varid)%datasz_max > buff_tmp2_sz) THEN
2064    IF (l_dbg) THEN
2065      WRITE(*,*) "histwrite_real 1.2 re-allocate buff_tmp2 : ", &
2066     & SIZE(buff_tmp)," instead of ",SIZE(buff_tmp2)
2067    ENDIF
2068    DEALLOCATE(buff_tmp2)
2069    ALLOCATE(buff_tmp2(W_F(pfileid)%W_V(varid)%datasz_max))
2070    buff_tmp2_sz = W_F(pfileid)%W_V(varid)%datasz_max
2071  ENDIF
2072!-
2073  rtime = pitau*W_F(pfileid)%deltat
2074  tmp_opp = W_F(pfileid)%W_V(varid)%topp
2075!-
2076! 3.0 Do the operations or transfer the slab of data into buff_tmp
2077!-
2078  IF (l_dbg) WRITE(*,*) "histwrite: 3.0",pfileid
2079!-
2080! 3.1 DO the Operations only if needed
2081!-
2082  IF (do_oper) THEN
2083    i = pfileid
2084    nbout = nbdpt
2085!-
2086!-- 3.4 We continue the sequence of operations
2087!--     we started in the interface routine
2088!-
2089    DO io=2,W_F(i)%W_V(varid)%nbopp,2
2090      nbin = nbout
2091      nbout = W_F(i)%W_V(varid)%datasz_max
2092      CALL mathop(W_F(i)%W_V(varid)%sopps(io),nbin,buff_tmp, &
2093 &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io), &
2094 &      nbout,buff_tmp2)
2095      IF (l_dbg) THEN
2096        WRITE(*,*) &
2097 &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io)
2098      ENDIF
2099!-
2100      nbin = nbout
2101      nbout = W_F(i)%W_V(varid)%datasz_max
2102      CALL mathop(W_F(i)%W_V(varid)%sopps(io+1),nbin,buff_tmp2, &
2103 &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io+1), &
2104 &      nbout,buff_tmp)
2105      IF (l_dbg) THEN
2106        WRITE(*,*) &
2107 &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io+1)
2108      ENDIF
2109    ENDDO
2110!-
2111!   3.5 Zoom into the data
2112!-
2113    IF (l_dbg) THEN
2114      WRITE(*,*) &
2115 &     "histwrite: 3.5 size(buff_tmp) : ",SIZE(buff_tmp)
2116      WRITE(*,*) &
2117 &     "histwrite: 3.5 slab in X :", &
2118 &     W_F(i)%W_V(varid)%zorig(1),W_F(i)%W_V(varid)%zsize(1)
2119      WRITE(*,*) &
2120 &     "histwrite: 3.5 slab in Y :", &
2121 &     W_F(i)%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zsize(2)
2122      WRITE(*,*) &
2123 &     "histwrite: 3.5 slab in Z :", &
2124 &     W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zsize(3)
2125      WRITE(*,*) &
2126 &     "histwrite: 3.5 slab of input:", &
2127 &     W_F(i)%W_V(varid)%scsize(1), &
2128 &     W_F(i)%W_V(varid)%scsize(2), &
2129 &     W_F(i)%W_V(varid)%scsize(3)
2130    ENDIF
2131!---
2132!-- We have to consider blocks of contiguous data
2133!---
2134    nx=MAX(W_F(i)%W_V(varid)%zsize(1),1)
2135    ny=MAX(W_F(i)%W_V(varid)%zsize(2),1)
2136    nz=MAX(W_F(i)%W_V(varid)%zsize(3),1)
2137    IF     (     (W_F(i)%W_V(varid)%zorig(1) == 1) &
2138 &          .AND.(   W_F(i)%W_V(varid)%zsize(1) &
2139 &                == W_F(i)%W_V(varid)%scsize(1)) &
2140 &          .AND.(W_F(i)%W_V(varid)%zorig(2) == 1) &
2141 &          .AND.(   W_F(i)%W_V(varid)%zsize(2) &
2142 &                == W_F(i)%W_V(varid)%scsize(2))) THEN
2143      kt = (W_F(i)%W_V(varid)%zorig(3)-1)*nx*ny
2144      buff_tmp2(1:nx*ny*nz) = buff_tmp(kt+1:kt+nx*ny*nz)
2145    ELSEIF (     (W_F(i)%W_V(varid)%zorig(1) == 1) &
2146 &          .AND.(   W_F(i)%W_V(varid)%zsize(1) &
2147 &                == W_F(i)%W_V(varid)%scsize(1))) THEN
2148      kc = -nx*ny
2149      DO kz=W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-1
2150        kc = kc+nx*ny
2151        kt = ( (kz-1)*W_F(i)%W_V(varid)%scsize(2) &
2152 &            +W_F(i)%W_V(varid)%zorig(2)-1)*nx
2153        buff_tmp2(kc+1:kc+nx*ny) = buff_tmp(kt+1:kt+nx*ny)
2154      ENDDO
2155    ELSE
2156      kc = -nx
2157      DO kz=W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-1
2158        DO ky=W_F(i)%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zorig(2)+ny-1
2159          kc = kc+nx
2160          kt = ((kz-1)*W_F(i)%W_V(varid)%scsize(2)+ky-1) &
2161 &            *W_F(i)%W_V(varid)%scsize(1) &
2162 &            +W_F(i)%W_V(varid)%zorig(1)-1
2163          buff_tmp2(kc+1:kc+nx) = buff_tmp(kt+1:kt+nx)
2164        ENDDO
2165      ENDDO
2166    ENDIF
2167!-
2168!-- 4.0 Get the min and max of the field (buff_tmp)
2169!-
2170    IF (l_dbg) WRITE(*,*) "histwrite: 4.0 buff_tmp",pfileid,varid, &
2171 &    TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex
2172!-
2173    IF (W_F(pfileid)%W_V(varid)%hist_calc_rng) THEN
2174      W_F(pfileid)%W_V(varid)%hist_minmax(1) = &
2175 &      MIN(W_F(pfileid)%W_V(varid)%hist_minmax(1), &
2176 &      MINVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val))
2177      W_F(pfileid)%W_V(varid)%hist_minmax(2) = &
2178 &      MAX(W_F(pfileid)%W_V(varid)%hist_minmax(2), &
2179 &      MAXVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val))
2180    ENDIF
2181!-
2182!-- 5.0 Do the operations if needed. In the case of instantaneous
2183!--     output we do not transfer to the buffer.
2184!-
2185    IF (l_dbg) WRITE(*,*) "histwrite: 5.0",pfileid,"tsz :",tsz
2186!-
2187    ipt = W_F(pfileid)%W_V(varid)%point
2188!-
2189!   WRITE(*,*) 'OPE ipt, buffer :',pvarname,ipt,varid
2190!-
2191    IF (     (TRIM(tmp_opp) /= "inst") &
2192 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2193      CALL moycum(tmp_opp,tsz,buffer(ipt:), &
2194 &           buff_tmp2,W_F(pfileid)%W_V(varid)%nb_opp)
2195    ENDIF
2196!-
2197    W_F(pfileid)%W_V(varid)%last_opp = pitau
2198    W_F(pfileid)%W_V(varid)%nb_opp = W_F(pfileid)%W_V(varid)%nb_opp+1
2199!-
2200  ENDIF
2201!-
2202! 6.0 Write to file if needed
2203!-
2204  IF (l_dbg) WRITE(*,*) "histwrite: 6.0",pfileid
2205!-
2206  IF (do_write) THEN
2207!-
2208    nfid = W_F(pfileid)%ncfid
2209    nvid = W_F(pfileid)%W_V(varid)%ncvid
2210!-
2211!-- 6.1 Do the operations that are needed before writting
2212!-
2213    IF (l_dbg) WRITE(*,*) "histwrite: 6.1",pfileid
2214!-
2215    IF (     (TRIM(tmp_opp) /= "inst") &
2216 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2217      rtime = ( rtime &
2218 &             +W_F(pfileid)%W_V(varid)%last_wrt*W_F(pfileid)%deltat)/2.0
2219    ENDIF
2220!-
2221!-- 6.2 Add a value to the time axis of this variable if needed
2222!-
2223    IF (     (TRIM(tmp_opp) /= "l_max") &
2224 &      .AND.(TRIM(tmp_opp) /= "l_min") &
2225 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2226!-
2227      IF (l_dbg) WRITE(*,*) "histwrite: 6.2",pfileid
2228!-
2229      itax = W_F(pfileid)%W_V(varid)%t_axid
2230      itime = W_F(pfileid)%W_V(varid)%nb_wrt+1
2231!-
2232      IF (W_F(pfileid)%W_V(itax)%tax_last < itime) THEN
2233        iret = NF90_PUT_VAR (nfid,W_F(pfileid)%W_V(itax)%tdimid, &
2234 &               (/ rtime /),start=(/ itime /),count=(/ 1 /))
2235        W_F(pfileid)%W_V(itax)%tax_last = itime
2236      ENDIF
2237    ELSE
2238      itime=1
2239    ENDIF
2240!-
2241!-- 6.3 Write the data. Only in the case of instantaneous output
2242!       we do not write the buffer.
2243!-
2244    IF (l_dbg) THEN
2245      WRITE(*,*) "histwrite: 6.3",pfileid,nfid,nvid,varid,itime
2246    ENDIF
2247!-
2248    IF (W_F(pfileid)%W_V(varid)%scsize(3) == 1) THEN
2249      IF (W_F(pfileid)%regular) THEN
2250        corner(1:4) = (/ 1,1,itime,0 /)
2251        edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), &
2252 &                      W_F(pfileid)%W_V(varid)%zsize(2),1,0 /)
2253      ELSE
2254        corner(1:4) = (/ 1,itime,0,0 /)
2255        edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1),1,0,0 /)
2256      ENDIF
2257    ELSE
2258      IF (W_F(pfileid)%regular) THEN
2259        corner(1:4) = (/ 1,1,1,itime /)
2260        edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), &
2261 &                      W_F(pfileid)%W_V(varid)%zsize(2), &
2262 &                      W_F(pfileid)%W_V(varid)%zsize(3),1 /)
2263      ELSE
2264        corner(1:4) = (/ 1,1,itime,0 /)
2265        edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), &
2266 &                      W_F(pfileid)%W_V(varid)%zsize(3),1,0 /)
2267      ENDIF
2268    ENDIF
2269!-
2270    ipt = W_F(pfileid)%W_V(varid)%point
2271!-
2272    IF (     (TRIM(tmp_opp) /= "inst") &
2273 &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
2274      iret = NF90_PUT_VAR (nfid,nvid,buffer(ipt:), &
2275 &                       start=corner(1:4),count=edges(1:4))
2276    ELSE
2277      iret = NF90_PUT_VAR (nfid,nvid,buff_tmp2, &
2278 &                       start=corner(1:4),count=edges(1:4))
2279    ENDIF
2280!-
2281    W_F(pfileid)%W_V(varid)%last_wrt = pitau
2282    W_F(pfileid)%W_V(varid)%nb_wrt = W_F(pfileid)%W_V(varid)%nb_wrt+1
2283    W_F(pfileid)%W_V(varid)%nb_opp = 0
2284!---
2285!   After the write the file can be synchronized so that no data is
2286!   lost in case of a crash. This feature gives up on the benefits of
2287!   buffering and should only be used in debuging mode. A flag is
2288!   needed here to switch to this mode.
2289!---
2290!   iret = NF90_SYNC (nfid)
2291!-
2292  ENDIF
2293!----------------------------
2294END SUBROUTINE histwrite_real
2295!===
2296SUBROUTINE histvar_seq (pfid,pvarname,pvid)
2297!---------------------------------------------------------------------
2298!- This subroutine optimized the search for the variable in the table.
2299!- In a first phase it will learn the succession of the variables
2300!- called and then it will use the table to guess what comes next.
2301!- It is the best solution to avoid lengthy searches through array
2302!- vectors.
2303!-
2304!- ARGUMENTS :
2305!-
2306!- pfid  : id of the file on which we work
2307!- pvarname : The name of the variable we are looking for
2308!- pvid     : The var id we found
2309!---------------------------------------------------------------------
2310  IMPLICIT NONE
2311!-
2312  INTEGER,INTENT(in)  :: pfid
2313  CHARACTER(LEN=*),INTENT(IN) :: pvarname
2314  INTEGER,INTENT(out) :: pvid
2315!-
2316  LOGICAL,SAVE :: learning(nb_files_max)=.TRUE.
2317  INTEGER,SAVE :: overlap(nb_files_max) = -1
2318  INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3)
2319  INTEGER,SAVE :: varseq_len(nb_files_max) = 0
2320  INTEGER,SAVE :: varseq_pos(nb_files_max)
2321  INTEGER,SAVE :: varseq_err(nb_files_max) = 0
2322  INTEGER      :: ib,sp,nn,pos
2323  CHARACTER(LEN=70) :: str70
2324  LOGICAL :: l_dbg
2325!---------------------------------------------------------------------
2326  CALL ipsldbg (old_status=l_dbg)
2327!-
2328  IF (l_dbg) THEN
2329    WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(pfid)
2330  ENDIF
2331!-
2332  IF (learning(pfid)) THEN
2333!-
2334!-- 1.0 We compute the length over which we are going
2335!--     to check the overlap
2336!-
2337    IF (overlap(pfid) <= 0) THEN
2338      IF (W_F(pfid)%n_var > 6) THEN
2339        overlap(pfid) = W_F(pfid)%n_var/3*2
2340      ELSE
2341        overlap(pfid) = W_F(pfid)%n_var
2342      ENDIF
2343    ENDIF
2344!-
2345!-- 1.1 Find the position of this string
2346!-
2347    CALL find_str (W_F(pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos)
2348    IF (pos > 0) THEN
2349      pvid = pos
2350    ELSE
2351      CALL ipslerr (3,"histvar_seq", &
2352 &      'The name of the variable you gave has not been declared', &
2353 &      'You should use subroutine histdef for declaring variable', &
2354 &      TRIM(pvarname))
2355    ENDIF
2356!-
2357!-- 1.2 If we have not given up we store the position
2358!--     in the sequence of calls
2359!-
2360    IF (varseq_err(pfid) >= 0) THEN
2361      sp = varseq_len(pfid)+1
2362      IF (sp <= nb_var_max*3) THEN
2363        varseq(pfid,sp) = pvid
2364        varseq_len(pfid) = sp
2365      ELSE
2366        CALL ipslerr (2,"histvar_seq",&
2367 &       'The learning process has failed and we give up. '// &
2368 &       'Either you sequence is',&
2369 &       'too complex or I am too dumb. '// &
2370 &       'This will only affect the efficiency',&
2371 &       'of your code. Thus if you wish to save time'// &
2372 &       ' contact the IOIPSL team. ')
2373        WRITE(*,*) 'The sequence we have found up to now :'
2374        WRITE(*,*) varseq(pfid,1:sp-1)
2375        varseq_err(pfid) = -1
2376      ENDIF
2377!-
2378!---- 1.3 Check if we have found the right overlap
2379!-
2380      IF (varseq_len(pfid) >= overlap(pfid)*2) THEN
2381!-
2382!------ We skip a few variables if needed as they could come
2383!------ from the initialisation of the model.
2384!-
2385        DO ib = 0,sp-overlap(pfid)*2
2386          IF ( learning(pfid) .AND.&
2387            & SUM(ABS(varseq(pfid,ib+1:ib+overlap(pfid)) -&
2388            & varseq(pfid,sp-overlap(pfid)+1:sp))) == 0 ) THEN
2389            learning(pfid) = .FALSE.
2390            varseq_len(pfid) = sp-overlap(pfid)-ib
2391            varseq_pos(pfid) = overlap(pfid)+ib
2392            varseq(pfid,1:varseq_len(pfid)) = &
2393 &            varseq(pfid,ib+1:ib+varseq_len(pfid))
2394          ENDIF
2395        ENDDO
2396      ENDIF
2397    ENDIF
2398  ELSE
2399!-
2400!-- 2.0 Now we know how the calls to histwrite are sequenced
2401!--     and we can get a guess at the var ID
2402!-
2403    nn = varseq_pos(pfid)+1
2404    IF (nn > varseq_len(pfid)) nn = 1
2405!-
2406    pvid = varseq(pfid,nn)
2407!-
2408    IF (TRIM(W_F(pfid)%W_V(pvid)%v_name) /= TRIM(pvarname)) THEN
2409      CALL find_str (W_F(pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos)
2410      IF (pos > 0) THEN
2411        pvid = pos
2412      ELSE
2413        CALL ipslerr (3,"histvar_seq", &
2414 &  'The name of the variable you gave has not been declared',&
2415 &  'You should use subroutine histdef for declaring variable', &
2416 &  TRIM(pvarname))
2417      ENDIF
2418      varseq_err(pfid) = varseq_err(pfid)+1
2419    ELSE
2420!-
2421!---- We only keep the new position if we have found the variable
2422!---- this way. This way an out of sequence call to histwrite does
2423!---- not defeat the process.
2424!-
2425      varseq_pos(pfid) = nn
2426    ENDIF
2427!-
2428    IF (varseq_err(pfid) >= 10) THEN
2429      WRITE(str70,'("for file ",I3)') pfid
2430      CALL ipslerr (2,"histvar_seq", &
2431 &  'There were 10 errors in the learned sequence of variables',&
2432 &  str70,'This looks like a bug, please report it.')
2433         varseq_err(pfid) = 0
2434    ENDIF
2435  ENDIF
2436!-
2437  IF (l_dbg) THEN
2438    WRITE(*,*) &
2439 &   'histvar_seq, end of the subroutine :',TRIM(pvarname),pvid
2440  ENDIF
2441!-------------------------
2442END SUBROUTINE histvar_seq
2443!===
2444SUBROUTINE histsync (file)
2445!---------------------------------------------------------------------
2446!- This subroutine will synchronise all
2447!- (or one if defined) opened files.
2448!-
2449!- VERSION
2450!-
2451!---------------------------------------------------------------------
2452  IMPLICIT NONE
2453!-
2454! file  : optional argument for fileid
2455  INTEGER,INTENT(in),OPTIONAL :: file
2456!-
2457  INTEGER :: ifile,nfid,iret
2458!-
2459  LOGICAL :: file_exists
2460  LOGICAL :: l_dbg
2461!---------------------------------------------------------------------
2462  CALL ipsldbg (old_status=l_dbg)
2463!-
2464  IF (l_dbg) WRITE(*,*) 'Entering loop on files : ',nb_files
2465!-
2466! 1.The loop on files to synchronise
2467!-
2468  DO ifile=1,nb_files
2469!-
2470    IF (PRESENT(file)) THEN
2471      file_exists = (ifile == file)
2472    ELSE
2473      file_exists = .TRUE.
2474    ENDIF
2475!-
2476    IF (file_exists) THEN
2477      IF (l_dbg) THEN
2478        WRITE(*,*) 'Synchronising specified file number :',file
2479      ENDIF
2480      nfid = W_F(ifile)%ncfid
2481      iret = NF90_SYNC (nfid)
2482    ENDIF
2483!-
2484  ENDDO
2485!----------------------
2486END SUBROUTINE histsync
2487!===
2488SUBROUTINE histclo (fid)
2489!---------------------------------------------------------------------
2490!- This subroutine will close all (or one if defined) opened files
2491!-
2492!- VERSION
2493!-
2494!---------------------------------------------------------------------
2495  IMPLICIT NONE
2496!-
2497! fid  : optional argument for fileid
2498  INTEGER,INTENT(in),OPTIONAL :: fid
2499!-
2500  INTEGER :: ifile,nfid,nvid,iret,iv
2501  INTEGER :: start_loop,end_loop
2502  CHARACTER(LEN=70) :: str70
2503  LOGICAL :: l_dbg
2504!---------------------------------------------------------------------
2505  CALL ipsldbg (old_status=l_dbg)
2506!-
2507  IF (l_dbg) WRITE(*,*) 'Entering loop on files :',nb_files
2508!-
2509  IF (PRESENT(fid)) THEN
2510    start_loop = fid
2511    end_loop = fid
2512  ELSE
2513    start_loop = 1
2514    end_loop = nb_files
2515  ENDIF
2516!-
2517  DO ifile=start_loop,end_loop
2518    IF (l_dbg) WRITE(*,*) 'Closing specified file number :',ifile
2519    nfid = W_F(ifile)%ncfid
2520    iret = NF90_REDEF (nfid)
2521!---
2522!-- 1. Loop on the number of variables to add some final information
2523!---
2524    IF (l_dbg) WRITE(*,*) 'Entering loop on vars : ',W_F(ifile)%n_var
2525    DO iv=1,W_F(ifile)%n_var
2526      IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN
2527        IF (l_dbg) THEN
2528          WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, &
2529         &           ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1)
2530          WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, &
2531         &           ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2)
2532        ENDIF
2533        IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN
2534!-------- Put the min and max values on the file
2535          nvid = W_F(ifile)%W_V(iv)%ncvid
2536          iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
2537 &                 REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4))
2538          iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
2539 &                 REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4))
2540        ENDIF
2541      ENDIF
2542    ENDDO
2543!---
2544!-- 2. Close the file
2545!---
2546    IF (l_dbg) WRITE(*,*) 'close file :',nfid
2547    iret = NF90_CLOSE (nfid)
2548    IF (iret /= NF90_NOERR) THEN
2549      WRITE(str70,'("This file has been already closed :",I3)') ifile
2550      CALL ipslerr (2,'histclo',str70,'','')
2551    ENDIF
2552  ENDDO
2553!---------------------
2554END SUBROUTINE histclo
2555!===
2556SUBROUTINE ioconf_modname (str)
2557!---------------------------------------------------------------------
2558!- This subroutine allows to configure the name
2559!- of the model written into the file
2560!---------------------------------------------------------------------
2561  IMPLICIT NONE
2562!-
2563  CHARACTER(LEN=*),INTENT(IN) :: str
2564!---------------------------------------------------------------------
2565  IF (.NOT.lock_modname) THEN
2566    model_name = str(1:MIN(LEN_TRIM(str),80))
2567    lock_modname = .TRUE.
2568  ELSE
2569    CALL ipslerr (2,"ioconf_modname", &
2570   &  'The model name can only be changed once and only', &
2571   &  'before it is used. It is now set to :',model_name)
2572  ENDIF
2573!----------------------------
2574END SUBROUTINE ioconf_modname
2575!-
2576!===
2577!-
2578!-----------------
2579END MODULE histcom
Note: See TracBrowser for help on using the repository browser.