!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE check_files_dimensions ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE check_files_dimensions(MAXWRFFIL,grid_id,io_form,jointime, & 1,1
nprocs,nproc_x,nproc_y,abstimes,abstimei,abstimee, &
dir_extd,extdname,nextdfil, &
ids,ide,idss,idse,jds,jde,jdss,jdse,istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE: Check the existence of WRF files to be read and return the
! valid file number, file names and the domain grid indices.
!
!-----------------------------------------------------------------------
!
! AUTHOR:
! Yunheng Wang (04/26/2007)
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: MAXWRFFIL
INTEGER, INTENT(IN) :: grid_id
INTEGER, INTENT(IN) :: io_form
LOGICAL, INTENT(IN) :: jointime
INTEGER, INTENT(IN) :: abstimes, abstimei, abstimee
INTEGER, INTENT(IN) :: nproc_x,nproc_y
INTEGER, INTENT(IN) :: nprocs(nproc_x*nproc_y)
CHARACTER(LEN=256), INTENT(IN) :: dir_extd
CHARACTER(LEN=256), INTENT(OUT) :: extdname(MAXWRFFIL)
INTEGER, INTENT(OUT) :: nextdfil
INTEGER, INTENT(OUT) :: ids, ide, jds, jde
INTEGER, INTENT(OUT) :: idss,idse,jdss,jdse
INTEGER, INTENT(OUT) :: istatus
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: year, month, day, hour, minute, second
INTEGER :: ifile, npx, npy, n
INTEGER :: ips, ipe, jps, jpe, ipss, ipse, jpss, jpse
INTEGER :: ipssv, ipesv, jpssv, jpesv
INTEGER :: nx
CHARACTER(LEN=256) :: tmpstr
LOGICAL :: fexist
LOGICAL :: dset = .FALSE., in_a_row = .FALSE.
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begining of executable code ....
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
ids = 99999999
ide = 0
idss = 99999999
idse = 0
jds = 99999999
jde = 0
jdss = 99999999
jdse = 0
nextdfil = 0
extdname(:) = ' '
istatus = 0
WRITE(6,'(1x,a,/,1x,a,/)') &
'============================','WRF files to be read are:'
ifile = abstimes
DO WHILE (ifile <= abstimee)
CALL abss2ctim
(ifile,year,month,day,hour,minute,second)
nextdfil = nextdfil + 1
WRITE(extdname(nextdfil),'(a,a,I2.2,a,I4.4,5(a,I2.2))') &
TRIM(dir_extd),'wrfout_d',grid_id,'_', &
year,'-',month,'-',day,'_',hour,':',minute,':',second
ipssv = 0
ipesv = 0
jpssv = 0
jpesv = 0
n = 0
DO npy = 1,nproc_y
in_a_row = .FALSE.
DO npx = 1,nproc_x
IF (npx > 1) in_a_row = .TRUE.
n = n+1
IF (jointime .AND. nproc_x*nproc_y == 1) THEN
WRITE(tmpstr,'(a)') TRIM(extdname(nextdfil))
ELSE
WRITE(tmpstr,'(a,a,I4.4)') TRIM(extdname(nextdfil)),'_',nprocs(n)
END IF
INQUIRE(FILE=TRIM(tmpstr), EXIST = fexist )
IF(.NOT. fexist) THEN
WRITE(6,'(1x,a)') 'ERROR: The WRF file ', &
TRIM(tmpstr),' does not exist.'
STOP
ELSE
CALL get_wrf_patch_indices(TRIM(tmpstr),io_form, &
ips,ipe,ipss,ipse,jps,jpe,jpss,jpse,nx,istatus)
IF (istatus /= 0) EXIT
IF (.NOT. dset) THEN
IF (npx == 1) THEN
ids = ips
idss = ipss
END IF
IF (npx == nproc_x) THEN
ide = ipe
idse = ipse
END IF
IF (npy == 1) THEN
jds = jps
jdss = jpss
END IF
IF (npy == nproc_y) THEN
jde = jpe
jdse = jpse
END IF
END IF
IF ( n > 1) THEN
IF (in_a_row) THEN
IF (jps /= jpssv .OR. jpe /= jpesv .OR. ips /= ipesv+1) THEN
WRITE(6,'(/,1x,a,I4,2a,/,8x,2(a,I2),a,/,8x,a,/,8x,a,/)') &
'ERROR: Patch ',n,' for file ',TRIM(tmpstr), &
'at relative patch (',npx,',',npy, &
') is not aligned in a row with its former patch.', &
'Please check parameter nproc_xin. Either it was specified with a wrong number', &
'or the program has made a bad guess about it.'
STOP
END IF
ELSE
IF (jps /= jpesv+1) THEN
WRITE(6,'(/,1x,a,I4,2a,/,8x,2(a,I2),a,/,8x,a,/,8x,a,/)') &
'ERROR: Patch ',n,' for file ',TRIM(tmpstr), &
'at relative patch (',npx,',',npy, &
') is not aligned in column with its former patch.', &
'Please check parameter nproc_xin. Either it was specified with a wrong number', &
'or the program has made a bad guess about it.'
STOP
END IF
END IF
END IF
ipssv = ips
ipesv = ipe
jpssv = jps
jpesv = jpe
WRITE(6,'(3x,a,I2.2,a,I4,a,/,5x,a)') &
'WRF file ',nextdfil,': patch - ',n,' =', TRIM(tmpstr)
END IF
END DO
END DO
ifile = ifile + abstimei
dset = .TRUE.
END DO
!-----------------------------------------------------------------------
!
! Validate nextdfil before return
!
!-----------------------------------------------------------------------
IF(nextdfil < 1) THEN
WRITE(6,'(a)') 'No input WRF file was valid. Please check the input file.'
istatus = -3
RETURN
END IF
IF (ide < ids .OR. jde < jds) THEN
WRITE(6,'(1x,2(a,I4),/36x,2(a,I4),a)') &
'ERROR: Domain indices are invalid: ids = ',ids,', ide = ',ide, &
'; jds = ',jds,', jde = ',jde,'.'
istatus = -3
RETURN
END IF
RETURN
END SUBROUTINE check_files_dimensions
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE get_wrf_patch_indices ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE get_wrf_patch_indices(filename,io_form,ips,ipe,ipss,ipse, &,60
jps,jpe,jpss,jpse,nx,istatus)
!-----------------------------------------------------------------------
!
! PURPOSE:
! Get the size of data patch stored in the WRF data file
!
!-----------------------------------------------------------------------
!
! AUTHOR:
! Yunheng Wang (04/26/2007)
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
IMPLICIT NONE
CHARACTER(LEN=*), INTENT(IN) :: filename
INTEGER, INTENT(IN) :: io_form
INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe
INTEGER, INTENT(OUT) :: ipss,ipse,jpss,jpse
INTEGER, INTENT(OUT) :: nx
INTEGER, INTENT(OUT) :: istatus
INCLUDE 'netcdf.inc'
!------------------------------------------------------------------
!
! Misc. local variables
!
!------------------------------------------------------------------
INTEGER :: ncid
CHARACTER(LEN=80) :: errmsg
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
istatus = 0
IF (io_form == 7) THEN
istatus = NF_OPEN(TRIM(filename),NF_NOWRITE,ncid)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_PATCH_START_STAG',ips)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_PATCH_END_STAG',ipe)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_PATCH_START_UNSTAG',ipss)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_PATCH_END_UNSTAG',ipse)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'SOUTH-NORTH_PATCH_START_STAG',jps)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'SOUTH-NORTH_PATCH_END_STAG',jpe)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'SOUTH-NORTH_PATCH_START_UNSTAG',jpss)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'SOUTH-NORTH_PATCH_END_UNSTAG',jpse)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_GRID_DIMENSION',nx)
IF(istatus /= NF_NOERR) GO TO 999
istatus = NF_CLOSE(ncid)
IF(istatus /= NF_NOERR) GO TO 999
ELSE
istatus = -1
ips = 0
ipe = 0
ipse= 0
jps = 0
jpe = 0
jpse= 0
WRITE(6,'(1x,a,/)') &
'WARNING: Only support netCDF file at present for patch indices.'
END IF
RETURN
999 CONTINUE
errmsg = NF_STRERROR(istatus)
WRITE(6,'(1x,2a)') 'NetCDF error: ',errmsg
STOP
RETURN
END SUBROUTINE get_wrf_patch_indices
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE joinwrfncdf ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE joinwrfncdf(filenames,nfile,attadj,jointime,procs,npatch, & 1
ids,ide,idss,idse,jds,jde,jdss,jdse, &
outdirname,filetail,nvarout,varlists,debug,istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Join WRF files in netCDF patches into one large piece.
!
!-----------------------------------------------------------------------
!
! Author: Yunheng Wang (04/27/2007)
!
! MODIFICATIONS:
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfile
LOGICAL, INTENT(IN) :: attadj
LOGICAL, INTENT(IN) :: jointime
INTEGER, INTENT(IN) :: npatch
INTEGER, INTENT(IN) :: procs(npatch)
INTEGER, INTENT(IN) :: ids,ide,idss,idse,jds,jde,jdss,jdse
INTEGER, INTENT(INOUT) :: nvarout
INTEGER, INTENT(IN) :: debug
INTEGER, INTENT(OUT) :: istatus
CHARACTER(LEN=*), INTENT(IN) :: filenames(nfile)
CHARACTER(LEN=*), INTENT(IN) :: outdirname
CHARACTER(LEN=5), INTENT(IN) :: filetail
CHARACTER(LEN=20), INTENT(IN) :: varlists(nvarout)
!
!-----------------------------------------------------------------------
!
! Including files
!
!-----------------------------------------------------------------------
INCLUDE 'netcdf.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: nf, nvar, n
INTEGER :: strlen
LOGICAL :: ispatch(NF_MAX_VARS)
CHARACTER(LEN=256) :: infilename, outfilename
INTEGER :: finid, foutid
INTEGER :: idsout, ideout, jdsout, jdeout
INTEGER :: idssout, idseout, jdssout, jdseout
!
! Dimension variables
!
CHARACTER(LEN=32), PARAMETER :: xdimname = 'west_east_stag'
CHARACTER(LEN=32), PARAMETER :: ydimname = 'south_north_stag'
CHARACTER(LEN=32), PARAMETER :: xsdimname = 'west_east'
CHARACTER(LEN=32), PARAMETER :: ysdimname = 'south_north'
CHARACTER(LEN=32) :: diminnames(NF_MAX_DIMS)
CHARACTER(LEN=32) :: dimname
INTEGER :: nxid, nyid, nxlg, nylg, nxsid, nysid, nxslg, nyslg
INTEGER :: narrsize, narrisizemax, narrasizemax
INTEGER :: unlimdimid, unlimdimlen, unlimodimlen, odimid
INTEGER :: ndims, dimid, dimlen
INTEGER :: dimina(NF_MAX_DIMS) ! Dimension size in original file
! INTEGER :: dimouta(NF_MAX_DIMS) ! Dimension size in joined files
!
! Attribute variables
!
CHARACTER(LEN=32), PARAMETER :: attnm_ips = 'WEST-EAST_PATCH_START_STAG'
CHARACTER(LEN=32), PARAMETER :: attnm_ipe = 'WEST-EAST_PATCH_END_STAG'
CHARACTER(LEN=32), PARAMETER :: attnm_ipss = 'WEST-EAST_PATCH_START_UNSTAG'
CHARACTER(LEN=32), PARAMETER :: attnm_ipse = 'WEST-EAST_PATCH_END_UNSTAG'
CHARACTER(LEN=32), PARAMETER :: attnm_jps = 'SOUTH-NORTH_PATCH_START_STAG'
CHARACTER(LEN=32), PARAMETER :: attnm_jpe = 'SOUTH-NORTH_PATCH_END_STAG'
CHARACTER(LEN=32), PARAMETER :: attnm_jpss = 'SOUTH-NORTH_PATCH_START_UNSTAG'
CHARACTER(LEN=32), PARAMETER :: attnm_jpse = 'SOUTH-NORTH_PATCH_END_UNSTAG'
CHARACTER(LEN=32) :: attname
INTEGER :: ipsid, ipeid, jpsid, jpeid
INTEGER :: ipssid, ipseid, jpssid, jpseid
INTEGER :: ips, ipe, ipss, ipse
INTEGER :: jps, jpe, jpss, jpse
INTEGER :: attnum, ngatts
CHARACTER(LEN=32), PARAMETER :: attnm_ndx = 'WEST-EAST_GRID_DIMENSION'
CHARACTER(LEN=32), PARAMETER :: attnm_ndy = 'SOUTH-NORTH_GRID_DIMENSION'
INTEGER :: ndxid, ndyid
!
! Dataset varaibles
!
INTEGER, PARAMETER :: MAX_RANK = 4 ! Assume the max rank is 5
CHARACTER(LEN=32) :: varname
INTEGER :: varid, nvars, ovarid
INTEGER :: vartype, varndims, varnatts
INTEGER :: vardimids(MAX_RANK),startidx(MAX_RANK), countidx(MAX_RANK)
INTEGER :: outstart(MAX_RANK)
INTEGER :: vardim, vdimid
INTEGER :: varidlists(NF_MAX_VARS), varoutidlists(NF_MAX_VARS)
INTEGER, ALLOCATABLE :: varari(:)
REAL, ALLOCATABLE :: vararr(:)
CHARACTER(LEN=256) :: tmpstr
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code below
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
varidlists(:) = 0
nxlg = ide-ids+1
nylg = jde-jds+1
nxslg = idse-idss+1
nyslg = jdse-jdss+1
startidx(:) = 1
narrisizemax = 0
narrasizemax = 0
unlimdimlen = 1
istatus = 0
DO nf = 1,nfile
IF (.NOT. jointime .OR. nf == 1) THEN
strlen = LEN_TRIM(filenames(nf))
n = INDEX(filenames(nf),'/',.TRUE.)
WRITE(outfilename,'(3a)') TRIM(outdirname), &
filenames(nf)(n+1:strlen),filetail
IF (jointime .AND. npatch == 1) THEN
WRITE(infilename, '(a)') TRIM(filenames(nf))
ELSE
WRITE(infilename, '(2a,I4.4)') TRIM(filenames(nf)),'_',procs(1)
END IF
IF (debug > 0) WRITE(6,'(1x,2a)') 'Opening file - ',TRIM(infilename)
istatus = nf_open(infilename,NF_NOWRITE,finid) ! Open file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (debug > 0) WRITE(6,'(1x,2a)') 'Creating file - ',TRIM(outfilename)
! istatus = nf_create(TRIM(outfilename),NF_CLOBBER,foutid) ! CDF 1
istatus = NF_CREATE(TRIM(outfilename),IOR(NF_CLOBBER,NF_64BIT_OFFSET),foutid) ! CDF 2
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
!
! Set dimensions
!
istatus = nf_inq_dimid(finid,xdimname,nxid)
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_dimid(finid,xsdimname,nxsid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_dimid(finid,ysdimname,nysid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_unlimdim(finid,unlimdimid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_ndims(finid,ndims)
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 = nxlg
! dimouta(dimid) = dimlen
ELSE IF (dimid == nxsid) THEN
dimlen = nxslg
! dimouta(dimid) = dimlen
ELSE IF (dimid == nyid) THEN
dimlen = nylg
! dimouta(dimid) = dimlen
ELSE IF (dimid == nysid) THEN
dimlen = nyslg
! dimouta(dimid) = dimlen
ELSE IF (dimid == unlimdimid) THEN
dimlen = NF_UNLIMITED
END IF
IF (debug > 0) WRITE(6,'(9x,2a)') 'Dimension name - ',TRIM(dimname)
istatus = nf_def_dim(foutid,dimname,dimlen,odimid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
!
! Set Global attributes
!
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ips),ipsid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ipe),ipeid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ipss),ipssid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ipse),ipseid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_jps),jpsid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_jpe),jpeid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_jpss),jpssid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_jpse),jpseid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ndx),ndxid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_inq_attid(finid,NF_GLOBAL,TRIM(attnm_ndy),ndyid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
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
IF (attadj) THEN
idsout = 1
ideout = ide - ids + 1
idssout = 1
idseout = idse - idss + 1
jdsout = 1
jdeout = jde - jds + 1
jdssout = 1
jdseout = jdse - jdss + 1
ELSE
idsout = ids
ideout = ide
idssout = idss
idseout = idse
jdsout = jds
jdeout = jde
jdssout = jdss
jdseout = jdse
END IF
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)
IF (attadj) THEN
IF (attnum == ndxid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ndx),NF_INT,1,nxlg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
CYCLE
ELSE IF (attnum == ndyid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ndy),NF_INT,1,nylg)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
CYCLE
END IF
END IF
IF (attnum == ipsid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ips),NF_INT,1,idsout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == ipeid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ipe),NF_INT,1,ideout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == jpsid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_jps),NF_INT,1,jdsout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == jpeid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_jpe),NF_INT,1,jdeout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == ipssid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ipss),NF_INT,1,idssout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == ipseid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_ipse),NF_INT,1,idseout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == jpssid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_jpss),NF_INT,1,jdssout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE IF (attnum == jpseid) THEN
istatus = NF_PUT_ATT_INT(foutid,NF_GLOBAL,TRIM(attnm_jpse),NF_INT,1,jdseout)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
ELSE
istatus = nf_copy_att(finid,NF_GLOBAL,attname,foutid,NF_GLOBAL)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END IF
END DO
!
! Define variables
!
istatus = nf_inq_nvars(finid,nvars)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF (nvarout >= nvars) THEN
nvarout = nvars
DO n = 1,nvars
varidlists(n) = n
END DO
ELSE
nvar = nvarout ! suppost to process this number
nvarout = 0 ! actually got
DO n = 1,nvar
istatus = nf_inq_varid(finid,TRIM(varlists(n)),ovarid)
IF (istatus /= NF_NOERR) THEN
WRITE(6,'(1x,3a)') 'WARNING: Variable ',TRIM(varlists(n)),' not found. Skipped.'
CYCLE
END IF
nvarout = nvarout + 1
varidlists(nvarout) = ovarid
END DO
END IF
IF (debug > 0) WRITE(6,'(5x,a,I4)') 'Defining variables - ',nvarout
DO n = 1,nvarout
varid = varidlists(n)
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)
! Dimensions should be in the same order
istatus = nf_def_var(foutid,varname,vartype,varndims,vardimids,ovarid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
varoutidlists(n) = ovarid
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,foutid,ovarid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
END DO
istatus = nf_enddef(foutid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
IF(debug > 0) WRITE(6,'(1x,a)') 'Merged file have been defined.'
istatus = nf_close(finid) ! Close file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END IF ! File created.
IF (.NOT. jointime) unlimdimlen = 1
unlimodimlen = 0
!
! Write each patch to the merged file
!
ispatch(:) = .FALSE.
DO n = 1,npatch
IF (jointime .AND. npatch == 1) THEN
WRITE(infilename, '(a)') TRIM(filenames(nf))
ELSE
WRITE(infilename, '(2a,I4.4)') TRIM(filenames(nf)),'_',procs(n)
END IF
IF (debug > 0) WRITE(6,'(1x,2a)') 'Opening file - ',TRIM(infilename)
istatus = nf_open(TRIM(infilename),NF_NOWRITE,finid) ! Open file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
!
! Get patch indice
!
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_ips),ips)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_ipe),ipe)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_ipss),ipss)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_ipse),ipse)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_jps),jps)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_jpe),jpe)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_jpss),jpss)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_get_att_int(finid,NF_GLOBAL,TRIM(attnm_jpse),jpse)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
!
! Get and save dimension size for this patch
!
istatus = nf_inq_ndims(finid,ndims)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
dimina(:) = 0
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
END DO
!
! loop over each variable
!
DO nvar = 1,nvarout
varid = varidlists(nvar)
vardimids(:) = 0
istatus = nf_inq_var(finid,varid,varname,vartype,varndims,vardimids,varnatts)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
countidx(:) = 1
outstart(:) = 1
narrsize = 1
DO vardim = 1, varndims
vdimid = vardimids(vardim)
countidx(vardim) = dimina (vdimid)
IF ( vdimid == nxid) THEN
outstart(vardim) = ips - ids + 1 ! start relative in subdomain
ispatch(nvar) = .TRUE.
ELSE IF ( vdimid == nyid) THEN
outstart(vardim) = jps - jds + 1
ispatch(nvar) = .TRUE.
ELSE IF ( vdimid == nxsid) THEN
outstart(vardim) = ipss - idss + 1
ispatch(nvar) = .TRUE.
ELSE IF ( vdimid == nysid) THEN
outstart(vardim) = jpss - jdss + 1
ispatch(nvar) = .TRUE.
ELSE IF (vdimid == unlimdimid) THEN
outstart(vardim) = unlimdimlen
IF (unlimodimlen <= 0) THEN
unlimodimlen = countidx(vardim)
ELSE
IF ( unlimodimlen /= countidx(vardim)) THEN
WRITE(6,'(1x,a,/)') 'ERROR: Inconsisten size for UNLIMITED dimension.'
STOP
END IF
END IF
ELSE
outstart(vardim) = 1
END IF
narrsize = countidx(vardim)*narrsize
END DO
IF ( n > 1 .AND. (.NOT. ispatch(nvar)) ) THEN
IF (debug > 2) WRITE(6,'(9x,3a)') 'Variable ',TRIM(varname),' skipped.'
CYCLE
ELSE
IF (debug > 2) THEN
WRITE(6,'(9x,3a,I2)') &
'Processing variables - ',TRIM(varname),' with rank = ',varndims
DO vardim = 1,varndims
vdimid = vardimids(vardim)
WRITE(6,'(12x,a,2(a,I4))') diminnames(vdimid), &
', startidx = ',outstart(vardim),', size = ', countidx(vardim)
END DO
END IF
END IF
! do not have to merge, use values from the first file
! IF (.NOT. ispatch(nvar)) THEN
!
! IF (debug > 0) WRITE(6,'(9x,2a)') 'Copying variables - ',TRIM(varname)
!
!write(0,*) finid,varid,foutid
! istatus = NF_COPY_VAR(finid,varid,foutid)
! IF (istatus /= NF_NOERR) CALL handle_err(istatus)
!
! ELSE
ovarid = varoutidlists(nvar)
! IF (debug > 0) WRITE(6,'(9x,2a)') 'Writing patch of variables - ',TRIM(varname)
SELECT CASE (vartype)
CASE (NF_INT)
IF (narrsize > narrisizemax) THEN ! Allocate input array only when necessary
IF (ALLOCATED(varari)) DEALLOCATE(varari, STAT = istatus)
ALLOCATE(varari(narrsize), STAT = istatus)
narrisizemax = narrsize
END IF
istatus = NF_GET_VARA_INT(finid,varid,startidx,countidx,varari)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_put_vara_INT(foutid,ovarid,outstart,countidx,varari)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
CASE (NF_FLOAT)
IF (narrsize > narrasizemax) THEN ! Allocate input array only when necessary
IF (ALLOCATED(vararr)) DEALLOCATE(vararr, STAT = istatus)
ALLOCATE(vararr(narrsize), STAT = istatus)
narrasizemax = narrsize
END IF
istatus = NF_GET_VARA_REAL(finid,varid,startidx,countidx,vararr)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_put_vara_REAL(foutid,ovarid,outstart,countidx,vararr)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
CASE (NF_CHAR)
istatus = NF_GET_VARA_TEXT(finid,varid,startidx,countidx,tmpstr)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
istatus = nf_put_vara_TEXT(foutid,ovarid,outstart,countidx,TRIM(tmpstr))
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
CASE DEFAULT
WRITE(6,'(1x,a,I2)') 'ERROR: unsupported variable type = ',vartype
istatus = -4
RETURN
END SELECT
! END IF ! ispatch(nvar)
END DO
istatus = nf_close(finid) ! Close file
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END DO
unlimdimlen = unlimdimlen + unlimodimlen ! Add # of time levels
! in output file
IF (.NOT. jointime .OR. nf == nfile) THEN
istatus = nf_close(foutid)
IF (istatus /= NF_NOERR) CALL handle_err(istatus)
END IF
END DO
RETURN
END SUBROUTINE joinwrfncdf
!
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