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