!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE BINDUMP3D ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE bindump3d(nx,ny,nz,filenm,qtag,qunits,qfield, & 6,3
i0,j0,k0)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Write out one single 2D/3D field in binary format
!
!-----------------------------------------------------------------------
!
! AUTHOR: Fanyou Kong
! 02/15/2007
!-----------------------------------------------------------------------
!
IMPLICIT NONE
CHARACTER (LEN=*) :: filenm
INTEGER :: fileun
CHARACTER (LEN=*) :: qtag, qunits
CHARACTER (LEN=40) :: qtag1, qunits1
INTEGER :: i0,j0,k0,istat
INTEGER :: nx,ny,nz
REAL :: qfield(nx,ny,nz)
INCLUDE 'mp.inc'
INTEGER :: lengt
INTEGER :: nxlg, nylg
REAL, ALLOCATABLE :: out3d(:,:,:)
qtag1=qtag
qunits1=qunits
nxlg = nproc_x*(nx-3)+3
nylg = nproc_y*(ny-3)+3
ALLOCATE (out3d( nxlg,nylg, nz ),stat=istat)
CALL getunit
(fileun)
IF(myproc == 0 ) print *,'filenm:',trim(filenm)
! CALL asnctl ('NEWLOCAL', 1, istat)
! CALL asnfile(filenm, '-F f77 -N ieee', istat)
IF (mp_opt > 0 .AND. joindmp > 0) THEN
! Write joined single file for the 3D field
IF (myproc == 0) THEN
! open(UNIT=fileun,file=trim(filenm),STATUS='new', &
open(UNIT=fileun,file=trim(filenm), &
FORM='unformatted',IOSTAT= istat )
END IF
CALL edgfill(qfield,1,nx,1,nx-i0,1,ny,1,ny-j0,1,nz,1,nz-k0)
CALL mpimerge3d(qfield,nx,ny,nz,out3d)
IF (myproc == 0) THEN
write(fileun) nxlg,nylg,nz
write(fileun) out3d(1:nxlg,1:nylg,1:nz)
write(fileun) qtag1
write(fileun) qunits1
END IF
IF (myproc == 0) CLOSE(UNIT=fileun)
ELSE
! Write piecewise or non-MPI file for the 3D field
open(UNIT=fileun,file=trim(filenm), &
! open(UNIT=fileun,file=trim(filenm),STATUS='new', &
FORM='unformatted',IOSTAT= istat )
write(fileun) nx,ny,nz
write(fileun) qfield
write(fileun) qtag1
write(fileun) qunits1
CLOSE(UNIT=fileun)
END IF
CALL retunit(fileun)
DEALLOCATE(out3d)
RETURN
END SUBROUTINE bindump3d
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE BINDUMP2D ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE bindump2d(nx,ny,filenm,qtag,qunits,qfield) 59,4
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Write out one single 2D field in binary format
!
!-----------------------------------------------------------------------
!
! AUTHOR: Fanyou Kong
! 02/15/2007
!-----------------------------------------------------------------------
!
IMPLICIT NONE
CHARACTER (LEN=*) :: filenm
INTEGER :: fileun
CHARACTER (LEN=*) :: qtag, qunits
CHARACTER (LEN=40) :: qtag1, qunits1
INTEGER :: istat
INTEGER :: nx,ny
REAL :: qfield(nx,ny)
INCLUDE 'mp.inc'
INTEGER :: lengt
INTEGER :: nxlg, nylg
REAL, ALLOCATABLE :: out2d(:,:)
qtag1=qtag
qunits1=qunits
nxlg = nproc_x*(nx-3)+3
nylg = nproc_y*(ny-3)+3
ALLOCATE (out2d( nxlg,nylg ),stat=istat)
IF(myproc == 0 ) print *,'filenm:',trim(filenm)
! CALL asnctl ('NEWLOCAL', 1, istat)
! CALL asnfile(filenm, '-F f77 -N ieee', istat)
! IF (mp_opt > 0 .AND. joindmp > 0) THEN
IF (mp_opt > 0 ) THEN ! hard coded to write joined 2D file
CALL edgfill(qfield,1,nx,1,nx-1,1,ny,1,ny-1,1,1,1,1)
CALL mpimerge3d(qfield,nx,ny,1,out2d)
IF (myproc == 0) THEN
CALL getunit(fileun)
! Write joined single file for the 3D field
!open(UNIT=fileun,file=trim(filenm),STATUS='new', &
OPEN(UNIT=fileun,file=trim(filenm),FORM='unformatted',IOSTAT= istat )
WRITE(fileun) nxlg,nylg,1
WRITE(fileun) out2d(1:nxlg,1:nylg)
WRITE(fileun) qtag1
WRITE(fileun) qunits1
CLOSE(UNIT=fileun)
CALL retunit(fileun)
END IF
ELSE
CALL getunit(fileun)
! Write piecewise or non-MPI file for the 3D field
! open(UNIT=fileun,file=trim(filenm),STATUS='new', &
open(UNIT=fileun,file=trim(filenm), &
FORM='unformatted',IOSTAT= istat )
write(fileun) nx,ny,1
write(fileun) qfield
write(fileun) qtag1
write(fileun) qunits1
CLOSE(UNIT=fileun)
CALL retunit(fileun)
END IF
DEALLOCATE(out2d)
RETURN
END SUBROUTINE bindump2d
SUBROUTINE binread2d(nx,ny,filenm,var) 76,8
IMPLICIT NONE
INCLUDE 'mp.inc'
INTEGER :: nx,ny
! CHARACTER (LEN=*) :: varname, varunits
CHARACTER (LEN=40) :: varname1, varunits1
CHARACTER (LEN=*) :: filenm
REAL :: var(nx,ny)
INTEGER :: nx_in,ny_in,nz_in
INTEGER :: nunit,istat,ierr,iSTATUS
INTEGER :: nxlg, nylg, i,j
INTEGER :: readsplit0
REAL, ALLOCATABLE :: var2d(:,:)
readsplit0 = 1 ! hard coded to read joined 2D file
nxlg = (nx-3)*nproc_x+3
nylg = (ny-3)*nproc_y+3
ALLOCATE(var2d(nxlg,nylg))
iSTATUS = 0
IF ((mp_opt > 0 .AND. readsplit0 <= 0) .OR. myproc == 0) THEN
CALL getunit( nunit)
CALL asnctl ('NEWLOCAL', 1, ierr)
CALL asnfile(filenm, '-F f77 -N ieee', ierr)
OPEN(UNIT=nunit,FILE=trim(filenm),STATUS='old', FORM='unformatted', &
ERR=9000, IOSTAT=istat)
END IF
IF (readsplit0 > 0) CALL mpupdatei(istat, 1)
IF( istat /= 0 ) GO TO 998
IF (mp_opt > 0 .AND. readsplit0 > 0) THEN
IF (myproc == 0) THEN
READ(nunit, ERR=9000, END=9000, IOSTAT=istat) nx_in,ny_in,nz_in
IF(nx_in /= nxlg .OR. ny_in /= nylg .OR. nz_in /= 1) THEN
WRITE(6,'(a,/a,a,/a,3I5,/a,3I5)') &
'Warning in subroutine BINREAD2D: Dimensions of data file ', &
trim(filenm),' do not agree with the expected dimensions.', &
'nx, ny and nz in the data are ',nx_in,ny_in,nz_in, &
'nx, ny and nz expected are ',nxlg,nylg,1
CALL arpsstop('arpstop called from BINREAD2D nx-ny-nz read ',1)
END IF
READ(nunit, ERR=9000, END=9000, IOSTAT=istat) &
((var2d(i,j),i=1,nxlg),j=1,nylg)
READ(nunit, ERR=9000,END=9000,IOSTAT=istat) varname1
READ(nunit, ERR=9000,END=9000,IOSTAT=istat) varunits1
! varname = varname1
! varunits = varunits1
END IF
CALL mpisplit3d(var2d,nx,ny,1,var)
! CALL mpupdatec(varname,40)
! CALL mpupdatec(varunits,40)
ELSE
READ(nunit, ERR=9000, END=9000, IOSTAT=istat) nx_in,ny_in,nz_in
IF(nx_in /= nx .OR. ny_in /= ny .OR. nz_in /= 1) THEN
IF(myproc == 0) &
WRITE(6,'(a,/a,a,/a,3I5,/a,3I5)') &
'Warning in subroutine BINREAD2D: Dimensions of data file ', &
trim(filenm),' do not agree with the expected dimensions.', &
'nx, ny and nz in the data are ',nx_in,ny_in,nz_in, &
'nx, ny and nz expected are ',nx,ny,1
CALL arpsstop('arpstop called from BINREAD2D nx-ny-nz read ',1)
END IF
READ(nunit, ERR=9000, END=9000, IOSTAT=istat) var
READ(nunit, ERR=9000,END=9000,IOSTAT=istat) varname1
READ(nunit, ERR=9000,END=9000,IOSTAT=istat) varunits1
! varname = varname1
! varunits = varunits1
END IF
IF ((mp_opt > 0 .AND. readsplit0 <= 0) .OR. myproc == 0) THEN
CLOSE(UNIT=nunit)
CALL retunit(nunit)
END IF
DEALLOCATE(var2d)
RETURN
9000 CONTINUE ! I/O errors
CLOSE(UNIT=nunit)
CALL retunit(nunit)
IF (istat < 0) THEN
iSTATUS = 2
PRINT *, 'BINREAD2D: I/O ERRORS OCCURRED ', &
'(possible end of record or file): ',istat, iSTATUS
ELSE IF (istat > 0) THEN
iSTATUS = 2
PRINT *, 'BINREAD2D: UNRECOVERABLE I/O ERRORS OCCURRED: ', &
istat,iSTATUS
END IF
RETURN
998 CONTINUE
WRITE(6,'(1x,a,a,/1x,i3,a)') &
'Error occured when opening file ',trim(filenm), &
'using FORTRAN unit ',nunit,' Program stopped in BINREAD2D.'
CALL arpsstop('arpsstop called from BINREAD2D during file read',1)
END SUBROUTINE binread2d