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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
fbstatncio.F90 in branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/TOOLS/OBSTOOLS/src – NEMO

source: branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/TOOLS/OBSTOOLS/src/fbstatncio.F90 @ 5967

Last change on this file since 5967 was 5967, checked in by timgraham, 8 years ago

Reset keywords before merging with head of trunk
  • Property svn:keywords set to Id
File size: 35.3 KB
Line 
1#define MYFILE 'fbstatncio.F90'
2MODULE 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
33CONTAINS
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=(nadd*6+nobe*3+nbge*3+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
995END MODULE fbstatncio
Note: See TracBrowser for help on using the repository browser.