external/io_netcdf/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_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
  37   use wrf_data
  38   use ext_ncd_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
  51   if(IO == 'write') then
  52     stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data)
  53   else
  54     stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data)
  55   endif
  56   call netcdf_err(stat,Status)
  57   if(Status /= WRF_NO_ERR) then
  58     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
  59     call wrf_debug ( WARN , msg)
  60   endif
  61   return
  62 end subroutine ext_ncd_RealFieldIO
  63
  64 subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
  65   use wrf_data
  66   use ext_ncd_support_routines
  67   implicit none
  68   include 'wrf_status_codes.h'
  69   include 'netcdf.inc'
  70   character (*)               ,intent(in)    :: IO
  71   integer                     ,intent(in)    :: NCID
  72   integer                     ,intent(in)    :: VarID
  73   integer ,dimension(NVarDims),intent(in)    :: VStart
  74   integer ,dimension(NVarDims),intent(in)    :: VCount
  75   real*8                      ,intent(inout) :: Data
  76   integer                     ,intent(out)   :: Status
  77   integer                                    :: stat
  78
  79   if(IO == 'write') then
  80     stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
  81   else
  82     stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
  83   endif
  84   call netcdf_err(stat,Status)
  85   if(Status /= WRF_NO_ERR) then
  86     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
  87     call wrf_debug ( WARN , msg)
  88   endif
  89   return
  90 end subroutine ext_ncd_DoubleFieldIO
  91
  92 subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
  93   use wrf_data
  94   use ext_ncd_support_routines
  95   implicit none
  96   include 'wrf_status_codes.h'
  97   include 'netcdf.inc'
  98   character (*)               ,intent(in)    :: IO
  99   integer                     ,intent(in)    :: NCID
 100   integer                     ,intent(in)    :: VarID
 101   integer ,dimension(NVarDims),intent(in)    :: VStart
 102   integer ,dimension(NVarDims),intent(in)    :: VCount
 103   integer                     ,intent(inout) :: Data
 104   integer                     ,intent(out)   :: Status
 105   integer                                    :: stat
 106
 107   if(IO == 'write') then
 108     stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data)
 109   else
 110     stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data)
 111   endif
 112   call netcdf_err(stat,Status)
 113   if(Status /= WRF_NO_ERR) then
 114     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 115     call wrf_debug ( WARN , msg)
 116   endif
 117   return
 118 end subroutine ext_ncd_IntFieldIO
 119
 120 subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
 121   use wrf_data
 122   use ext_ncd_support_routines
 123   implicit none
 124   include 'wrf_status_codes.h'
 125   include 'netcdf.inc'
 126   character (*)                                   ,intent(in)    :: IO
 127   integer                                         ,intent(in)    :: NCID
 128   integer                                         ,intent(in)    :: VarID
 129   integer,dimension(NVarDims)                     ,intent(in)    :: VStart
 130   integer,dimension(NVarDims)                     ,intent(in)    :: VCount
 131   logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data
 132   integer                                         ,intent(out)   :: Status
 133   integer,dimension(:,:,:),allocatable                           :: Buffer
 134   integer                                                        :: stat
 135   integer                                                        :: i,j,k
 136
 137   allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
 138   if(stat/= 0) then
 139     Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 140     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 141     call wrf_debug ( FATAL , msg)
 142     return
 143   endif
 144   if(IO == 'write') then
 145     do k=1,VCount(3)
 146       do j=1,VCount(2)
 147         do i=1,VCount(1)
 148           if(data(i,j,k)) then
 149             Buffer(i,j,k)=1
 150           else
 151             Buffer(i,j,k)=0
 152           endif
 153         enddo
 154       enddo
 155     enddo
 156     stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
 157   else
 158     stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
 159     Data = Buffer == 1
 160   endif
 161   call netcdf_err(stat,Status)
 162   if(Status /= WRF_NO_ERR) then
 163     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 164     call wrf_debug ( WARN , msg)
 165     return
 166   endif
 167   deallocate(Buffer, STAT=stat)
 168   if(stat/= 0) then
 169     Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 170     write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 171     call wrf_debug ( FATAL , msg)
 172     return
 173   endif
 174   return
 175 end subroutine ext_ncd_LogicalFieldIO