external/io_adios2/field_routines.F90

   1 !*----------------------------------------------------------------------------
   2 !*
   3 !*  WRF ADIOS2 I/O
   4 !*  Author: Michael Laufer
   5 !*          Toga Networks, a Huawei Company
   6 !*          michael.laufer@toganetworks.com
   7 !*  Author: Erick Fredj
   8 !*          Computer Science Department, The Jerusalem College of Technology
   9 !*          fredj@jct.ac.il
  10 !*          Toga Networks, a Huawei Company
  11 !*          erick.fredj@toganetworks.com
  12 !*
  13 !*  Date:    November 3, 2021
  14 !*
  15 !*----------------------------------------------------------------------------
  16
  17 subroutine ext_adios2_RealFieldIO(IO,DataHandle,VarID,VStart,VCount,Data,Status)
  18   use wrf_data_adios2
  19   use ext_adios2_support_routines
  20   use adios2
  21   implicit none
  22   include 'wrf_status_codes.h'
  23   character (*)                       ,intent(in)          :: IO
  24   integer                             ,intent(in)          :: DataHandle
  25   type(adios2_variable)               ,intent(in)          :: VarID
  26   integer(kind=8),dimension(NVarDims) ,intent(in)          :: VStart
  27   integer(kind=8),dimension(NVarDims) ,intent(in)          :: VCount
  28   real                                ,intent(inout)       :: Data
  29   integer                             ,intent(out)         :: Status
  30   integer                                                  :: stat
  31   type(wrf_data_handle),pointer                            :: DH
  32   integer(kind=8),dimension(NVarDims)                      :: VStart_mpi, VCount_mpi
  33
  34   !start arrays should start at 0 for ADIOS2
  35   VStart_mpi = VStart - 1
  36   VCount_mpi = VCount
  37   call GetDH(DataHandle,DH,Status)
  38   if(Status /= WRF_NO_ERR) then
  39     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_RealFieldIO ',__FILE__,', line', __LINE__
  40     call wrf_debug ( WARN , TRIM(msg))
  41     return
  42   endif
  43   !adios2_set_selection to set start dims and count dims
  44   call adios2_set_selection(VarID, VarID%ndims, VStart_mpi, VCount_mpi, stat)
  45   call adios2_err(stat,Status)
  46   if(Status /= WRF_NO_ERR) then
  47     write(msg,*) 'adios2 error in ext_adios2_RealFieldIO ',__FILE__,', line', __LINE__
  48     call wrf_debug ( WARN , TRIM(msg))
  49     return
  50   endif
  51   if(IO == 'write') then
  52     call adios2_put(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
  53   else
  54     call adios2_get(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
  55   endif
  56   call adios2_err(stat,Status)
  57   if(Status /= WRF_NO_ERR) then
  58     write(msg,*) 'adios2 error in ext_adios2_RealFieldIO ',__FILE__,', line', __LINE__
  59     call wrf_debug ( WARN , TRIM(msg))
  60     return
  61   endif
  62 end subroutine ext_adios2_RealFieldIO
  63
  64 subroutine ext_adios2_DoubleFieldIO(IO,DataHandle,VarID,VStart,VCount,Data,Status)
  65   use wrf_data_adios2
  66   use ext_adios2_support_routines
  67   use adios2
  68   implicit none
  69   include 'wrf_status_codes.h'
  70   character (*)                        ,intent(in)           :: IO
  71   integer                              ,intent(in)           :: DataHandle
  72   type(adios2_variable)                ,intent(in)           :: VarID
  73   integer(kind=8) ,dimension(NVarDims) ,intent(in)           :: VStart
  74   integer(kind=8) ,dimension(NVarDims) ,intent(in)           :: VCount
  75   real*8                               ,intent(inout)        :: Data
  76   integer                              ,intent(out)          :: Status
  77   integer                                                    :: stat
  78   type(wrf_data_handle),pointer                              :: DH
  79   integer(kind=8),dimension(NVarDims)                        :: VStart_mpi, VCount_mpi
  80
  81   !start arrays should start at 0 for ADIOS2
  82   VStart_mpi = VStart - 1
  83   VCount_mpi = VCount
  84   call GetDH(DataHandle,DH,Status)
  85   if(Status /= WRF_NO_ERR) then
  86     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_DoubleFieldIO ',__FILE__,', line', __LINE__
  87     call wrf_debug ( WARN , TRIM(msg))
  88     return
  89   endif
  90   !adios2_set_selection to set start dims and count dims
  91   call adios2_set_selection(VarID, VarID%ndims, VStart_mpi, VCount_mpi, stat)
  92   call adios2_err(stat,Status)
  93   if(Status /= WRF_NO_ERR) then
  94     write(msg,*) 'adios2 error in ext_adios2_DoubleFieldIO ',__FILE__,', line', __LINE__
  95     call wrf_debug ( WARN , TRIM(msg))
  96     return
  97   endif
  98   if(IO == 'write') then
  99     call adios2_put(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
 100   else
 101     call adios2_get(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
 102   endif
 103   call adios2_err(stat,Status)
 104   if(Status /= WRF_NO_ERR) then
 105     write(msg,*) 'adios2 error in ext_adios2_DoubleFieldIO ',__FILE__,', line', __LINE__
 106     call wrf_debug ( WARN , TRIM(msg))
 107     return
 108   endif
 109   end subroutine ext_adios2_DoubleFieldIO
 110
 111 subroutine ext_adios2_IntFieldIO(IO,DataHandle,VarID,VStart,VCount,Data,Status)
 112   use wrf_data_adios2
 113   use ext_adios2_support_routines
 114   use adios2
 115   implicit none
 116   include 'wrf_status_codes.h'
 117   character (*)                        ,intent(in)          :: IO
 118   integer                              ,intent(in)          :: DataHandle
 119   type(adios2_variable)                ,intent(in)          :: VarID
 120   integer(kind=8) ,dimension(NVarDims) ,intent(in)          :: VStart
 121   integer(kind=8) ,dimension(NVarDims) ,intent(in)          :: VCount
 122   integer                              ,intent(inout)       :: Data
 123   integer                              ,intent(out)         :: Status
 124   integer                                                   :: stat
 125   type(wrf_data_handle),pointer                             :: DH
 126   integer(kind=8),dimension(NVarDims)                       :: VStart_mpi, VCount_mpi
 127
 128   !start arrays should start at 0 for ADIOS2
 129   VStart_mpi = VStart - 1
 130   VCount_mpi = VCount
 131   call GetDH(DataHandle,DH,Status)
 132   if(Status /= WRF_NO_ERR) then
 133     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_IntFieldIO ',__FILE__,', line', __LINE__
 134     call wrf_debug ( WARN , TRIM(msg))
 135     return
 136   endif
 137   !adios2_set_selection to set start dims and count dims
 138   call adios2_set_selection(VarID, VarID%ndims, VStart_mpi, VCount_mpi, stat)
 139   call adios2_err(stat,Status)
 140   if(Status /= WRF_NO_ERR) then
 141     write(msg,*) 'adios2 error in ext_adios2_IntFieldIO ',__FILE__,', line', __LINE__
 142     call wrf_debug ( WARN , TRIM(msg))
 143     return
 144   endif
 145   if(IO == 'write') then
 146     call adios2_put(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
 147   else
 148     call adios2_get(DH%adios2Engine, VarID, Data, adios2_mode_sync, stat)
 149   endif
 150   call adios2_err(stat,Status)
 151   if(Status /= WRF_NO_ERR) then
 152     write(msg,*) 'adios2 error in ext_adios2_IntFieldIO ',__FILE__,', line', __LINE__
 153     call wrf_debug ( WARN , TRIM(msg))
 154     return
 155   endif
 156 end subroutine ext_adios2_IntFieldIO
 157
 158 subroutine ext_adios2_LogicalFieldIO(IO,DataHandle,VarID,VStart,VCount,Data,Status)
 159   use wrf_data_adios2
 160   use ext_adios2_support_routines
 161   use adios2
 162   implicit none
 163   include 'wrf_status_codes.h'
 164   character (*)                                    ,intent(in)         :: IO
 165   integer                                          ,intent(in)         :: DataHandle
 166   type(adios2_variable)                            ,intent(in)         :: VarID
 167   integer(kind=8) ,dimension(NVarDims)             ,intent(in)         :: VStart
 168   integer(kind=8) ,dimension(NVarDims)             ,intent(in)         :: VCount
 169   logical,dimension(VCount(1),VCount(2),VCount(3)) ,intent(inout)      :: Data
 170   integer                                          ,intent(out)        :: Status
 171   integer                                                              :: stat
 172   type(wrf_data_handle),pointer                                        :: DH
 173   integer,dimension(:,:,:),allocatable                                 :: Buffer
 174   integer                                                              :: i,j,k
 175   integer(kind=8),dimension(NVarDims)                                  :: VStart_mpi, VCount_mpi
 176
 177   !start arrays should start at 0 for ADIOS2
 178   VStart_mpi = VStart - 1
 179   VCount_mpi = VCount
 180   call GetDH(DataHandle,DH,Status)
 181   if(Status /= WRF_NO_ERR) then
 182     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_LogicalFieldIO ',__FILE__,', line', __LINE__
 183     call wrf_debug ( WARN , TRIM(msg))
 184     return
 185   endif
 186   !adios2_set_selection to set start dims and count dims
 187   call adios2_set_selection(VarID, VarID%ndims, VStart_mpi, VCount_mpi, stat)
 188   call adios2_err(stat,Status)
 189   if(Status /= WRF_NO_ERR) then
 190     write(msg,*) 'adios2 error in ext_adios2_LogicalFieldIO ',__FILE__,', line', __LINE__
 191   call wrf_debug ( WARN , TRIM(msg))
 192   return
 193   endif
 194   allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
 195   if(stat/= 0) then
 196     Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 197     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 198     call wrf_debug ( FATAL , msg)
 199     return
 200   endif
 201   if(IO == 'write') then
 202     do k=1,VCount(3)
 203       do j=1,VCount(2)
 204         do i=1,VCount(1)
 205           if(data(i,j,k)) then
 206             Buffer(i,j,k)=1
 207           else
 208             Buffer(i,j,k)=0
 209           endif
 210         enddo
 211       enddo
 212     enddo
 213     call adios2_put(DH%adios2Engine, VarID, Buffer, adios2_mode_sync, stat)
 214     call adios2_err(stat,Status)
 215     if(Status /= WRF_NO_ERR) then
 216       write(msg,*) 'adios2 error in ext_adios2_LogicalFieldIO ',__FILE__,', line', __LINE__
 217       call wrf_debug ( WARN , TRIM(msg))
 218       return
 219     endif
 220   else
 221     call adios2_get(DH%adios2Engine, VarID, Buffer, adios2_mode_sync, stat)
 222     call adios2_err(stat,Status)
 223     if(Status /= WRF_NO_ERR) then
 224       write(msg,*) 'adios2 error in ext_adios2_LogicalFieldIO ',__FILE__,', line', __LINE__
 225       call wrf_debug ( WARN , TRIM(msg))
 226       return
 227     endif
 228     Data = Buffer == 1
 229   endif
 230   deallocate(Buffer, STAT=stat)
 231   if(stat/= 0) then
 232     Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 233     write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 234     call wrf_debug ( FATAL , msg)
 235     return
 236   endif
 237   return
 238 end subroutine ext_adios2_LogicalFieldIO