!
SUBROUTINE splitncdf(filenames,nfile,stag, xdimname, ydimname, & 1
nproc_x,nproc_y,outdirname, debug,istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Split files in netCDF format into patches. The patched files will
! contain the same data as original file but in evenly divided
! subdomain specified by the user.
!
!-----------------------------------------------------------------------
!
! Author: Yunheng Wang (11/07/2006)
!
! MODIFICATIONS:
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Variable declaration
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nfile
CHARACTER(LEN=*), INTENT(IN) :: filenames(nfile)
CHARACTER(LEN=*), INTENT(IN) :: outdirname
CHARACTER(LEN=*), INTENT(IN) :: xdimname, ydimname
LOGICAL, INTENT(IN) :: stag ! Whether the data contains
! both staggered and unstaggered dimensions. If it is true, then xdimname/ydimname is
! the name of staggered dimension. The unstaggered dimensions are assumed to be
! xdimname/ydimname by tripping the trail '_stag'. Such as xdimname = 'x_stag' then
! the unstaggered dimension name is 'x'.
INTEGER, INTENT(IN) :: nproc_x, nproc_y
INTEGER, INTENT(IN) :: debug
INTEGER, INTENT(OUT) :: istatus
!-----------------------------------------------------------------------
!
! Dimensions and work arrays
!
!-----------------------------------------------------------------------
INTEGER :: nxlg, nylg
INTEGER :: nx, ny
INTEGER, ALLOCATABLE :: variin(:), variout(:)
INTEGER, ALLOCATABLE :: varain(:), varaout(:)
INTEGER :: finid
CHARACTER(LEN=256), ALLOCATABLE :: outfilenames(:,:)
INTEGER, ALLOCATABLE :: foutids(:,:)
INTEGER, ALLOCATABLE :: dimouts0(:,:,:)
!
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER, PARAMETER :: MAX_RANK = 5 ! Assume the max rank is 5
INTEGER :: nf, dindx
INTEGER :: iout, iin
CHARACTER(LEN=256) :: xsdimname, ysdimname
INTEGER :: nxid, nyid, nxsid, nysid
INTEGER :: iloc, jloc
INTEGER :: ndims, unlimdimid, ngatts, nvars
INTEGER :: dimid, odimid, attnum, varid, ovarid
INTEGER :: dimlen
CHARACTER(LEN=256) :: dimname, attname, varname
INTEGER :: vartype, varndims, varnatts
INTEGER :: vardim, varainsize, varaoutsize, varaallsize, varballsize
INTEGER :: vardimids(MAX_RANK), startidx(MAX_RANK), countidx(MAX_RANK), outidx(MAX_RANK)
INTEGER :: sin1d, sin2d, sin3d, sin4d
INTEGER :: sout1d, sout2d, sout3d, sout4d
INTEGER :: nd1, nd2, nd3, nd4, nd5 ! Assume the max rank is 5
!
!-----------------------------------------------------------------------
!
! Including files
!
!-----------------------------------------------------------------------
INCLUDE 'netcdf.inc'
INTEGER :: dimina(NF_MAX_DIMS) ! Dimension size in original file
INTEGER :: dimouta(NF_MAX_DIMS) ! Dimension size in split files
CHARACTER(LEN=256) :: diminnames(NF_MAX_DIMS)
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code below
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
nxsid = 0
nysid = 0
xsdimname = ' '
ysdimname = ' '
IF (stag) THEN
xsdimname = xdimname(1:INDEX(xdimname,'_stag')-1)
ysdimname = ydimname(1:INDEX(ydimname,'_stag')-1)
END IF
!-----------------------------------------------------------------------
!
! Check dimensions first
!
!-----------------------------------------------------------------------
istatus = nf_open(filenames(1),NF_NOWRITE,finid)
IF (istatus /= NF_NOERR) CALL handle_err
(istatus)
istatus = nf_inq_dimid(finid,xdimname,nxid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nxid,nxlg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimid(finid,ydimname,nyid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nyid,nylg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
WRITE(6,'(1x,2(a,I5))') 'Dimensions in file to be split are: nx = ',nxlg,', ny = ',nylg
IF (MOD((nxlg-3),nproc_x) /= 0 ) THEN
WRITE(6,'(1x,a)') 'ERROR: Wrong dimension size'
WRITE(6,'(1x,2(a,I5),a)') ' Dimension size in X direction (',nxlg,&
') is not divisible by nproc_x (',nproc_x,').'
istatus = -1
RETURN
END IF
IF (MOD((nylg-3),nproc_y) /= 0 ) THEN
WRITE(6,'(1x,a)') 'ERROR: Wrong dimension size'
WRITE(6,'(1x,2(a,I5),a)') ' Dimension size in Y direction (',nylg,&
') is not divisible by nproc_y (',nproc_y,').'
istatus = -2
RETURN
END IF
istatus = nf_close(finid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
!-----------------------------------------------------------------------
!
! Loop over filenames
!
!-----------------------------------------------------------------------
startidx(:) = 1
ALLOCATE(outfilenames(nproc_x,nproc_y), STAT = istatus)
ALLOCATE(foutids(nproc_x,nproc_y), STAT = istatus)
ALLOCATE(dimouts0(0:NF_MAX_DIMS,nproc_x,nproc_y), STAT = istatus)
DO nf = 1,nfile
IF (debug > 0) WRITE(6,'(1x,2a)') 'Opening file - ',filenames(nf)
istatus = nf_open(filenames(nf),NF_NOWRITE,finid) ! Open file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
dindx = INDEX(filenames(nf),'/',.TRUE.) + 1
DO jloc = 1,nproc_y ! Create patches
DO iloc = 1,nproc_x
WRITE(outfilenames(iloc,jloc),'(3a,2I2.2)') &
TRIM(outdirname),TRIM(filenames(nf)(dindx:)),'_',iloc,jloc
IF (debug > 0) WRITE(6,'(1x,2a)') 'Creating file - ',TRIM(outfilenames(iloc,jloc))
istatus = nf_create(outfilenames(iloc,jloc),NF_CLOBBER,foutids(iloc,jloc))
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
!
! Set dimensions
!
istatus = nf_inq_dimid(finid,xdimname,nxid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nxid,nxlg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
nx = (nxlg-3)/nproc_x + 3
istatus = nf_inq_dimid(finid,ydimname,nyid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nyid,nylg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ny = (nylg-3)/nproc_y + 3
IF (stag) THEN
istatus = nf_inq_dimid(finid,xsdimname,nxsid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nxsid,dimlen)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (dimlen /= nxlg -1) THEN
WRITE(6,'(1x,3a,I4,a,I4,a)') 'ERROR: Wrong size with dimension - ', &
TRIM(xsdimname),'(',dimlen,'), expected: ',nxlg-1,'.'
istatus = -5
RETURN
END IF
istatus = nf_inq_dimid(finid,ysdimname,nysid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimlen(finid,nysid,dimlen)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (dimlen /= nylg -1) THEN
WRITE(6,'(1x,3a,I4,a,I4,a)') 'ERROR: Wrong size with dimension - ', &
TRIM(ysdimname),'(',dimlen,'), expected: ',nylg-1,'.'
istatus = -5
RETURN
END IF
END IF
istatus = nf_inq_ndims(finid,ndims)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_unlimdim(finid,unlimdimid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(5x,a,I2)') 'Copying dimensions - ',ndims
DO dimid = 1,ndims
istatus = nf_inq_dim(finid,dimid,dimname,dimlen)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
diminnames(dimid) = dimname
dimina(dimid) = dimlen ! Save dimension id and len
dimouta(dimid) = dimlen ! Output dimension id and len
IF (dimid == nxid) THEN
dimlen = nx
dimouta(dimid) = dimlen
ELSE IF (dimid == nxsid) THEN
dimlen = nx-1
dimouta(dimid) = dimlen
ELSE IF (dimid == nyid) THEN
dimlen = ny
dimouta(dimid) = dimlen
ELSE IF (dimid == nysid) THEN
dimlen = ny-1
dimouta(dimid) = dimlen
ELSE IF (dimid == unlimdimid) THEN
dimlen = NF_UNLIMITED
END IF
IF (debug > 0) WRITE(6,'(9x,2a)') 'Dimension name - ',TRIM(dimname)
DO jloc = 1,nproc_y ! Write patches Dimensions
DO iloc = 1,nproc_x
istatus = nf_def_dim(foutids(iloc,jloc),dimname,dimlen,odimid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
END DO
dimouts0(:,:,:) = 0 ! The starting index of each dimensions for each subdomain
DO jloc = 1,nproc_y
DO iloc = 1,nproc_x
dimouts0(nxid,iloc,jloc) = (iloc-1)*(nx-3)
dimouts0(nyid,iloc,jloc) = (jloc-1)*(ny-3)
END DO
END DO
IF (stag) THEN
dimouts0(nxsid,:,:) = dimouts0(nxid,:,:)
dimouts0(nysid,:,:) = dimouts0(nyid,:,:)
END IF
!
! Set Global attributes
!
istatus = nf_inq_natts(finid,ngatts)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(5x,a,I2)') 'Copying global attributes - ',ngatts
DO attnum = 1,ngatts
istatus = nf_inq_attname(finid,NF_GLOBAL,attnum,attname)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(9x,2a)') 'Attribute name - ',TRIM(attname)
DO jloc = 1,nproc_y ! Write patches global attributes
DO iloc = 1,nproc_x
istatus = nf_copy_att(finid,NF_GLOBAL,attname,foutids(iloc,jloc),NF_GLOBAL)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
END DO
!
! Define variables
!
istatus = nf_inq_nvars(finid,nvars)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(5x,a,I2)') 'Defining variables - ',nvars
DO varid = 1,nvars
istatus = nf_inq_var(finid,varid,varname,vartype,varndims,vardimids,varnatts)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(9x,2a)') 'Variables - ',TRIM(varname)
DO jloc = 1,nproc_y ! Define patches variables
DO iloc = 1,nproc_x
! Dimensions should be in the same order
istatus = nf_def_var(foutids(iloc,jloc),varname,vartype,varndims,vardimids,ovarid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
DO attnum = 1,varnatts ! Copy variable attributes
istatus = nf_inq_attname(finid,varid,attnum,attname)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_copy_att(finid,varid,attname,foutids(iloc,jloc),ovarid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
END DO
END DO
DO jloc = 1,nproc_y ! End patches DEF mode
DO iloc = 1,nproc_x
istatus = nf_enddef(foutids(iloc,jloc))
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
IF(debug > 0) WRITE(6,'(1x,a)') 'All patches have been defined.'
!
! Split and assign variables, LOOP over variables
!
DO varid = 1,nvars
vardimids(:) = 0
istatus = nf_inq_var(finid,varid,varname,vartype,varndims,vardimids,varnatts)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug >0) WRITE(6,'(9x,2a)') 'Processing variables - ',TRIM(varname)
varainsize = 1
varaoutsize = 1
outidx(:) = 1 ! Initial all dimension size to be 1
countidx(:) = 1
DO vardim = 1, varndims
countidx(vardim) = dimina(vardimids(vardim))
outidx(vardim) = dimouta(vardimids(vardim))
varainsize = countidx(vardim)*varainsize
varaoutsize = outidx(vardim)*varaoutsize
IF (debug > 1) WRITE(6,'(13x,a15,2(a,I4),a)') &
TRIM(diminnames(vardimids(vardim))),': ',countidx(vardim),'(in) - ',&
outidx(vardim), '(out).'
END DO
sin1d = countidx(1) ! size of one column, INPUT
sin2d = sin1d*countidx(2) ! size of one slice (xy)
sin3d = sin2d*countidx(3) ! size of one cell (xyz)
sin4d = sin3d*countidx(4)
sout1d = outidx(1) ! size of one column, OUTPUT
sout2d = sout1d*outidx(2)
sout3d = sout2d*outidx(3)
sout4d = sout3d*outidx(4)
SELECT CASE (vartype)
CASE (NF_INT)
IF (varainsize > varaallsize) THEN ! Allocate input array only when necessary
IF (ALLOCATED(variin)) DEALLOCATE(variin, STAT = istatus)
ALLOCATE(variin(varainsize), STAT = istatus)
varaallsize = varainsize
END IF
IF (varaoutsize > varballsize) THEN ! Allocate output array only when necessary
IF (ALLOCATED(variout)) DEALLOCATE(variout, STAT = istatus)
ALLOCATE(variout(varaoutsize), STAT = istatus)
varballsize = varaoutsize
END IF
istatus = NF_GET_VARA_INT(finid,varid,startidx,countidx,variin)
DO jloc = 1,nproc_y ! Write patches variables
DO iloc = 1,nproc_x
IF (debug > 1) THEN
WRITE(6,FMT='(13x,a,2(I4,a))',ADVANCE='NO') &
'Writing to processor - (',iloc,',',jloc,') with: '
DO vardim = 1,varndims
WRITE(6,FMT='(I4,a)',ADVANCE='NO') dimouts0(vardimids(vardim),iloc,jloc),' '
END DO
WRITE(6,*)
END IF
DO nd5 = 1, outidx(5) ! Assume max rank is 5, IMPORTANT
DO nd4 = 1, outidx(4)
DO nd3 = 1, outidx(3)
DO nd2 = 1, outidx(2)
DO nd1 = 1, outidx(1)
iin = nd1+dimouts0(vardimids(1),iloc,jloc) &
+ (nd2+dimouts0(vardimids(2),iloc,jloc)-1)*sin1d &
+ (nd3+dimouts0(vardimids(3),iloc,jloc)-1)*sin2d &
+ (nd4+dimouts0(vardimids(4),iloc,jloc)-1)*sin3d &
+ (nd5+dimouts0(vardimids(5),iloc,jloc)-1)*sin4d
iout = nd1 + (nd2-1)*sout1d + (nd3-1)*sout2d &
+ (nd4-1)*sout3d + (nd5-1)*sout4d
! IF (debug > 2) WRITE(6,'(13x,a,2I2,3(a,I4),4I4)') &
! 'Processor - ',iloc,jloc,': Extracting from ',iin, &
! ' to ',iout,' at ',nd1,nd2,nd3,nd4,nd5
variout(iout) = variin(iin)
END DO
END DO
END DO
END DO
END DO
istatus = nf_put_vara_INT(foutids(iloc,jloc),varid,startidx,outidx,variout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
CASE (NF_FLOAT)
IF (varainsize > varaallsize) THEN ! Allocate input array only when necessary
IF (ALLOCATED(varain)) DEALLOCATE(varain, STAT = istatus)
ALLOCATE(varain(varainsize), STAT = istatus)
varaallsize = varainsize
END IF
IF (varaoutsize > varballsize) THEN ! Allocate output array only when necessary
IF (ALLOCATED(varaout)) DEALLOCATE(varaout, STAT = istatus)
ALLOCATE(varaout(varaoutsize), STAT = istatus)
varballsize = varaoutsize
END IF
istatus = NF_GET_VARA_REAL(finid,varid,startidx,countidx,varain)
DO jloc = 1,nproc_y ! Write patches variables
DO iloc = 1,nproc_x
IF (debug > 1) THEN
WRITE(6,FMT='(13x,a,2(I4,a))',ADVANCE='NO') &
'Writing to processor - (',iloc,',',jloc,') with: '
DO vardim = 1,varndims
WRITE(6,FMT='(I4,a)',ADVANCE='NO') dimouts0(vardimids(vardim),iloc,jloc),' '
END DO
WRITE(6,*)
END IF
DO nd5 = 1, outidx(5) ! Assume max rank is 5, IMPORTANT
DO nd4 = 1, outidx(4)
DO nd3 = 1, outidx(3)
DO nd2 = 1, outidx(2)
DO nd1 = 1, outidx(1)
iin = nd1+dimouts0(vardimids(1),iloc,jloc) &
+ (nd2+dimouts0(vardimids(2),iloc,jloc)-1)*sin1d &
+ (nd3+dimouts0(vardimids(3),iloc,jloc)-1)*sin2d &
+ (nd4+dimouts0(vardimids(4),iloc,jloc)-1)*sin3d &
+ (nd5+dimouts0(vardimids(5),iloc,jloc)-1)*sin4d
iout = nd1 + (nd2-1)*sout1d + (nd3-1)*sout2d &
+ (nd4-1)*sout3d + (nd5-1)*sout4d
! IF (debug > 2) WRITE(6,'(13x,a,2I2,3(a,I4),4I4)') &
! 'Processor - ',iloc,jloc,': Extracting from ',iin, &
! ' to ',iout,' at ',nd1,nd2,nd3,nd4,nd5
!
varaout(iout) = varain(iin)
END DO
END DO
END DO
END DO
END DO
istatus = nf_put_vara_real(foutids(iloc,jloc),varid,startidx,outidx,varaout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
CASE DEFAULT
WRITE(6,'(1x,a,I2)') 'ERROR: unsupported variable type = ',vartype
istatus = -4
RETURN
END SELECT
END DO
!
! Close files
!
IF (debug > 0) WRITE(6,'(1x,a)') 'Closing all files ...'
DO jloc = 1,nproc_y ! Close patches
DO iloc = 1,nproc_x
istatus = nf_close(foutids(iloc,jloc))
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
istatus = nf_close(finid) ! Close file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
DEALLOCATE(outfilenames, foutids, STAT = istatus)
IF (ALLOCATED(varain)) DEALLOCATE(varain, varaout, STAT = istatus)
IF (ALLOCATED(variin)) DEALLOCATE(variin, variout, STAT = istatus)
RETURN
END SUBROUTINE splitncdf
SUBROUTINE handle_err(istat) 151
IMPLICIT NONE
INTEGER, INTENT(IN) :: istat
INCLUDE 'netcdf.inc'
IF (istat /= NF_NOERR) THEN
PRINT *, TRIM(nf_strerror(istat))
STOP 'NetCDF error!'
END IF
RETURN
END SUBROUTINE handle_err