Context Navigation

histcom.f90

Last change on this file was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 81.1 KB

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

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

Download in other formats:

Original Format