restfilemod.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

    endif
#else 
! Read in data directly
    read (iu,iostat=ier) arr
    if (ier /= 0 ) then
       write(6,*) 'READIN3D_REAL error ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine readin3d_real

!=======================================================================

  subroutine wrtoutsc_int(iu, scalar)
!-----------------------------------------------------------------------
! Wrapper routine to read real scalar variable from restart binary file 
!------------------------------Arguments--------------------------------
    integer, intent(in) :: iu             !input unit
    integer, intent(in) :: scalar         !scalar to read in
!---------------------------Local variables-----------------------------
    integer ier                           !errorcode
!-----------------------------------------------------------------------
    if (masterproc) then
       write(iu, iostat=ier) scalar
       if (ier /= 0 ) then
          write(6,*) 'WRTOUT ieror ',ier,' on i/o unit = ',iu
          call endrun
       end if
    endif
    return
  end subroutine wrtoutsc_int

!=======================================================================

  subroutine wrtoutsc_log(iu, scalar)
!-----------------------------------------------------------------------
! Wrapper routine to read real scalar variable from restart binary file 
!------------------------------Arguments--------------------------------
    integer, intent(in) :: iu             !input unit
    logical, intent(in) :: scalar         !scalar to read in
!---------------------------Local variables-----------------------------
    integer ier                           !errorcode
!-----------------------------------------------------------------------
    if (masterproc) then
       write(iu, iostat=ier) scalar
       if (ier /= 0 ) then
          write(6,*) 'READIN ieror ',ier,' on i/o unit = ',iu
          call endrun
       end if
    endif
    return
  end subroutine wrtoutsc_log

!=======================================================================

  subroutine wrtoutsc_real(iu, scalar)
!-----------------------------------------------------------------------
! Wrapper routine to read real scalar variable from restart binary file 
!------------------------------Arguments--------------------------------
    integer , intent(in) :: iu           !input unit
    real(r8), intent(in) :: scalar       !scalar to read in
!---------------------------Local variables-----------------------------
    integer ier                          !errorcode
!-----------------------------------------------------------------------
    if (masterproc) then
       write(iu, iostat=ier) scalar
       if (ier /= 0 ) then
          write(6,*) 'WRTOUT ieror ',ier,' on i/o unit = ',iu
          call endrun
       end if
    endif
    return
  end subroutine wrtoutsc_real

!=======================================================================

  subroutine wrtout1d_int (iu, iarr)
!-----------------------------------------------------------------------
! Wrapper routine to write integer array to restart binary file 
!------------------------------Arguments--------------------------------
    integer, intent(in)  :: iu                     !input unit
    integer, intent(in)  :: iarr(begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                   !error code
#if (defined SPMD)
    integer, allocatable :: ibuf(:)
    integer :: numrecvv(0:npes-1)    !vector of items to be received  
    integer :: displsv(0:npes-1)     !displacement vector
    integer :: numsend               !number of items to be sent
!-----------------------------------------------------------------------
! Gather on master processor, write out record
    call compute_mpigs_patch(1, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(ibuf(numpatch))
       call mpi_gatherv (iarr(begpatch), numsend , mpiint, &
            ibuf, numrecvv, displsv, mpiint, 0, mpicom, ier)
       write (iu, iostat=ier) ibuf
       if (ier /= 0 ) then
          write(6,*) 'WRTOUT1D_INT error ',ier,' on i/o unit = ',iu; call endrun
       end if
       deallocate(ibuf)
    else
       call mpi_gatherv (iarr(begpatch), numsend , mpiint, &
            0._r8, numrecvv, displsv, mpiint, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) iarr
    if (ier /= 0 ) then
       write(6,*) 'WRTOUT1D_INT error ',ier,' on i/o unit = ',iu;  call endrun
    end if
#endif
    return
  end subroutine wrtout1d_int

!=======================================================================

  subroutine wrtout2d_int (iu, iarr, ndim1)
!-----------------------------------------------------------------------
! Wrapper routine to write integer array to restart binary file 
!------------------------------Arguments--------------------------------
    integer, intent(in) :: iu                            !input unit
    integer, intent(in) :: ndim1                         !dimension
    integer, intent(in) :: iarr(ndim1,begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                  !error code
#if (defined SPMD)
    integer, allocatable :: ibuf(:,:)
    integer :: numrecvv(0:npes-1)   !vector of items to be received  
    integer :: displsv(0:npes-1)    !displacement vector
    integer :: numsend              !number of items to be sent
!-----------------------------------------------------------------------
! Gather on master processor, write out record
    call compute_mpigs_patch(ndim1, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(ibuf(ndim1,numpatch))
       call mpi_gatherv (iarr(1,begpatch), numsend , mpiint, &
            ibuf, numrecvv, displsv, mpiint, 0, mpicom, ier)
       write (iu,iostat=ier) ibuf
       if (ier /= 0 ) then
          write (6,*) 'WRTOUT2D_INT errror ',ier,' on i/o unit = ',iu
          call endrun
       end if
       deallocate(ibuf)
    else
       call mpi_gatherv (iarr(1,begpatch), numsend , mpiint, &
            0._r8, numrecvv, displsv, mpiint, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) iarr
    if (ier /= 0 ) then
       write (6,*) 'WRTOUT2D_INT error ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine wrtout2d_int

!=======================================================================

  subroutine wrtout3d_int (iu, iarr, ndim1, ndim2)
!-----------------------------------------------------------------------
! Wrapper routine to write integer array to restart binary file 
!------------------------------Arguments--------------------------------
    integer, intent(in) :: iu                                  !input unit
    integer, intent(in) :: ndim1                               !dimension
    integer, intent(in) :: ndim2                               !dimension
    integer, intent(in) :: iarr(ndim1,ndim2,begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                  !error code
#if (defined SPMD)
    integer, allocatable :: ibuf(:,:,:)
    integer :: numrecvv(0:npes-1)   !vector of items to be received  
    integer :: displsv(0:npes-1)    !displacement vector
    integer :: numsend              !number of items to be sent
!-----------------------------------------------------------------------
! Gather on master processor, write out record
    call compute_mpigs_patch(ndim1*ndim2, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(ibuf(ndim1,ndim2,numpatch))
       call mpi_gatherv (iarr(1,1,begpatch), numsend , mpiint, &
            ibuf, numrecvv, displsv, mpiint, 0, mpicom, ier)
       write (iu,iostat=ier) ibuf
       if (ier /= 0 ) then
          write (6,*) 'WRTOUT3D_INT error ',ier,' on i/o unit = ',iu
          call endrun
       end if
       deallocate(ibuf)
    else
       call mpi_gatherv (iarr(1,1,begpatch), numsend , mpiint, &
            0._r8, numrecvv, displsv, mpiint, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) iarr
    if (ier /= 0 ) then
       write (6,*) 'WRTOUT3D_INT error ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine wrtout3d_int

!=======================================================================

  subroutine wrtout1d_real (iu, arr)
!-----------------------------------------------------------------------
! Wrapper routine to write real array to restart binary file 
!------------------------------Arguments--------------------------------
    integer , intent(in)  :: iu                     !input unit
    real(r8), intent(in)  :: arr(begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                   !error code     
#if (defined SPMD)
    real(r8), allocatable :: buf(:)
    integer  :: numrecvv(0:npes-1)   !vector of items to be received  
    integer  :: displsv(0:npes-1)    !displacement vector
    integer  :: numsend              !number of items to be sent
!-----------------------------------------------------------------------
! Gather on masterp processor, write out record
    call compute_mpigs_patch(1, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(buf(numpatch))
       call mpi_gatherv (arr(begpatch), numsend , mpir8, &
            buf, numrecvv, displsv, mpir8, 0, mpicom, ier)
       write (iu, iostat=ier) buf
       if (ier /= 0 ) then
          write (6,*) 'WRTOUT1D_REAL error ',ier,' on i/o unit = ',iu
          call endrun
       end if
       deallocate(buf)
    else
       call mpi_gatherv (arr(begpatch), numsend , mpir8, &
            0._r8, numrecvv, displsv, mpir8, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) arr
    if (ier /= 0 ) then
       write (6,*) 'WRTOUT1D_REAL error ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine wrtout1d_real

!=======================================================================

  subroutine wrtout2d_real (iu, arr, ndim1)
!-----------------------------------------------------------------------
! Wrapper routine to write real array to restart binary file 
!------------------------------Arguments--------------------------------
    integer , intent(in) :: iu                           !input unit
    integer , intent(in) :: ndim1                        !dimension
    real(r8), intent(in) :: arr(ndim1,begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                   !error code
#if (defined SPMD)
    real(r8), allocatable :: buf(:,:)
    integer  :: numrecvv(0:npes-1)   !vector of items to be received  
    integer  :: displsv(0:npes-1)    !displacement vector
    integer  :: numsend              !number of items to be sent
!-----------------------------------------------------------------------
! Gather on master processor, write out record
    call compute_mpigs_patch(ndim1, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(buf(ndim1,numpatch))
       call mpi_gatherv (arr(1,begpatch), numsend , mpir8, &
            buf, numrecvv, displsv, mpir8, 0, mpicom, ier)
       write (iu,iostat=ier) buf
       if (ier /= 0 ) then
          write (6,*) 'WRTOUT ieror ',ier,' on i/o unit = ',iu
          call endrun
       end if
       deallocate(buf)
    else
       call mpi_gatherv (arr(1,begpatch), numsend , mpir8, &
            0._r8, numrecvv, displsv, mpir8, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) arr
    if (ier /= 0 ) then
       write (6,*) 'WRTOUT ieror ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine wrtout2d_real

!=======================================================================

  subroutine wrtout3d_real (iu, arr, ndim1, ndim2)
!-----------------------------------------------------------------------
! Wrapper routine to write real array to restart binary file 
!------------------------------Arguments--------------------------------
    integer , intent(in) :: iu                     !input unit
    integer , intent(in) :: ndim1                  !dimension
    integer , intent(in) :: ndim2                  !dimension
    real(r8), intent(in) :: arr(ndim1,ndim2,begpatch:endpatch) !output data
!---------------------------Local variables-----------------------------
    integer :: ier                  !error code
#if (defined SPMD) 
    real(r8), allocatable :: buf(:,:,:)
    integer :: numrecvv(0:npes-1)   !vector of items to be received  
    integer :: displsv(0:npes-1)    !displacement vector
    integer :: numsend              !number of items to be sent
!-----------------------------------------------------------------------
! Gather on master processor, write out record
    call compute_mpigs_patch(ndim1*ndim2, numsend, numrecvv, displsv)
    if (masterproc) then
       allocate(buf(ndim1,ndim2,numpatch))
       call mpi_gatherv (arr(1,1,begpatch), numsend , mpir8, &
            buf, numrecvv, displsv, mpir8, 0, mpicom, ier)
       write (iu,iostat=ier) buf
       if (ier /= 0 ) then
          write (6,*) 'WRTOUT3D_REAL error ',ier,' on i/o unit = ',iu
          call endrun
       end if
       deallocate(buf)
    else
       call mpi_gatherv (arr(1,1,begpatch), numsend , mpir8, &
            0._r8, numrecvv, displsv, mpir8, 0, mpicom, ier)
    endif
#else 
! Write out array directly
    write (iu,iostat=ier) arr
    if (ier /= 0 ) then
       write (6,*) 'WRTOUT3D_REAL error ',ier,' on i/o unit = ',iu
       call endrun
    end if
#endif
    return
  end subroutine wrtout3d_real

!=======================================================================
! END GENERIC PROCEDURE DEFINITIONS
!=======================================================================

end module restFileMod