! !################################################################## !################################################################## !###### ###### !###### 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