external/io_netcdfpar/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_ncdpar_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
  37   use wrf_data_ncpar
  38   use ext_ncdpar_support_routines
  39   implicit none
  40   include 'wrf_status_codes.h'
  41   include 'netcdf.inc'
  42   character (*)               ,intent(in)    :: IO
  43   integer                     ,intent(in)    :: NCID
  44   integer                     ,intent(in)    :: VarID
  45   integer ,dimension(NVarDims),intent(in)    :: VStart
  46   integer ,dimension(NVarDims),intent(in)    :: VCount
  47   real, dimension(*)          ,intent(inout) :: Data
  48   integer                     ,intent(out)   :: Status
  49   integer                                    :: stat
  50   character(len=180)     :: errmsg
  51   integer i
  52
  53   if(IO == 'write') then
  54   !  write(0,*) 'vstart = ',vstart
  55   !  write(0,*) 'vcount = ',vcount
  56   !  write(0,*) 'varid = ',varid
  57   !  i = vcount(1)*vcount(2)
  58   !  write(0,*) 'data ',data(1),data(i)
  59     !write(0,*) 'data size = ',size(data)
  60     stat = NF_VAR_PAR_ACCESS(ncid,VarID,nf_collective)
  61     call netcdf_err(stat,Status)
  62     if ( Status /= WRF_NO_ERR) then
  63       write(0,*) 'error setting par_access'
  64     ENDIF
  65   !  write(0,*) 'call put_vara'
  66     stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data)
  67   !  write(0,*) 'done put_vara'
  68   else
  69     stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data)
  70   endif
  71   call netcdf_err(stat,Status)
  72   if(Status /= WRF_NO_ERR) then
  73         errmsg = NF_STRERROR(stat)
  74     write(0,*) 'error = ',errmsg
  75     write(0,*) 'vstart = ',vstart
  76     write(0,*) 'vcount = ',vcount
  77     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
  78     call wrf_debug ( WARN , msg)
  79   endif
  80   !write(0,*) 'barrier 1'
  81   !call mpi_barrier(MPI_COMM_WORLD,i)
  82   !write(0,*) 'barrier 2'
  83   return
  84 end subroutine ext_ncdpar_RealFieldIO
  85
  86 subroutine ext_ncdpar_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
  87   use wrf_data_ncpar
  88   use ext_ncdpar_support_routines
  89   implicit none
  90   include 'wrf_status_codes.h'
  91   include 'netcdf.inc'
  92   character (*)               ,intent(in)    :: IO
  93   integer                     ,intent(in)    :: NCID
  94   integer                     ,intent(in)    :: VarID
  95   integer ,dimension(NVarDims),intent(in)    :: VStart
  96   integer ,dimension(NVarDims),intent(in)    :: VCount
  97   real*8                      ,intent(inout) :: Data
  98   integer                     ,intent(out)   :: Status
  99   integer                                    :: stat
 100
 101   if(IO == 'write') then
 102     stat = NF_VAR_PAR_ACCESS(ncid,VarID,nf_collective)
 103     stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
 104   else
 105     stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
 106   endif
 107   call netcdf_err(stat,Status)
 108   if(Status /= WRF_NO_ERR) then
 109     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 110     call wrf_debug ( WARN , msg)
 111   endif
 112   return
 113 end subroutine ext_ncdpar_DoubleFieldIO
 114
 115 subroutine ext_ncdpar_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
 116   use wrf_data_ncpar
 117   use ext_ncdpar_support_routines
 118   implicit none
 119   include 'wrf_status_codes.h'
 120   include 'netcdf.inc'
 121   character (*)               ,intent(in)    :: IO
 122   integer                     ,intent(in)    :: NCID
 123   integer                     ,intent(in)    :: VarID
 124   integer ,dimension(NVarDims),intent(in)    :: VStart
 125   integer ,dimension(NVarDims),intent(in)    :: VCount
 126   integer                     ,intent(inout) :: Data
 127   integer                     ,intent(out)   :: Status
 128   integer                                    :: stat
 129
 130   if(IO == 'write') then
 131     stat = NF_VAR_PAR_ACCESS(ncid,VarID,nf_collective)
 132     stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data)
 133   else
 134     stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data)
 135   endif
 136   call netcdf_err(stat,Status)
 137   if(Status /= WRF_NO_ERR) then
 138     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 139     call wrf_debug ( WARN , msg)
 140   endif
 141   return
 142 end subroutine ext_ncdpar_IntFieldIO
 143
 144 subroutine ext_ncdpar_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
 145   use wrf_data_ncpar
 146   use ext_ncdpar_support_routines
 147   implicit none
 148   include 'wrf_status_codes.h'
 149   include 'netcdf.inc'
 150   character (*)                                   ,intent(in)    :: IO
 151   integer                                         ,intent(in)    :: NCID
 152   integer                                         ,intent(in)    :: VarID
 153   integer,dimension(NVarDims)                     ,intent(in)    :: VStart
 154   integer,dimension(NVarDims)                     ,intent(in)    :: VCount
 155   logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data
 156   integer                                         ,intent(out)   :: Status
 157   integer,dimension(:,:,:),allocatable                           :: Buffer
 158   integer                                                        :: stat
 159   integer                                                        :: i,j,k
 160
 161   allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
 162   if(stat/= 0) then
 163     Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 164     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 165     call wrf_debug ( FATAL , msg)
 166     return
 167   endif
 168   if(IO == 'write') then
 169     do k=1,VCount(3)
 170       do j=1,VCount(2)
 171         do i=1,VCount(1)
 172           if(data(i,j,k)) then
 173             Buffer(i,j,k)=1
 174           else
 175             Buffer(i,j,k)=0
 176           endif
 177         enddo
 178       enddo
 179     enddo
 180     stat = NF_VAR_PAR_ACCESS(ncid,VarID,nf_collective)
 181     stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
 182   else
 183     stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
 184     Data = Buffer == 1
 185   endif
 186   call netcdf_err(stat,Status)
 187   if(Status /= WRF_NO_ERR) then
 188     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 189     call wrf_debug ( WARN , msg)
 190     return
 191   endif
 192   deallocate(Buffer, STAT=stat)
 193   if(stat/= 0) then
 194     Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 195     write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 196     call wrf_debug ( FATAL , msg)
 197     return
 198   endif
 199   return
 200 end subroutine ext_ncdpar_LogicalFieldIO