external/io_pnetcdf/field_routines.F90

   1 !*------------------------------------------------------------------------------
   2 !*  Standard Disclaimer
   3 !*
   4 !*  Forecast Systems Laboratory
   5 !*  NOAA/OAR/ERL/FSL
   6 !*  325 Broadway
   7 !*  Boulder, CO     80303
   8 !*
   9 !*  AVIATION DIVISION
  10 !*  ADVANCED COMPUTING BRANCH
  11 !*  SMS/NNT Version: 2.0.0
  12 !*
  13 !*  This software and its documentation are in the public domain and
  14 !*  are furnished "as is".  The United States government, its
  15 !*  instrumentalities, officers, employees, and agents make no
  16 !*  warranty, express or implied, as to the usefulness of the software
  17 !*  and documentation for any purpose.  They assume no
  18 !*  responsibility (1) for the use of the software and documentation;
  19 !*  or (2) to provide technical support to users.
  20 !*
  21 !*  Permission to use, copy, modify, and distribute this software is
  22 !*  hereby granted, provided that this disclaimer notice appears in
  23 !*  all copies.  All modifications to this software must be clearly
  24 !*  documented, and are solely the responsibility of the agent making
  25 !*  the modification.  If significant modifications or enhancements
  26 !*  are made to this software, the SMS Development team
  27 !*  (sms-info@fsl.noaa.gov) should be notified.
  28 !*
  29 !*----------------------------------------------------------------------------
  30 !*
  31 !*  WRF NetCDF I/O
  32 !   Author:  Jacques Middlecoff jacquesm@fsl.noaa.gov
  33 !*  Date:    October 6, 2000
  34 !*
  35 !*----------------------------------------------------------------------------
  36 subroutine ext_pnc_RealFieldIO(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
  37   use wrf_data_pnc
  38   use ext_pnc_support_routines
  39   implicit none
  40   include 'wrf_status_codes.h'
  41 #  include "pnetcdf.inc"
  42   logical                     ,intent(in)    :: Coll
  43   character (*)               ,intent(in)    :: IO
  44   integer                     ,intent(in)    :: NCID
  45   integer                     ,intent(in)    :: VarID
  46   integer ,dimension(NVarDims),intent(in)    :: VStart
  47   integer ,dimension(NVarDims),intent(in)    :: VCount
  48   real, dimension(*)          ,intent(inout) :: Data
  49   integer                     ,intent(out)   :: Status
  50   integer                                    :: stat
  51 !local
  52   integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims)    :: VStart_mpi, VCount_mpi
  53   VStart_mpi = VStart
  54   VCount_mpi = VCount
  55
  56   if(IO == 'write') then
  57     if(Coll)then
  58       stat = NFMPI_PUT_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
  59     else
  60       stat = NFMPI_PUT_VARA_REAL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
  61     end if
  62   else
  63     if(Coll)then
  64       stat = NFMPI_GET_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
  65    else
  66       stat = NFMPI_GET_VARA_REAL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
  67    end if
  68   endif
  69   call netcdf_err(stat,Status)
  70   if(Status /= WRF_NO_ERR) then
  71     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
  72     call wrf_debug ( WARN , msg)
  73   endif
  74   return
  75 end subroutine ext_pnc_RealFieldIO
  76
  77 subroutine ext_pnc_DoubleFieldIO(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
  78   use wrf_data_pnc
  79   use ext_pnc_support_routines
  80   implicit none
  81   include 'wrf_status_codes.h'
  82 #  include "pnetcdf.inc"
  83   logical                     ,intent(in)    :: Coll
  84   character (*)               ,intent(in)    :: IO
  85   integer                     ,intent(in)    :: NCID
  86   integer                     ,intent(in)    :: VarID
  87   integer ,dimension(NVarDims),intent(in)    :: VStart
  88   integer ,dimension(NVarDims),intent(in)    :: VCount
  89   real*8                      ,intent(inout) :: Data
  90   integer                     ,intent(out)   :: Status
  91   integer                                    :: stat
  92 !local
  93   integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims)    :: VStart_mpi, VCount_mpi
  94   VStart_mpi = VStart
  95   VCount_mpi = VCount
  96
  97   if(IO == 'write') then
  98     if(Coll)then
  99       stat = NFMPI_PUT_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 100    else
 101       stat = NFMPI_PUT_VARA_DOUBLE(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 102    endif
 103   else
 104     if(Coll)then
 105       stat = NFMPI_GET_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 106    else
 107       stat = NFMPI_GET_VARA_DOUBLE(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 108    endif
 109   endif
 110   call netcdf_err(stat,Status)
 111   if(Status /= WRF_NO_ERR) then
 112     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 113     call wrf_debug ( WARN , msg)
 114   endif
 115   return
 116 end subroutine ext_pnc_DoubleFieldIO
 117
 118 subroutine ext_pnc_IntFieldIO(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
 119   use wrf_data_pnc
 120   use ext_pnc_support_routines
 121   implicit none
 122   include 'wrf_status_codes.h'
 123 #  include "pnetcdf.inc"
 124   logical                     ,intent(in)    :: Coll
 125   character (*)               ,intent(in)    :: IO
 126   integer                     ,intent(in)    :: NCID
 127   integer                     ,intent(in)    :: VarID
 128   integer ,dimension(NVarDims),intent(in)    :: VStart
 129   integer ,dimension(NVarDims),intent(in)    :: VCount
 130   integer                     ,intent(inout) :: Data
 131   integer                     ,intent(out)   :: Status
 132   integer                                    :: stat
 133 !local
 134   integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims)    :: VStart_mpi, VCount_mpi
 135   VStart_mpi = VStart
 136   VCount_mpi = VCount
 137
 138   if(IO == 'write') then
 139     if(Coll)then
 140       stat = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 141     else
 142       stat = NFMPI_PUT_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 143     endif
 144   else
 145     if(Coll)then
 146       stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 147    else
 148       stat = NFMPI_GET_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Data)
 149    end if
 150   endif
 151   call netcdf_err(stat,Status)
 152   if(Status /= WRF_NO_ERR) then
 153     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 154     call wrf_debug ( WARN , msg)
 155   endif
 156   return
 157 end subroutine ext_pnc_IntFieldIO
 158
 159 subroutine ext_pnc_LogicalFieldIO(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
 160   use wrf_data_pnc
 161   use ext_pnc_support_routines
 162   implicit none
 163   include 'wrf_status_codes.h'
 164 #  include "pnetcdf.inc"
 165   logical                                         ,intent(in)    :: Coll
 166   character (*)                                   ,intent(in)    :: IO
 167   integer                                         ,intent(in)    :: NCID
 168   integer                                         ,intent(in)    :: VarID
 169   integer,dimension(NVarDims)                     ,intent(in)    :: VStart
 170   integer,dimension(NVarDims)                     ,intent(in)    :: VCount
 171   logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data
 172   integer                                         ,intent(out)   :: Status
 173   integer,dimension(:,:,:),allocatable                           :: Buffer
 174   integer                                                        :: stat
 175   integer                                                        :: i,j,k
 176 !local
 177   integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims)    :: VStart_mpi, VCount_mpi
 178   VStart_mpi = VStart
 179   VCount_mpi = VCount
 180
 181   allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
 182   if(stat/= 0) then
 183     Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 184     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 185     call wrf_debug ( FATAL , msg)
 186     return
 187   endif
 188   if(IO == 'write') then
 189     do k=1,VCount(3)
 190       do j=1,VCount(2)
 191         do i=1,VCount(1)
 192           if(data(i,j,k)) then
 193             Buffer(i,j,k)=1
 194           else
 195             Buffer(i,j,k)=0
 196           endif
 197         enddo
 198       enddo
 199     enddo
 200     if(Coll)then
 201       stat = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
 202    else
 203       stat = NFMPI_PUT_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
 204    end if
 205   else
 206     if(Coll)then
 207       stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
 208     else
 209       stat = NFMPI_GET_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
 210     end if
 211     Data = Buffer == 1
 212   endif
 213   call netcdf_err(stat,Status)
 214   if(Status /= WRF_NO_ERR) then
 215     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 216     call wrf_debug ( WARN , msg)
 217     return
 218   endif
 219   deallocate(Buffer, STAT=stat)
 220   if(stat/= 0) then
 221     Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 222     write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 223     call wrf_debug ( FATAL , msg)
 224     return
 225   endif
 226   return
 227 end subroutine ext_pnc_LogicalFieldIO