#define MYFILE 'fbstatncio.F90' MODULE fbstatncio USE fbacctype USE nctools IMPLICIT NONE REAL, PARAMETER :: fbstncmiss = 99999. TYPE fbstatnctype INTEGER :: nlev,nbox,nadd CHARACTER(len=20), POINTER, DIMENSION(:) :: area CHARACTER(len=32), POINTER, DIMENSION(:) :: name REAL, POINTER, DIMENSION(:) :: dep REAL, POINTER, DIMENSION(:,:,:) :: val INTEGER, POINTER, DIMENSION(:,:) :: cnt END TYPE fbstatnctype TYPE fbstathistnctype INTEGER :: nlev,nbox,npoints CHARACTER(len=20), POINTER, DIMENSION(:) :: area REAL, POINTER, DIMENSION(:) :: dep,val INTEGER, POINTER, DIMENSION(:,:,:) :: nhist END TYPE fbstathistnctype TYPE fbstatxynctype INTEGER :: nlev,nbox,npoints CHARACTER(len=20), POINTER, DIMENSION(:) :: area REAL, POINTER, DIMENSION(:) :: dep,val INTEGER, POINTER, DIMENSION(:,:,:,:) :: nxy END TYPE fbstatxynctype CONTAINS SUBROUTINE fbstat_ncwrite(cdfilename,nvar,cdvar,nadd,cdadd,& & nobe,cdobe,nbge,cdbge,& & nbox,nboxl,lenboxname,cdboxnam,lskipbox,nlev,pdep,& & knum,pbias,prms,pstd,pomean,pmmean,knuma,poamean, & & knumo,poerr,povar,knumb,pberr,pbvar) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename INTEGER :: nvar ! Number of variables CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables INTEGER :: nadd ! Number of additional data CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries INTEGER :: nobe ! Number of obs errors CHARACTER(len=*), DIMENSION(nadd) :: cdobe ! Name of obs erors INTEGER :: nbge ! Number of bg errors CHARACTER(len=*), DIMENSION(nadd) :: cdbge ! Name of bg erors INTEGER :: nbox ! Total number of boxes INTEGER :: nboxl ! Actual number of boxes INTEGER :: lenboxname ! Length of box names CHARACTER(len=lenboxname), DIMENSION(nbox) :: & & cdboxnam ! Name of boxes LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip INTEGER :: nlev ! Number of levels REAL,DIMENSION(nlev) :: pdep ! Depth of levels INTEGER, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data & knum REAL, DIMENSION(nlev,nboxl,nadd,nvar) :: & ! Output data & pbias, prms, pstd, pomean, pmmean INTEGER, DIMENSION(nlev,nboxl,nvar) :: & ! Output data & knuma REAL, DIMENSION(nlev,nboxl,nvar) :: & ! Output data & poamean INTEGER, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data & knumo REAL, DIMENSION(nlev,nboxl,nobe,nvar) :: & ! Output data & poerr,povar INTEGER, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data & knumb REAL, DIMENSION(nlev,nboxl,nbge,nvar) :: & ! Output data & pberr,pbvar ! Local variables INTEGER :: jadd,jvar,incvar,iv,jbox,ip CHARACTER(len=50) :: cncvarbase CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar ! netcdf stuff INTEGER :: ncid,idlev,idbox,idlbox,idimdep(1),idimbox(2),idimids(2) INTEGER :: idvbox,idvlev INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar INTEGER :: inoboxes REAL, ALLOCATABLE, DIMENSION(:,:) :: ztmp INTEGER, ALLOCATABLE, DIMENSION(:,:) :: itmp CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & & clboxnam ! Name of boxes ! Open netCDF files. CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& & __LINE__,MYFILE) ! Create dimensions inoboxes=nbox-COUNT(lskipbox) ALLOCATE(ztmp(nlev,inoboxes),itmp(nlev,inoboxes),clboxnam(inoboxes)) CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& & __LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) ! Box variable name idimbox(1)=idlbox idimbox(2)=idbox CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& & __LINE__,MYFILE) ! Depths idimdep(1)=idlev CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& & __LINE__,MYFILE) ! Setup variables names idimids(1)=idlev idimids(2)=idbox incvar=(nadd*6+nobe*3+nbge*3+2)*nvar ALLOCATE(cncvar(incvar),idvar(incvar)) iv=0 DO jvar=1,nvar DO jadd=1,nadd WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdadd(jadd)) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_bias' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_rms' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_std' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_omean' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_mmean' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_count' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) ENDDO DO jadd=1,nobe WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdobe(jadd)) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_meanerr' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_meanvar' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_count' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) ENDDO DO jadd=1,nbge WRITE(cncvarbase,'(3A)')TRIM(cdvar(jvar)),'_',TRIM(cdbge(jadd)) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_meanerr' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_meanvar' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_count' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) ENDDO WRITE(cncvarbase,'(A)')TRIM(cdvar(jvar)) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_omean' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_float,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) iv=iv+1 cncvar(iv)=TRIM(cncvarbase)//'_count' CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),nf90_int,& & idimids,idvar(iv)),__LINE__,MYFILE) CALL nchdlerr(nf90_put_att(ncid,idvar(iv),"missing_value",fbstncmiss),& & __LINE__,MYFILE) ENDDO CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) ! Write box names ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 clboxnam(ip)=cdboxnam(jbox) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& & __LINE__,MYFILE) ! Write levels CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& & __LINE__,MYFILE) ! Write the output data iv=0 DO jvar=1,nvar DO jadd=1,nadd iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pbias(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=prms(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pstd(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pomean(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pmmean(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,ip)=knum(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) ENDDO DO jadd=1,nobe iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=poerr(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=povar(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,ip)=knumo(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) ENDDO DO jadd=1,nbge iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pberr(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=pbvar(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,ip)=knumb(:,ip,jadd,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) ENDDO iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 ztmp(:,ip)=poamean(:,ip,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),ztmp),& & __LINE__,MYFILE) iv=iv+1 ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,ip)=knuma(:,ip,jvar) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) ENDDO ! Close the file CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) DEALLOCATE(cncvar,idvar,ztmp,itmp,clboxnam) END SUBROUTINE fbstat_ncwrite SUBROUTINE fbstat_ncwrite_hist(cdfilename,nvar,cdvar,nadd,cdadd,& & nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,& & zhist,zhistmin,zhiststep,ntyp) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename INTEGER :: nvar ! Number of variables CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables INTEGER :: nadd ! Number of addiables CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries INTEGER :: nbox ! Number of boxes INTEGER :: lenboxname ! Length of box names CHARACTER(len=lenboxname), dimension(nbox) :: & & cdboxnam ! Name of boxes LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip INTEGER :: nlev ! Number of levels REAL,DIMENSION(nlev) :: pdep ! Depth of levels TYPE(histtype), DIMENSION(nvar) :: zhist ! Histogram data REAL, DIMENSION(nvar) :: & & zhistmin,zhiststep ! Histogram info integer :: ntyp ! Type to write ! Local variables INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox CHARACTER(len=50) :: cncvarbase CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar ! netcdf stuff INTEGER :: ncid,idlev,idbox,idlbox,idimhist(nvar),& & idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(3) INTEGER :: idvbox,idvlev INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar CHARACTER(len=40) :: cdhdimname REAL, ALLOCATABLE, DIMENSION(:) :: zhval INTEGER :: inoboxes INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: itmp CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & & clboxnam ! Name of boxes ! Open netCDF files. CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& & __LINE__,MYFILE) ! Create dimensions inoboxes=nbox-COUNT(lskipbox) ALLOCATE(clboxnam(inoboxes)) CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& & __LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) DO jvar=1,nvar WRITE(cdhdimname,'(A,A)')'hist',TRIM(cdvar(jvar)) CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),& & zhist(jvar)%npoints,idimhist(jvar)),& & __LINE__,MYFILE) ENDDO ! Box variable name idimbox(1)=idlbox idimbox(2)=idbox CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& & __LINE__,MYFILE) ! Depths idimdep(1)=idlev CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& & __LINE__,MYFILE) ! Histogram values and depths incvar=nvar+nadd*nvar ALLOCATE(cncvar(incvar),idvar(incvar)) iv=0 DO jvar=1,nvar iv=iv+1 WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val' idimval(1)=idimhist(jvar) CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& & nf90_float,idimval,idvar(iv)),& & __LINE__,MYFILE) DO jadd=1,nadd iv=iv+1 WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),& & TRIM(cdadd(jadd)),'_count' idimcnt(1)=idimhist(jvar) idimcnt(2)=idlev idimcnt(3)=idbox CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& & nf90_int,idimcnt,idvar(iv)),& & __LINE__,MYFILE) ENDDO ENDDO CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) ! Write box names ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 clboxnam(ip)=cdboxnam(jbox) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& & __LINE__,MYFILE) ! Write levels CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& & __LINE__,MYFILE) iv=0 DO jvar=1,nvar iv=iv+1 ALLOCATE(zhval(zhist(jvar)%npoints)) DO ji=1,zhist(jvar)%npoints zhval(ji)=(ji-1)*zhiststep(jvar)+zhistmin(jvar) ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),& & __LINE__,MYFILE) DEALLOCATE(zhval) DO jadd=1,nadd iv=iv+1 ALLOCATE(itmp(zhist(jvar)%npoints,nlev,inoboxes)) ip=0 DO jbox=1,nbox IF(.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,:,ip)=zhist(jvar)%nhist(:,:,ip,jadd,ntyp) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) DEALLOCATE(itmp) ENDDO ENDDO ! Close the file CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) DEALLOCATE(cncvar,idvar,clboxnam) END SUBROUTINE fbstat_ncwrite_hist SUBROUTINE fbstat_ncwrite_xy(cdfilename,nvar,cdvar,nadd,cdadd,& & nbox,lenboxname,cdboxnam,lskipbox,nlev,pdep,& & zxy,zxymin,zxystep,ntyp) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename INTEGER :: nvar ! Number of variables CHARACTER(len=*), DIMENSION(nvar) :: cdvar ! Name of variables INTEGER :: nadd ! Number of addiables CHARACTER(len=*), DIMENSION(nadd) :: cdadd ! Name of entries INTEGER :: nbox ! Number of boxes INTEGER :: lenboxname ! Length of box names CHARACTER(len=lenboxname), dimension(nbox) :: & & cdboxnam ! Name of boxes LOGICAL, DIMENSION(nbox) :: lskipbox ! Boxes to skip INTEGER :: nlev ! Number of levels REAL,DIMENSION(nlev) :: pdep ! Depth of levels TYPE(xytype), DIMENSION(nvar) :: zxy ! xyplot data REAL, DIMENSION(nvar) :: & & zxymin,zxystep ! xyplot info integer :: ntyp ! Type to write ! Local variables INTEGER :: jadd,jvar,incvar,ji,iv,ip,jbox CHARACTER(len=50) :: cncvarbase CHARACTER(len=60), ALLOCATABLE, DIMENSION(:) :: cncvar ! netcdf stuff INTEGER :: ncid,idlev,idbox,idlbox,idimxy(nvar),& & idimdep(1),idimbox(2),idimids(2),idimval(1),idimcnt(4) INTEGER :: idvbox,idvlev INTEGER, ALLOCATABLE, DIMENSION(:) :: idvar CHARACTER(len=40) :: cdhdimname REAL, ALLOCATABLE, DIMENSION(:) :: zhval INTEGER :: inoboxes INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:) :: itmp CHARACTER(len=lenboxname), DIMENSION(:), ALLOCATABLE :: & & clboxnam ! Name of boxes ! Open netCDF files. CALL nchdlerr(nf90_create(TRIM(cdfilename),nf90_clobber,ncid),& & __LINE__,MYFILE) ! Create dimensions inoboxes=nbox-COUNT(lskipbox) ALLOCATE(clboxnam(inoboxes)) CALL nchdlerr(nf90_def_dim(ncid,"depth",nlev,idlev),__LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"box",inoboxes,idbox),& & __LINE__,MYFILE) CALL nchdlerr(nf90_def_dim(ncid,"len",lenboxname,idlbox),__LINE__,MYFILE) DO jvar=1,nvar WRITE(cdhdimname,'(A,A)')'xy',TRIM(cdvar(jvar)) CALL nchdlerr(nf90_def_dim(ncid,TRIM(cdhdimname),& & zxy(jvar)%npoints,idimxy(jvar)),& & __LINE__,MYFILE) ENDDO ! Box variable name idimbox(1)=idlbox idimbox(2)=idbox CALL nchdlerr(nf90_def_var(ncid,'box',nf90_char,idimbox,idvbox),& & __LINE__,MYFILE) ! Depths idimdep(1)=idlev CALL nchdlerr(nf90_def_var(ncid,'depth',nf90_float,idimdep,idvlev),& & __LINE__,MYFILE) ! Histogram values and depths incvar=nvar+nadd*nvar ALLOCATE(cncvar(incvar),idvar(incvar)) iv=0 DO jvar=1,nvar iv=iv+1 WRITE(cncvar(iv),'(A,A)')TRIM(cdvar(jvar)),'_val' idimval(1)=idimxy(jvar) CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& & nf90_float,idimval,idvar(iv)),& & __LINE__,MYFILE) DO jadd=1,nadd iv=iv+1 WRITE(cncvar(iv),'(A,A,A)')TRIM(cdvar(jvar)),& & TRIM(cdadd(jadd)),'_count' idimcnt(1)=idimxy(jvar) idimcnt(2)=idimxy(jvar) idimcnt(3)=idlev idimcnt(4)=idbox CALL nchdlerr(nf90_def_var(ncid,TRIM(cncvar(iv)),& & nf90_int,idimcnt,idvar(iv)),& & __LINE__,MYFILE) ENDDO ENDDO CALL nchdlerr(nf90_enddef(ncid),__LINE__,MYFILE) ! Write box names ip=0 DO jbox=1,nbox IF (.NOT.lskipbox(jbox)) THEN ip=ip+1 clboxnam(ip)=cdboxnam(jbox) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvbox,clboxnam),& & __LINE__,MYFILE) ! Write levels CALL nchdlerr(nf90_put_var(ncid,idvlev,pdep),& & __LINE__,MYFILE) iv=0 DO jvar=1,nvar iv=iv+1 ALLOCATE(zhval(zxy(jvar)%npoints)) DO ji=1,zxy(jvar)%npoints zhval(ji)=(ji-1)*zxystep(jvar)+zxymin(jvar) ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),zhval),& & __LINE__,MYFILE) DEALLOCATE(zhval) DO jadd=1,nadd iv=iv+1 ALLOCATE(itmp(zxy(jvar)%npoints,zxy(jvar)%npoints,nlev,inoboxes)) ip=0 DO jbox=1,nbox IF(.NOT.lskipbox(jbox)) THEN ip=ip+1 itmp(:,:,:,ip)=zxy(jvar)%nxy(:,:,:,ip,jadd,ntyp) ENDIF ENDDO CALL nchdlerr(nf90_put_var(ncid,idvar(iv),itmp),& & __LINE__,MYFILE) DEALLOCATE(itmp) ENDDO ENDDO ! Close the file CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) DEALLOCATE(cncvar,idvar,clboxnam) END SUBROUTINE fbstat_ncwrite_xy SUBROUTINE fbstat_ncread(cdfilename,cdvar,sdata) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename CHARACTER(len=*) :: cdvar ! Name of variables TYPE(fbstatnctype) :: sdata ! Data to be filled ! Local variables INTEGER :: nbox,nlev,nadd,nvar INTEGER :: ncid,dimid,varid,i,icntpos CHARACTER(len=128) :: cdname,tmpname ! Open the file and get the dimensions CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nbox),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nlev),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire(ncid,nVariables=nvar),__LINE__,MYFILE) ! Count the number of variables and find the "count" position nadd=0 icntpos=0 DO i=1,nvar CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),& & __LINE__,MYFILE) IF (TRIM(cdvar)//'_count'==TRIM(cdname)) THEN icntpos=i ELSE IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN tmpname=cdname(LEN_TRIM(cdvar)+2:) IF (INDEX(tmpname,'_')==0) THEN nadd=nadd+1 ENDIF ENDIF ENDIF ENDDO ! Allocate the data structure CALL fbstat_ncread_alloc(sdata,nlev,nbox,nadd) ! Get the box names in files CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) ! Get the depths CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) nadd=0 DO i=1,nvar CALL nchdlerr(nf90_inquire_variable(ncid,i,name=cdname),& & __LINE__,MYFILE) IF (i==icntpos) THEN CALL nchdlerr(nf90_get_var(ncid,i,sdata%cnt),__LINE__,MYFILE) ELSE IF (TRIM(cdvar)==cdname(1:LEN_TRIM(cdvar))) THEN tmpname=cdname(LEN_TRIM(cdvar)+2:) IF (INDEX(tmpname,'_')==0) THEN nadd=nadd+1 sdata%name(nadd)=tmpname(1:MAX(LEN_TRIM(tmpname),32)) CALL nchdlerr(nf90_get_var(ncid,i,sdata%val(:,:,nadd)),& & __LINE__,MYFILE) ENDIF ENDIF ENDIF ENDDO CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) END SUBROUTINE fbstat_ncread SUBROUTINE fbstat_ncread_alloc(sdata,nlev,nbox,nadd) ! Arguments TYPE(fbstatnctype) :: sdata ! Data to be allocated INTEGER :: nlev,nbox,nadd ! Local variables sdata%nlev=nlev sdata%nbox=nbox sdata%nadd=nadd ALLOCATE( & & sdata%area(nbox), & & sdata%dep(nlev), & & sdata%name(nadd), & & sdata%val(nlev,nbox,nadd), & & sdata%cnt(nlev,nbox) & ) END SUBROUTINE fbstat_ncread_alloc SUBROUTINE fbstat_ncread_dealloc(sdata) ! Arguments TYPE(fbstatnctype) :: sdata ! Data to be deallocated ! Local variables sdata%nlev=0 sdata%nbox=0 sdata%nadd=0 DEALLOCATE( & & sdata%area, & & sdata%dep, & & sdata%name, & & sdata%val, & & sdata%cnt & ) END SUBROUTINE fbstat_ncread_dealloc SUBROUTINE fbstat_ncread_hist(cdfilename,cdvar,cdext,sdata) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename CHARACTER(len=*) :: cdvar ! Name of variables CHARACTER(len=*) :: cdext ! Name of extras TYPE(fbstathistnctype) :: sdata ! Data to be filled ! Local variables INTEGER :: nbox,nlev,npoints INTEGER :: ncid,dimid,varid ! Open the file and get the dimensions CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nbox),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nlev),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'hist'//TRIM(cdvar),dimid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=npoints),__LINE__,MYFILE) ! Allocate the data structure CALL fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox) ! Get the box names in files CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) ! Get the depths CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) ! Get values CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE) ! Get histograms CALL nchdlerr(nf90_inq_varid(ncid,& & TRIM(cdvar)//TRIM(cdext)//'_count',varid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nhist),__LINE__,MYFILE) CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) END SUBROUTINE fbstat_ncread_hist SUBROUTINE fbstat_ncread_hist_alloc(sdata,npoints,nlev,nbox) ! Arguments TYPE(fbstathistnctype) :: sdata ! Data to be allocated INTEGER :: npoints,nlev,nbox ! Local variables sdata%nlev=nlev sdata%nbox=nbox sdata%npoints=npoints ALLOCATE( & & sdata%area(nbox), & & sdata%dep(nlev), & & sdata%val(npoints), & & sdata%nhist(npoints,nlev,nbox) & & ) END SUBROUTINE fbstat_ncread_hist_alloc SUBROUTINE fbstat_ncread_hist_dealloc(sdata) ! Arguments TYPE(fbstathistnctype) :: sdata ! Data to be deallocated ! Local variables sdata%nlev=0 sdata%nbox=0 sdata%npoints=0 DEALLOCATE( & & sdata%area, & & sdata%dep, & & sdata%val, & & sdata%nhist & & ) END SUBROUTINE fbstat_ncread_hist_dealloc SUBROUTINE fbstat_ncread_xy(cdfilename,cdvar,cdext,sdata) ! Arguments CHARACTER(len=*) :: cdfilename ! Netcdf filename CHARACTER(len=*) :: cdvar ! Name of variables CHARACTER(len=*) :: cdext ! Name of extras TYPE(fbstatxynctype) :: sdata ! Data to be filled ! Local variables INTEGER :: nbox,nlev,npoints INTEGER :: ncid,dimid,varid ! Open the file and get the dimensions CALL nchdlerr(nf90_open(cdfilename,nf90_nowrite,ncid),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'box',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nbox),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'depth',dimid),__LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=nlev),__LINE__,MYFILE) CALL nchdlerr(nf90_inq_dimid(ncid,'xy'//TRIM(cdvar),dimid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_inquire_dimension(ncid,dimid,& & len=npoints),__LINE__,MYFILE) ! Allocate the data structure CALL fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox) ! Get the box names in files CALL nchdlerr(nf90_inq_varid(ncid,'box',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%area),__LINE__,MYFILE) ! Get the depths CALL nchdlerr(nf90_inq_varid(ncid,'depth',varid),__LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%dep),__LINE__,MYFILE) ! Get values CALL nchdlerr(nf90_inq_varid(ncid,TRIM(cdvar)//'_val',varid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%val),__LINE__,MYFILE) ! Get xyograms CALL nchdlerr(nf90_inq_varid(ncid,& & TRIM(cdvar)//TRIM(cdext)//'_count',varid),& & __LINE__,MYFILE) CALL nchdlerr(nf90_get_var(ncid,varid,sdata%nxy),__LINE__,MYFILE) CALL nchdlerr(nf90_close(ncid),__LINE__,MYFILE) END SUBROUTINE fbstat_ncread_xy SUBROUTINE fbstat_ncread_xy_alloc(sdata,npoints,nlev,nbox) ! Arguments TYPE(fbstatxynctype) :: sdata ! Data to be allocated INTEGER :: npoints,nlev,nbox ! Local variables sdata%nlev=nlev sdata%nbox=nbox sdata%npoints=npoints ALLOCATE( & & sdata%area(nbox), & & sdata%dep(nlev), & & sdata%val(npoints), & & sdata%nxy(npoints,npoints,nlev,nbox) & & ) END SUBROUTINE fbstat_ncread_xy_alloc SUBROUTINE fbstat_ncread_xy_dealloc(sdata) ! Arguments TYPE(fbstatxynctype) :: sdata ! Data to be deallocated ! Local variables sdata%nlev=0 sdata%nbox=0 sdata%npoints=0 DEALLOCATE( & & sdata%area, & & sdata%dep, & & sdata%val, & & sdata%nxy & & ) END SUBROUTINE fbstat_ncread_xy_dealloc END MODULE fbstatncio