Context Navigation

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

Last change on this file since 962 was 962, checked in by bellier, 14 years ago
New interface for histbeg (regular 1d or 2D, irregular) New interface for histhori (regular 1d or 2D, irregular) New version of histsync New version of histclo New handling of opened files (using a stack) : the limitation is no more the total number of opened files in a run but is the number of SIMULTANEOUS opened files
Property svn:keywords set to `Id`
File size: 77.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: