Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

fbstatncio.F90 @ 11884

Last change on this file since 11884 was 3000, checked in by djlea, 13 years ago
Updated obstools. Addition of headers to programs which explain what each utility does and how to run it. All the programs now build using the naketools utility.
File size: 35.3 KB

Line
1	#define MYFILE 'fbstatncio.F90'
2	MODULE fbstatncio
3
4	USE fbacctype
5	USE nctools
6	IMPLICIT NONE
7
8	REAL, PARAMETER :: fbstncmiss = 99999.
9
10	TYPE fbstatnctype
11	INTEGER :: nlev,nbox,nadd
12	CHARACTER(len=20), POINTER, DIMENSION(:) :: area
13	CHARACTER(len=32), POINTER, DIMENSION(:) :: name
14	REAL, POINTER, DIMENSION(:) :: dep
15	REAL, POINTER, DIMENSION(:,:,:) :: val
16	INTEGER, POINTER, DIMENSION(:,:) :: cnt
17	END TYPE fbstatnctype
18
19	TYPE fbstathistnctype
20	INTEGER :: nlev,nbox,npoints
21	CHARACTER(len=20), POINTER, DIMENSION(:) :: area
22	REAL, POINTER, DIMENSION(:) :: dep,val
23	INTEGER, POINTER, DIMENSION(:,:,:) :: nhist
24	END TYPE fbstathistnctype
25
26	TYPE fbstatxynctype
27	INTEGER :: nlev,nbox,npoints
28	CHARACTER(len=20), POINTER, DIMENSION(:) :: area
29	REAL, POINTER, DIMENSION(:) :: dep,val
30	INTEGER, POINTER, DIMENSION(:,:,:,:) :: nxy
31	END TYPE fbstatxynctype
32
33	CONTAINS
34
35	SUBROUTINE fbstat_ncwrite(cdfilename,nvar,cdvar,nadd,cdadd,&
36	& nobe,cdobe,nbge,cdbge,&
37	& nbox,nboxl,lenboxname,cdboxnam,lskipbox,nlev,pdep,&
38	& knum,pbias,prms,pstd,pomean,pmmean,knuma,poamean, &
39	& knumo,poerr,povar,knumb,pberr,pbvar)
40	! Arguments
41	CHARACTER(len=*) :: cdfilename ! Netcdf filename
42	INTEGER :: nvar ! Number of variables
43	CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables
44	INTEGER :: nadd ! Number of additional data
45	CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries
46	INTEGER :: nobe ! Number of obs errors
47	CHARACTER(len=*), DIMENSION(nadd) :: cdobe ! Name of obs erors
48	INTEGER :: nbge ! Number of bg errors
49	CHARACTER(len=*), DIMENSION(nadd) :: cdbge ! Name of bg erors
50	INTEGER :: nbox ! Total number of boxes
51	INTEGER :: nboxl ! Actual number of boxes
52	INTEGER :: lenboxname ! Length of box names
53	CHARACTER(len=lenboxname), DIMENSION(nbox) :: &
54	& cdboxnam ! Name of boxes
55	LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip
56	INTEGER :: nlev ! Number of levels
57	REAL,DIMENSION(nlev) :: pdep ! Depth of levels
58	INTEGER, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data
59	& knum
60	REAL, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data
61	& pbias, prms, pstd, pomean, pmmean
62	INTEGER, DIMENSION(nlev,nboxl,nvar) :: & ! Output data
63	& knuma
64	REAL, DIMENSION(nlev,nboxl,nvar) :: & ! Output data
65	& poamean
66	INTEGER, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data
67	& knumo
68	REAL, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data
69	& poerr,povar
70	INTEGER, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data
71	& knumb
72	REAL, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data
73	& pberr,pbvar
74	! Local variables
75	INTEGER :: jadd,jvar,incvar,iv,jbox,ip
76	CHARACTER(len=50) :: cncvarbase
77	CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar
78	! netcdf stuff
79	INTEGER :: ncid,idlev,idbox,idlbox,idimdep(1),idimbox(2),idimids(2)
80	INTEGER :: idvbox,idvlev
81	INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar
82	INTEGER :: inoboxes
83	REAL, ALLOCATABLE, DIMENSION(:,:) :: ztmp
84	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: itmp
85	CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: &
86	& clboxnam ! Name of boxes
87
88	! Open netCDF files.
89
90	CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),&
91	& __LINE__,MYFILE)
92
93	! Create dimensions
94
95	inoboxes=nbox-COUNT(lskipbox)
96	ALLOCATE(ztmp(nlev,inoboxes),itmp(nlev,inoboxes),clboxnam(inoboxes))
97
98	CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE)
99
100	CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),&
101	& __LINE__,MYFILE)
102
103	CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE)
104
105	! Box variable name
106
107	idimbox(1)=idlbox
108	idimbox(2)=idbox
109	CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),&
110	& __LINE__,MYFILE)
111
112	! Depths
113
114	idimdep(1)=idlev
115	CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),&
116	& __LINE__,MYFILE)
117
118	! Setup variables names
119
120	idimids(1)=idlev
121	idimids(2)=idbox
122	incvar=(nadd6+nobe3+nbge3+2)nvar
123	ALLOCATE(cncvar(incvar),idvar(incvar))
124	iv=0
125	DO jvar=1,nvar
126	DO jadd=1,nadd
127	WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdadd(jadd))
128	iv=iv+1
129	cncvar(iv)=TRIM(cncvarbase)//'_bias'
130	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
131	& idimids,idvar(iv)),__LINE__,MYFILE)
132	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
133	& __LINE__,MYFILE)
134	iv=iv+1
135	cncvar(iv)=TRIM(cncvarbase)//'_rms'
136	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
137	& idimids,idvar(iv)),__LINE__,MYFILE)
138	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
139	& __LINE__,MYFILE)
140	iv=iv+1
141	cncvar(iv)=TRIM(cncvarbase)//'_std'
142	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
143	& idimids,idvar(iv)),__LINE__,MYFILE)
144	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
145	& __LINE__,MYFILE)
146	iv=iv+1
147	cncvar(iv)=TRIM(cncvarbase)//'_omean'
148	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
149	& idimids,idvar(iv)),__LINE__,MYFILE)
150	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
151	& __LINE__,MYFILE)
152	iv=iv+1
153	cncvar(iv)=TRIM(cncvarbase)//'_mmean'
154	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
155	& idimids,idvar(iv)),__LINE__,MYFILE)
156	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
157	& __LINE__,MYFILE)
158	iv=iv+1
159	cncvar(iv)=TRIM(cncvarbase)//'_count'
160	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,&
161	& idimids,idvar(iv)),__LINE__,MYFILE)
162	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
163	& __LINE__,MYFILE)
164	ENDDO
165	DO jadd=1,nobe
166	WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdobe(jadd))
167	iv=iv+1
168	cncvar(iv)=TRIM(cncvarbase)//'_meanerr'
169	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
170	& idimids,idvar(iv)),__LINE__,MYFILE)
171	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
172	& __LINE__,MYFILE)
173	iv=iv+1
174	cncvar(iv)=TRIM(cncvarbase)//'_meanvar'
175	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
176	& idimids,idvar(iv)),__LINE__,MYFILE)
177	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
178	& __LINE__,MYFILE)
179	iv=iv+1
180	cncvar(iv)=TRIM(cncvarbase)//'_count'
181	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,&
182	& idimids,idvar(iv)),__LINE__,MYFILE)
183	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
184	& __LINE__,MYFILE)
185	ENDDO
186	DO jadd=1,nbge
187	WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdbge(jadd))
188	iv=iv+1
189	cncvar(iv)=TRIM(cncvarbase)//'_meanerr'
190	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
191	& idimids,idvar(iv)),__LINE__,MYFILE)
192	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
193	& __LINE__,MYFILE)
194	iv=iv+1
195	cncvar(iv)=TRIM(cncvarbase)//'_meanvar'
196	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
197	& idimids,idvar(iv)),__LINE__,MYFILE)
198	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
199	& __LINE__,MYFILE)
200	iv=iv+1
201	cncvar(iv)=TRIM(cncvarbase)//'_count'
202	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,&
203	& idimids,idvar(iv)),__LINE__,MYFILE)
204	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
205	& __LINE__,MYFILE)
206	ENDDO
207	WRITE(cncvarbase,'(A)')TRIM(cdvar(jvar))
208	iv=iv+1
209	cncvar(iv)=TRIM(cncvarbase)//'_omean'
210	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,&
211	& idimids,idvar(iv)),__LINE__,MYFILE)
212	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
213	& __LINE__,MYFILE)
214	iv=iv+1
215	cncvar(iv)=TRIM(cncvarbase)//'_count'
216	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,&
217	& idimids,idvar(iv)),__LINE__,MYFILE)
218	CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),&
219	& __LINE__,MYFILE)
220	ENDDO
221	CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE)
222
223	! Write box names
224
225	ip=0
226	DO jbox=1,nbox
227	IF (.NOT.lskipbox(jbox)) THEN
228	ip=ip+1
229	clboxnam(ip)=cdboxnam(jbox)
230	ENDIF
231	ENDDO
232	CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),&
233	& __LINE__,MYFILE)
234
235	! Write levels
236
237	CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),&
238	& __LINE__,MYFILE)
239
240	! Write the output data
241
242	iv=0
243	DO jvar=1,nvar
244	DO jadd=1,nadd
245	iv=iv+1
246	ip=0
247	DO jbox=1,nbox
248	IF (.NOT.lskipbox(jbox)) THEN
249	ip=ip+1
250	ztmp(:,ip)=pbias(:,ip,jadd,jvar)
251	ENDIF
252	ENDDO
253	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
254	& __LINE__,MYFILE)
255	iv=iv+1
256	ip=0
257	DO jbox=1,nbox
258	IF (.NOT.lskipbox(jbox)) THEN
259	ip=ip+1
260	ztmp(:,ip)=prms(:,ip,jadd,jvar)
261	ENDIF
262	ENDDO
263	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
264	& __LINE__,MYFILE)
265	iv=iv+1
266	ip=0
267	DO jbox=1,nbox
268	IF (.NOT.lskipbox(jbox)) THEN
269	ip=ip+1
270	ztmp(:,ip)=pstd(:,ip,jadd,jvar)
271	ENDIF
272	ENDDO
273	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
274	& __LINE__,MYFILE)
275	iv=iv+1
276	ip=0
277	DO jbox=1,nbox
278	IF (.NOT.lskipbox(jbox)) THEN
279	ip=ip+1
280	ztmp(:,ip)=pomean(:,ip,jadd,jvar)
281	ENDIF
282	ENDDO
283	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
284	& __LINE__,MYFILE)
285	iv=iv+1
286	ip=0
287	DO jbox=1,nbox
288	IF (.NOT.lskipbox(jbox)) THEN
289	ip=ip+1
290	ztmp(:,ip)=pmmean(:,ip,jadd,jvar)
291	ENDIF
292	ENDDO
293	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
294	& __LINE__,MYFILE)
295	iv=iv+1
296	ip=0
297	DO jbox=1,nbox
298	IF (.NOT.lskipbox(jbox)) THEN
299	ip=ip+1
300	itmp(:,ip)=knum(:,ip,jadd,jvar)
301	ENDIF
302	ENDDO
303	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
304	& __LINE__,MYFILE)
305	ENDDO
306	DO jadd=1,nobe
307	iv=iv+1
308	ip=0
309	DO jbox=1,nbox
310	IF (.NOT.lskipbox(jbox)) THEN
311	ip=ip+1
312	ztmp(:,ip)=poerr(:,ip,jadd,jvar)
313	ENDIF
314	ENDDO
315	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
316	& __LINE__,MYFILE)
317	iv=iv+1
318	ip=0
319	DO jbox=1,nbox
320	IF (.NOT.lskipbox(jbox)) THEN
321	ip=ip+1
322	ztmp(:,ip)=povar(:,ip,jadd,jvar)
323	ENDIF
324	ENDDO
325	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
326	& __LINE__,MYFILE)
327	iv=iv+1
328	ip=0
329	DO jbox=1,nbox
330	IF (.NOT.lskipbox(jbox)) THEN
331	ip=ip+1
332	itmp(:,ip)=knumo(:,ip,jadd,jvar)
333	ENDIF
334	ENDDO
335	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
336	& __LINE__,MYFILE)
337	ENDDO
338	DO jadd=1,nbge
339	iv=iv+1
340	ip=0
341	DO jbox=1,nbox
342	IF (.NOT.lskipbox(jbox)) THEN
343	ip=ip+1
344	ztmp(:,ip)=pberr(:,ip,jadd,jvar)
345	ENDIF
346	ENDDO
347	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
348	& __LINE__,MYFILE)
349	iv=iv+1
350	ip=0
351	DO jbox=1,nbox
352	IF (.NOT.lskipbox(jbox)) THEN
353	ip=ip+1
354	ztmp(:,ip)=pbvar(:,ip,jadd,jvar)
355	ENDIF
356	ENDDO
357	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
358	& __LINE__,MYFILE)
359	iv=iv+1
360	ip=0
361	DO jbox=1,nbox
362	IF (.NOT.lskipbox(jbox)) THEN
363	ip=ip+1
364	itmp(:,ip)=knumb(:,ip,jadd,jvar)
365	ENDIF
366	ENDDO
367	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
368	& __LINE__,MYFILE)
369	ENDDO
370	iv=iv+1
371	ip=0
372	DO jbox=1,nbox
373	IF (.NOT.lskipbox(jbox)) THEN
374	ip=ip+1
375	ztmp(:,ip)=poamean(:,ip,jvar)
376	ENDIF
377	ENDDO
378	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),&
379	& __LINE__,MYFILE)
380	iv=iv+1
381	ip=0
382	DO jbox=1,nbox
383	IF (.NOT.lskipbox(jbox)) THEN
384	ip=ip+1
385	itmp(:,ip)=knuma(:,ip,jvar)
386	ENDIF
387	ENDDO
388	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
389	& __LINE__,MYFILE)
390	ENDDO
391
392	! Close the file
393
394	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
395
396	DEALLOCATE(cncvar,idvar,ztmp,itmp,clboxnam)
397
398	END SUBROUTINE fbstat_ncwrite
399
400	SUBROUTINE fbstat_ncwrite_hist(cdfilename,nvar,cdvar,nadd,cdadd,&
401	& nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,&
402	& zhist,zhistmin,zhiststep,ntyp)
403	! Arguments
404	CHARACTER(len=*) :: cdfilename ! Netcdf filename
405	INTEGER :: nvar ! Number of variables
406	CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables
407	INTEGER :: nadd ! Number of addiables
408	CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries
409	INTEGER :: nbox ! Number of boxes
410	INTEGER :: lenboxname ! Length of box names
411	CHARACTER(len=lenboxname), dimension(nbox) :: &
412	& cdboxnam ! Name of boxes
413	LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip
414	INTEGER :: nlev ! Number of levels
415	REAL,DIMENSION(nlev) :: pdep ! Depth of levels
416	TYPE(histtype), DIMENSION(nvar) :: zhist ! Histogram data
417	REAL, DIMENSION(nvar) :: &
418	& zhistmin,zhiststep ! Histogram info
419	integer :: ntyp ! Type to write
420	! Local variables
421	INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox
422	CHARACTER(len=50) :: cncvarbase
423	CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar
424	! netcdf stuff
425	INTEGER :: ncid,idlev,idbox,idlbox,idimhist(nvar),&
426	& idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(3)
427	INTEGER :: idvbox,idvlev
428	INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar
429	CHARACTER(len=40) :: cdhdimname
430	REAL, ALLOCATABLE, DIMENSION(:) :: zhval
431	INTEGER :: inoboxes
432	INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: itmp
433	CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: &
434	& clboxnam ! Name of boxes
435
436	! Open netCDF files.
437
438	CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),&
439	& __LINE__,MYFILE)
440
441	! Create dimensions
442
443	inoboxes=nbox-COUNT(lskipbox)
444	ALLOCATE(clboxnam(inoboxes))
445
446	CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE)
447
448	CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),&
449	& __LINE__,MYFILE)
450
451	CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE)
452
453	DO jvar=1,nvar
454	WRITE(cdhdimname,'(A,A)')'hist',TRIM(cdvar(jvar))
455	CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),&
456	& zhist(jvar)%npoints,idimhist(jvar)),&
457	& __LINE__,MYFILE)
458	ENDDO
459
460	! Box variable name
461
462	idimbox(1)=idlbox
463	idimbox(2)=idbox
464	CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),&
465	& __LINE__,MYFILE)
466
467	! Depths
468
469	idimdep(1)=idlev
470	CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),&
471	& __LINE__,MYFILE)
472
473	! Histogram values and depths
474
475	incvar=nvar+nadd*nvar
476	ALLOCATE(cncvar(incvar),idvar(incvar))
477	iv=0
478	DO jvar=1,nvar
479	iv=iv+1
480	WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val'
481	idimval(1)=idimhist(jvar)
482	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),&
483	& nf90_float,idimval,idvar(iv)),&
484	& __LINE__,MYFILE)
485	DO jadd=1,nadd
486	iv=iv+1
487	WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),&
488	& TRIM(cdadd(jadd)),'_count'
489	idimcnt(1)=idimhist(jvar)
490	idimcnt(2)=idlev
491	idimcnt(3)=idbox
492	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),&
493	& nf90_int,idimcnt,idvar(iv)),&
494	& __LINE__,MYFILE)
495	ENDDO
496	ENDDO
497	CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE)
498
499	! Write box names
500
501	ip=0
502	DO jbox=1,nbox
503	IF (.NOT.lskipbox(jbox)) THEN
504	ip=ip+1
505	clboxnam(ip)=cdboxnam(jbox)
506	ENDIF
507	ENDDO
508	CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),&
509	& __LINE__,MYFILE)
510
511	! Write levels
512
513	CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),&
514	& __LINE__,MYFILE)
515
516	iv=0
517	DO jvar=1,nvar
518	iv=iv+1
519	ALLOCATE(zhval(zhist(jvar)%npoints))
520	DO ji=1,zhist(jvar)%npoints
521	zhval(ji)=(ji-1)*zhiststep(jvar)+zhistmin(jvar)
522	ENDDO
523	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),&
524	& __LINE__,MYFILE)
525	DEALLOCATE(zhval)
526	DO jadd=1,nadd
527	iv=iv+1
528	ALLOCATE(itmp(zhist(jvar)%npoints,nlev,inoboxes))
529	ip=0
530	DO jbox=1,nbox
531	IF(.NOT.lskipbox(jbox)) THEN
532	ip=ip+1
533	itmp(:,:,ip)=zhist(jvar)%nhist(:,:,ip,jadd,ntyp)
534	ENDIF
535	ENDDO
536	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
537	& __LINE__,MYFILE)
538	DEALLOCATE(itmp)
539	ENDDO
540	ENDDO
541
542	! Close the file
543
544	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
545
546	DEALLOCATE(cncvar,idvar,clboxnam)
547
548	END SUBROUTINE fbstat_ncwrite_hist
549
550	SUBROUTINE fbstat_ncwrite_xy(cdfilename,nvar,cdvar,nadd,cdadd,&
551	& nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,&
552	& zxy,zxymin,zxystep,ntyp)
553	! Arguments
554	CHARACTER(len=*) :: cdfilename ! Netcdf filename
555	INTEGER :: nvar ! Number of variables
556	CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables
557	INTEGER :: nadd ! Number of addiables
558	CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries
559	INTEGER :: nbox ! Number of boxes
560	INTEGER :: lenboxname ! Length of box names
561	CHARACTER(len=lenboxname), dimension(nbox) :: &
562	& cdboxnam ! Name of boxes
563	LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip
564	INTEGER :: nlev ! Number of levels
565	REAL,DIMENSION(nlev) :: pdep ! Depth of levels
566	TYPE(xytype), DIMENSION(nvar) :: zxy ! xyplot data
567	REAL, DIMENSION(nvar) :: &
568	& zxymin,zxystep ! xyplot info
569	integer :: ntyp ! Type to write
570	! Local variables
571	INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox
572	CHARACTER(len=50) :: cncvarbase
573	CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar
574	! netcdf stuff
575	INTEGER :: ncid,idlev,idbox,idlbox,idimxy(nvar),&
576	& idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(4)
577	INTEGER :: idvbox,idvlev
578	INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar
579	CHARACTER(len=40) :: cdhdimname
580	REAL, ALLOCATABLE, DIMENSION(:) :: zhval
581	INTEGER :: inoboxes
582	INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:) :: itmp
583	CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: &
584	& clboxnam ! Name of boxes
585
586	! Open netCDF files.
587
588	CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),&
589	& __LINE__,MYFILE)
590
591	! Create dimensions
592
593	inoboxes=nbox-COUNT(lskipbox)
594	ALLOCATE(clboxnam(inoboxes))
595
596	CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE)
597
598	CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),&
599	& __LINE__,MYFILE)
600
601	CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE)
602
603	DO jvar=1,nvar
604	WRITE(cdhdimname,'(A,A)')'xy',TRIM(cdvar(jvar))
605	CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),&
606	& zxy(jvar)%npoints,idimxy(jvar)),&
607	& __LINE__,MYFILE)
608	ENDDO
609
610	! Box variable name
611
612	idimbox(1)=idlbox
613	idimbox(2)=idbox
614	CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),&
615	& __LINE__,MYFILE)
616
617	! Depths
618
619	idimdep(1)=idlev
620	CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),&
621	& __LINE__,MYFILE)
622
623	! Histogram values and depths
624
625	incvar=nvar+nadd*nvar
626	ALLOCATE(cncvar(incvar),idvar(incvar))
627	iv=0
628	DO jvar=1,nvar
629	iv=iv+1
630	WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val'
631	idimval(1)=idimxy(jvar)
632	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),&
633	& nf90_float,idimval,idvar(iv)),&
634	& __LINE__,MYFILE)
635	DO jadd=1,nadd
636	iv=iv+1
637	WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),&
638	& TRIM(cdadd(jadd)),'_count'
639	idimcnt(1)=idimxy(jvar)
640	idimcnt(2)=idimxy(jvar)
641	idimcnt(3)=idlev
642	idimcnt(4)=idbox
643	CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),&
644	& nf90_int,idimcnt,idvar(iv)),&
645	& __LINE__,MYFILE)
646	ENDDO
647	ENDDO
648	CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE)
649
650	! Write box names
651
652	ip=0
653	DO jbox=1,nbox
654	IF (.NOT.lskipbox(jbox)) THEN
655	ip=ip+1
656	clboxnam(ip)=cdboxnam(jbox)
657	ENDIF
658	ENDDO
659	CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),&
660	& __LINE__,MYFILE)
661
662	! Write levels
663
664	CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),&
665	& __LINE__,MYFILE)
666
667	iv=0
668	DO jvar=1,nvar
669	iv=iv+1
670	ALLOCATE(zhval(zxy(jvar)%npoints))
671	DO ji=1,zxy(jvar)%npoints
672	zhval(ji)=(ji-1)*zxystep(jvar)+zxymin(jvar)
673	ENDDO
674	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),&
675	& __LINE__,MYFILE)
676	DEALLOCATE(zhval)
677	DO jadd=1,nadd
678	iv=iv+1
679	ALLOCATE(itmp(zxy(jvar)%npoints,zxy(jvar)%npoints,nlev,inoboxes))
680	ip=0
681	DO jbox=1,nbox
682	IF(.NOT.lskipbox(jbox)) THEN
683	ip=ip+1
684	itmp(:,:,:,ip)=zxy(jvar)%nxy(:,:,:,ip,jadd,ntyp)
685	ENDIF
686	ENDDO
687	CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),&
688	& __LINE__,MYFILE)
689	DEALLOCATE(itmp)
690	ENDDO
691	ENDDO
692
693	! Close the file
694
695	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
696
697	DEALLOCATE(cncvar,idvar,clboxnam)
698
699	END SUBROUTINE fbstat_ncwrite_xy
700
701	SUBROUTINE fbstat_ncread(cdfilename,cdvar,sdata)
702	! Arguments
703	CHARACTER(len=*) :: cdfilename ! Netcdf filename
704	CHARACTER(len=*) :: cdvar ! Name of variables
705	TYPE(fbstatnctype) :: sdata ! Data to be filled
706	! Local variables
707	INTEGER :: nbox,nlev,nadd,nvar
708	INTEGER :: ncid,dimid,varid,i,icntpos
709	CHARACTER(len=128) :: cdname,tmpname
710
711	! Open the file and get the dimensions
712
713	CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE)
714	CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE)
715	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
716	& len=nbox),__LINE__,MYFILE)
717	CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE)
718	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
719	& len=nlev),__LINE__,MYFILE)
720	CALL nchdlerr(nf90_inquire(ncid,nVariables=nvar),__LINE__,MYFILE)
721
722	! Count the number of variables and find the "count" position
723
724	nadd=0
725	icntpos=0
726	DO i=1,nvar
727	CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),&
728	& __LINE__,MYFILE)
729	IF (TRIM(cdvar)//'_count'==TRIM(cdname)) THEN
730	icntpos=i
731	ELSE
732	IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN
733	tmpname=cdname(LEN_TRIM(cdvar)+2:)
734	IF (INDEX(tmpname,'_')==0) THEN
735	nadd=nadd+1
736	ENDIF
737	ENDIF
738	ENDIF
739	ENDDO
740
741	! Allocate the data structure
742
743	CALL fbstat_ncread_alloc(sdata,nlev,nbox,nadd)
744
745	! Get the box names in files
746
747	CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE)
748	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE)
749
750	! Get the depths
751
752	CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE)
753	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE)
754
755	nadd=0
756	DO i=1,nvar
757	CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),&
758	& __LINE__,MYFILE)
759	IF (i==icntpos) THEN
760	CALL nchdlerr(nf90_get_var(ncid,i,sdata%cnt),__LINE__,MYFILE)
761	ELSE
762	IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN
763	tmpname=cdname(LEN_TRIM(cdvar)+2:)
764	IF (INDEX(tmpname,'_')==0) THEN
765	nadd=nadd+1
766	sdata%name(nadd)=tmpname(1:MAX(LEN_TRIM(tmpname),32))
767	CALL nchdlerr(nf90_get_var(ncid,i,sdata%val(:,:,nadd)),&
768	& __LINE__,MYFILE)
769	ENDIF
770	ENDIF
771	ENDIF
772	ENDDO
773
774	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
775
776	END SUBROUTINE fbstat_ncread
777
778	SUBROUTINE fbstat_ncread_alloc(sdata,nlev,nbox,nadd)
779	! Arguments
780	TYPE(fbstatnctype) :: sdata ! Data to be allocated
781	INTEGER :: nlev,nbox,nadd
782	! Local variables
783
784	sdata%nlev=nlev
785	sdata%nbox=nbox
786	sdata%nadd=nadd
787	ALLOCATE( &
788	& sdata%area(nbox), &
789	& sdata%dep(nlev), &
790	& sdata%name(nadd), &
791	& sdata%val(nlev,nbox,nadd), &
792	& sdata%cnt(nlev,nbox) &
793	)
794
795	END SUBROUTINE fbstat_ncread_alloc
796
797	SUBROUTINE fbstat_ncread_dealloc(sdata)
798	! Arguments
799	TYPE(fbstatnctype) :: sdata ! Data to be deallocated
800	! Local variables
801
802	sdata%nlev=0
803	sdata%nbox=0
804	sdata%nadd=0
805	DEALLOCATE( &
806	& sdata%area, &
807	& sdata%dep, &
808	& sdata%name, &
809	& sdata%val, &
810	& sdata%cnt &
811	)
812
813	END SUBROUTINE fbstat_ncread_dealloc
814
815	SUBROUTINE fbstat_ncread_hist(cdfilename,cdvar,cdext,sdata)
816	! Arguments
817	CHARACTER(len=*) :: cdfilename ! Netcdf filename
818	CHARACTER(len=*) :: cdvar ! Name of variables
819	CHARACTER(len=*) :: cdext ! Name of extras
820	TYPE(fbstathistnctype) :: sdata ! Data to be filled
821	! Local variables
822	INTEGER :: nbox,nlev,npoints
823	INTEGER :: ncid,dimid,varid
824
825	! Open the file and get the dimensions
826
827	CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE)
828	CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE)
829	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
830	& len=nbox),__LINE__,MYFILE)
831	CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE)
832	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
833	& len=nlev),__LINE__,MYFILE)
834	CALL nchdlerr(nf90_inq_dimid(ncid,'hist'//TRIM(cdvar),dimid),&
835	& __LINE__,MYFILE)
836	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
837	& len=npoints),__LINE__,MYFILE)
838
839	! Allocate the data structure
840
841	CALL fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox)
842
843	! Get the box names in files
844
845	CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE)
846	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE)
847
848	! Get the depths
849
850	CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE)
851	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE)
852
853	! Get values
854
855	CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),&
856	& __LINE__,MYFILE)
857	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE)
858
859	! Get histograms
860
861	CALL nchdlerr(nf90_inq_varid(ncid,&
862	& TRIM(cdvar)//TRIM(cdext)//'_count',varid),&
863	& __LINE__,MYFILE)
864	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nhist),__LINE__,MYFILE)
865
866	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
867
868	END SUBROUTINE fbstat_ncread_hist
869
870	SUBROUTINE fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox)
871	! Arguments
872	TYPE(fbstathistnctype) :: sdata ! Data to be allocated
873	INTEGER :: npoints,nlev,nbox
874	! Local variables
875
876	sdata%nlev=nlev
877	sdata%nbox=nbox
878	sdata%npoints=npoints
879	ALLOCATE( &
880	& sdata%area(nbox), &
881	& sdata%dep(nlev), &
882	& sdata%val(npoints), &
883	& sdata%nhist(npoints,nlev,nbox) &
884	& )
885
886	END SUBROUTINE fbstat_ncread_hist_alloc
887
888	SUBROUTINE fbstat_ncread_hist_dealloc(sdata)
889	! Arguments
890	TYPE(fbstathistnctype) :: sdata ! Data to be deallocated
891	! Local variables
892
893	sdata%nlev=0
894	sdata%nbox=0
895	sdata%npoints=0
896	DEALLOCATE( &
897	& sdata%area, &
898	& sdata%dep, &
899	& sdata%val, &
900	& sdata%nhist &
901	& )
902
903	END SUBROUTINE fbstat_ncread_hist_dealloc
904
905	SUBROUTINE fbstat_ncread_xy(cdfilename,cdvar,cdext,sdata)
906	! Arguments
907	CHARACTER(len=*) :: cdfilename ! Netcdf filename
908	CHARACTER(len=*) :: cdvar ! Name of variables
909	CHARACTER(len=*) :: cdext ! Name of extras
910	TYPE(fbstatxynctype) :: sdata ! Data to be filled
911	! Local variables
912	INTEGER :: nbox,nlev,npoints
913	INTEGER :: ncid,dimid,varid
914
915	! Open the file and get the dimensions
916
917	CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE)
918	CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE)
919	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
920	& len=nbox),__LINE__,MYFILE)
921	CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE)
922	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
923	& len=nlev),__LINE__,MYFILE)
924	CALL nchdlerr(nf90_inq_dimid(ncid,'xy'//TRIM(cdvar),dimid),&
925	& __LINE__,MYFILE)
926	CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,&
927	& len=npoints),__LINE__,MYFILE)
928
929	! Allocate the data structure
930
931	CALL fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox)
932
933	! Get the box names in files
934
935	CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE)
936	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE)
937
938	! Get the depths
939
940	CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE)
941	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE)
942
943	! Get values
944
945	CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),&
946	& __LINE__,MYFILE)
947	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE)
948
949	! Get xyograms
950
951	CALL nchdlerr(nf90_inq_varid(ncid,&
952	& TRIM(cdvar)//TRIM(cdext)//'_count',varid),&
953	& __LINE__,MYFILE)
954	CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nxy),__LINE__,MYFILE)
955
956	CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE)
957
958	END SUBROUTINE fbstat_ncread_xy
959
960	SUBROUTINE fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox)
961	! Arguments
962	TYPE(fbstatxynctype) :: sdata ! Data to be allocated
963	INTEGER :: npoints,nlev,nbox
964	! Local variables
965
966	sdata%nlev=nlev
967	sdata%nbox=nbox
968	sdata%npoints=npoints
969	ALLOCATE( &
970	& sdata%area(nbox), &
971	& sdata%dep(nlev), &
972	& sdata%val(npoints), &
973	& sdata%nxy(npoints,npoints,nlev,nbox) &
974	& )
975
976	END SUBROUTINE fbstat_ncread_xy_alloc
977
978	SUBROUTINE fbstat_ncread_xy_dealloc(sdata)
979	! Arguments
980	TYPE(fbstatxynctype) :: sdata ! Data to be deallocated
981	! Local variables
982
983	sdata%nlev=0
984	sdata%nbox=0
985	sdata%npoints=0
986	DEALLOCATE( &
987	& sdata%area, &
988	& sdata%dep, &
989	& sdata%val, &
990	& sdata%nxy &
991	& )
992
993	END SUBROUTINE fbstat_ncread_xy_dealloc
994
995	END MODULE fbstatncio

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/UKMO/dev_r5518_GO6_starthour_obsoper/NEMOGCM/TOOLS/OBSTOOLS/src/fbstatncio.F90 @ 11884

Download in other formats: