external/io_adios2/ext_adios2_put_dom_ti.code

   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   use wrf_data_adios2
  18   use ext_adios2_support_routines
  19   use adios2
  20   implicit none
  21   include 'wrf_status_codes.h'
  22   integer               ,intent(in)     :: DataHandle
  23   character*(*)         ,intent(in)     :: Element
  24   TYPE_COUNT
  25   TYPE_DATA
  26   integer               ,intent(out)    :: Status
  27   type(wrf_data_handle) ,pointer        :: DH
  28   integer                               :: stat
  29   integer                               :: stat2
  30   integer               ,allocatable    :: Buffer(:)
  31   integer                               :: i
  32   type(adios2_attribute)                :: AttributeID
  33
  34   call GetDH(DataHandle,DH,Status)
  35   if(Status /= WRF_NO_ERR) then
  36     write(msg,*) &
  37 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  38     call wrf_debug ( WARN , msg)
  39     return
  40   endif
  41 IF ( adios2_ok_to_put_dom_ti( DataHandle ) ) THEN
  42   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
  43     Status = WRF_WARN_FILE_NOT_OPENED
  44     write(msg,*) &
  45 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  46     call wrf_debug ( WARN , msg)
  47   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
  48     STATUS = WRF_WARN_WRITE_RONLY_FILE
  49     write(msg,*) &
  50 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  51     call wrf_debug ( WARN , msg)
  52   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
  53 #ifdef LOG
  54       allocate(Buffer(Count), STAT=stat)
  55       if(stat/= 0) then
  56         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
  57         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  58         call wrf_debug ( FATAL , msg)
  59         return
  60       endif
  61       do i=1,Count
  62         if(data(i)) then
  63            Buffer(i)=1
  64         else
  65            Buffer(i)=0
  66         endif
  67       enddo
  68       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Buffer, Count, stat)
  69       call adios2_err(stat,Status)
  70       if(Status /= WRF_NO_ERR) then
  71         write(msg,*) 'adios2 error in ext_adios2_put_dom_ti',__FILE__,', line', __LINE__
  72         call wrf_debug ( WARN , TRIM(msg))
  73         return
  74       endif
  75       deallocate(Buffer, STAT=stat2)
  76       if(stat2/= 0) then
  77         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
  78         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  79         call wrf_debug ( FATAL , msg)
  80         return
  81       endif
  82 #else
  83 #ifdef CHAR_TYPE
  84       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Data, stat)
  85 #else
  86       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Data, Count, stat)
  87 #endif
  88       call adios2_err(stat,Status)
  89       if(Status /= WRF_NO_ERR) then
  90         write(msg,*) 'adios2 error in ext_adios2_put_dom_ti ',__FILE__,', line', __LINE__
  91         call wrf_debug ( WARN , TRIM(msg))
  92         return
  93       endif
  94 #endif
  95   elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
  96 #ifdef LOG
  97       allocate(Buffer(Count), STAT=stat)
  98       if(stat/= 0) then
  99         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 100         write(msg,*) &
 101 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 102         call wrf_debug ( FATAL , msg)
 103         return
 104       endif
 105       do i=1,Count
 106         if(data(i)) then
 107            Buffer(i)=1
 108         else
 109            Buffer(i)=0
 110         endif
 111       enddo
 112       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Buffer, Count, stat)
 113       call adios2_err(stat,Status)
 114       if(Status /= WRF_NO_ERR) then
 115         write(msg,*) 'adios2 error in ext_adios2_put_dom_ti ',__FILE__,', line', __LINE__
 116         call wrf_debug ( WARN , TRIM(msg))
 117         return
 118       endif
 119       deallocate(Buffer, STAT=stat2)
 120       if(stat2/= 0) then
 121         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 122         write(msg,*) &
 123 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 124         call wrf_debug ( FATAL , msg)
 125         return
 126       endif
 127 #else
 128 #ifdef CHAR_TYPE
 129       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Data, stat)
 130 #else
 131       call adios2_define_attribute(AttributeID, DH%adios2IO, Element, Data, Count, stat)
 132 #endif
 133       call adios2_err(stat,Status)
 134       if(Status /= WRF_NO_ERR) then
 135         write(msg,*) 'adios2 error in ext_adios2_put_dom_ti ',__FILE__,', line', __LINE__
 136         call wrf_debug ( WARN , TRIM(msg))
 137         return
 138       endif
 139 #endif
 140   else
 141     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 142     write(msg,*) &
 143 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 144     call wrf_debug ( FATAL , msg)
 145   endif
 146 ENDIF
 147   return