external/io_adios2/wrf_io.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 module wrf_data_adios2
  18    use adios2
  19    integer                , parameter      :: FATAL            = 0
  20    integer                , parameter      :: WARN             = 0
  21    integer                , parameter      :: WrfDataHandleMax = 99
  22    integer                , parameter      :: MaxDims          = 2000 ! = NF_MAX_VARS
  23    integer                , parameter      :: MaxVars          = 3000
  24    integer                , parameter      :: MaxTimes         = 60000
  25    integer                , parameter      :: DateStrLen       = 19
  26    integer                , parameter      :: VarNameLen       = 31
  27    integer                , parameter      :: NO_DIM           = 0
  28    integer                , parameter      :: NVarDims         = 3 !down from 4, as time is dealt with as "steps" in ADIOS2
  29    integer                , parameter      :: NMDVarDims       = 2
  30    character (8)          , parameter      :: NO_NAME          = 'NULL'
  31    character (DateStrLen) , parameter      :: ZeroDate = '0000-00-00-00:00:00'
  32 #include "wrf_io_flags.h"
  33    character (256)                         :: msg
  34    logical                                 :: WrfIOnotInitialized = .true.
  35    type(adios2_adios)                      :: adios
  36
  37    type :: wrf_data_handle
  38      character (255)                       :: FileName
  39      integer                               :: FileStatus
  40      logical                               :: Free
  41      logical                               :: Write
  42      character (5)                         :: TimesName
  43      integer                               :: TimeIndex
  44      integer                               :: CurrentTime  !Only used for read
  45      integer                               :: NumberTimes  !Only used for read
  46      character (DateStrLen), pointer       :: Times(:)
  47      type(adios2_variable)                 :: TimesVarID
  48      integer               , pointer       :: DimLengths(:)
  49      type(adios2_attribute), pointer       :: DimIDs(:)
  50      character (31)        , pointer       :: DimNames(:)
  51      type(adios2_attribute)                :: DimUnlimID
  52      character (9)                         :: DimUnlimName
  53      type(adios2_attribute), dimension(NVarDims) :: DimID
  54      integer       , dimension(NVarDims)   :: Dimension
  55      type(adios2_variable), pointer        :: MDVarIDs(:)
  56      integer               , pointer       :: MDVarDimLens(:)
  57      character (80)        , pointer       :: MDVarNames(:)
  58      type(adios2_variable) , pointer       :: VarIDs(:)
  59      integer               , pointer       :: VarDimLens(:,:)
  60      character (VarNameLen), pointer       :: VarNames(:)
  61      integer                               :: CurrentVariable  !Only used for read
  62      integer                               :: NumVars
  63  ! first_operation is set to .TRUE. when a new handle is allocated
  64  ! or when open-for-write or open-for-read are committed.  It is set
  65  ! to .FALSE. when the first field is read or written.
  66      logical                               :: first_operation
  67      type(adios2_io)                       :: adios2IO
  68      type(adios2_engine)                   :: adios2Engine
  69      type(adios2_operator)                 :: compress_operator
  70      character(32)                         :: blosc_compressor
  71    end type wrf_data_handle
  72    type(wrf_data_handle),target            :: WrfDataHandles(WrfDataHandleMax)
  73  end module wrf_data_adios2
  74
  75 module ext_adios2_support_routines
  76
  77    implicit none
  78    !include 'mpif.h'
  79
  80  CONTAINS
  81
  82  subroutine allocHandle(DataHandle,DH,Status)
  83    use wrf_data_adios2
  84    include 'wrf_status_codes.h'
  85    integer              ,intent(out) :: DataHandle
  86    type(wrf_data_handle),pointer     :: DH
  87    integer              ,intent(out) :: Status
  88    integer                           :: i
  89    integer                           :: stat
  90
  91    do i=1,WrfDataHandleMax
  92      if(WrfDataHandles(i)%Free) then
  93        DH => WrfDataHandles(i)
  94        DataHandle = i
  95        allocate(DH%Times(MaxTimes), STAT=stat)
  96        if(stat/= 0) then
  97          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
  98          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
  99          call wrf_debug ( FATAL , msg)
 100          return
 101        endif
 102        allocate(DH%DimLengths(MaxDims), STAT=stat)
 103        if(stat/= 0) then
 104          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 105          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 106          call wrf_debug ( FATAL , msg)
 107          return
 108        endif
 109        allocate(DH%DimIDs(MaxDims), STAT=stat)
 110        if(stat/= 0) then
 111          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 112          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 113          call wrf_debug ( FATAL , msg)
 114          return
 115        endif
 116        allocate(DH%DimNames(MaxDims), STAT=stat)
 117        if(stat/= 0) then
 118          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 119          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 120          call wrf_debug ( FATAL , msg)
 121          return
 122        endif
 123        allocate(DH%MDVarIDs(MaxVars), STAT=stat)
 124        if(stat/= 0) then
 125          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 126          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 127          call wrf_debug ( FATAL , msg)
 128          return
 129        endif
 130        allocate(DH%MDVarDimLens(MaxVars), STAT=stat)
 131        if(stat/= 0) then
 132          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 133          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 134          call wrf_debug ( FATAL , msg)
 135          return
 136        endif
 137        allocate(DH%MDVarNames(MaxVars), 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        allocate(DH%VarIDs(MaxVars), STAT=stat)
 145        if(stat/= 0) then
 146          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 147          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 148          call wrf_debug ( FATAL , msg)
 149          return
 150        endif
 151        allocate(DH%VarDimLens(NVarDims,MaxVars), STAT=stat)
 152        if(stat/= 0) then
 153          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 154          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 155          call wrf_debug ( FATAL , msg)
 156          return
 157        endif
 158        allocate(DH%VarNames(MaxVars), STAT=stat)
 159        if(stat/= 0) then
 160          Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 161          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 162          call wrf_debug ( FATAL , msg)
 163          return
 164        endif
 165        exit
 166      endif
 167      if(i==WrfDataHandleMax) then
 168        Status = WRF_WARN_TOO_MANY_FILES
 169        write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__
 170        call wrf_debug ( WARN , TRIM(msg))
 171        write(msg,*) 'Did you call ext_adios2_ioinit?'
 172        call wrf_debug ( WARN , TRIM(msg))
 173        return
 174      endif
 175    enddo
 176    DH%Free      =.false.
 177    DH%Write     =.false.
 178    DH%first_operation  = .TRUE.
 179    Status = WRF_NO_ERR
 180  end subroutine allocHandle
 181
 182  subroutine deallocHandle(DataHandle, Status)
 183    use wrf_data_adios2
 184    include 'wrf_status_codes.h'
 185    integer              ,intent(in)  :: DataHandle
 186    integer              ,intent(out) :: Status
 187    type(wrf_data_handle),pointer     :: DH
 188    integer                           :: i
 189    integer                           :: stat
 190
 191    IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN
 192      if(.NOT. WrfDataHandles(DataHandle)%Free) then
 193        DH => WrfDataHandles(DataHandle)
 194        deallocate(DH%Times, STAT=stat)
 195        if(stat/= 0) then
 196          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 197          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 198          call wrf_debug ( FATAL , msg)
 199          return
 200        endif
 201        deallocate(DH%DimLengths, STAT=stat)
 202        if(stat/= 0) then
 203          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 204          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 205          call wrf_debug ( FATAL , msg)
 206          return
 207        endif
 208        deallocate(DH%DimIDs, STAT=stat)
 209        if(stat/= 0) then
 210          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 211          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 212          call wrf_debug ( FATAL , msg)
 213          return
 214        endif
 215        deallocate(DH%DimNames, STAT=stat)
 216        if(stat/= 0) then
 217          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 218          write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 219          call wrf_debug ( FATAL , msg)
 220          return
 221        endif
 222        deallocate(DH%MDVarIDs, STAT=stat)
 223        if(stat/= 0) then
 224          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 225          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 226          call wrf_debug ( FATAL , msg)
 227          return
 228        endif
 229        deallocate(DH%MDVarDimLens, STAT=stat)
 230        if(stat/= 0) then
 231          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 232          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 233          call wrf_debug ( FATAL , msg)
 234          return
 235        endif
 236        deallocate(DH%MDVarNames, STAT=stat)
 237        if(stat/= 0) then
 238          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 239          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 240          call wrf_debug ( FATAL , msg)
 241          return
 242        endif
 243        deallocate(DH%VarIDs, STAT=stat)
 244        if(stat/= 0) then
 245          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 246          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 247          call wrf_debug ( FATAL , msg)
 248          return
 249        endif
 250        deallocate(DH%VarDimLens, STAT=stat)
 251        if(stat/= 0) then
 252          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 253          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 254          call wrf_debug ( FATAL , msg)
 255          return
 256        endif
 257        deallocate(DH%VarNames, STAT=stat)
 258        if(stat/= 0) then
 259          Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 260          write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 261          call wrf_debug ( FATAL , msg)
 262          return
 263        endif
 264        DH%Free      =.TRUE.
 265      endif
 266    ENDIF
 267    Status = WRF_NO_ERR
 268  end subroutine deallocHandle
 269
 270  subroutine GetDH(DataHandle,DH,Status)
 271    use wrf_data_adios2
 272    include 'wrf_status_codes.h'
 273    integer               ,intent(in)     :: DataHandle
 274    type(wrf_data_handle) ,pointer        :: DH
 275    integer               ,intent(out)    :: Status
 276
 277    if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then
 278      Status = WRF_WARN_BAD_DATA_HANDLE
 279      return
 280    endif
 281    DH => WrfDataHandles(DataHandle)
 282    if(DH%Free) then
 283      Status = WRF_WARN_BAD_DATA_HANDLE
 284      return
 285    endif
 286    Status = WRF_NO_ERR
 287    return
 288  end subroutine GetDH
 289
 290  subroutine DateCheck(Date,Status)
 291    use wrf_data_adios2
 292    include 'wrf_status_codes.h'
 293    character*(*) ,intent(in)      :: Date
 294    integer       ,intent(out)     :: Status
 295
 296    if(len(Date) /= DateStrLen) then
 297      Status = WRF_WARN_DATESTR_BAD_LENGTH
 298    else
 299      Status = WRF_NO_ERR
 300    endif
 301    return
 302  end subroutine DateCheck
 303
 304  subroutine GetName(Element,Var,Name,Status)
 305    use wrf_data_adios2
 306    include 'wrf_status_codes.h'
 307    character*(*) ,intent(in)     :: Element
 308    character*(*) ,intent(in)     :: Var
 309    character*(*) ,intent(out)    :: Name
 310    integer       ,intent(out)    :: Status
 311    character (VarNameLen)        :: VarName
 312    character (1)                 :: c
 313    integer                       :: i
 314    integer, parameter            :: upper_to_lower =IACHAR('a')-IACHAR('A')
 315
 316    VarName = Var
 317    Name = 'MD___'//trim(Element)//VarName
 318    do i=1,len(Name)
 319      c=Name(i:i)
 320      if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower)
 321      if(c=='-'.or.c==':') Name(i:i)='_'
 322    enddo
 323    Status = WRF_NO_ERR
 324    return
 325  end subroutine GetName
 326
 327  subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
 328    use wrf_data_adios2
 329    use adios2
 330    include 'wrf_status_codes.h'
 331    character (*)         ,intent(in)     :: IO
 332    integer               ,intent(in)     :: DataHandle
 333    character*(*)         ,intent(in)     :: DateStr
 334    integer               ,intent(out)    :: TimeIndex
 335    integer               ,intent(out)    :: Status
 336    type(wrf_data_handle) ,pointer        :: DH
 337    integer                               :: stat
 338    integer                               :: i
 339
 340    DH => WrfDataHandles(DataHandle)
 341    call DateCheck(DateStr,Status)
 342    if(Status /= WRF_NO_ERR) then
 343      Status =  WRF_WARN_DATESTR_ERROR
 344      write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
 345      call wrf_debug ( WARN , TRIM(msg))
 346      return
 347    endif
 348    if(IO == 'write') then
 349      TimeIndex = DH%TimeIndex
 350      if(TimeIndex <= 0) then
 351        TimeIndex = 1
 352      elseif(DateStr == DH%Times(TimeIndex)) then
 353        Status = WRF_NO_ERR
 354        return
 355      else
 356        TimeIndex = TimeIndex +1
 357        if(TimeIndex > MaxTimes) then
 358          Status = WRF_WARN_TIME_EOF
 359          write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__
 360          call wrf_debug ( WARN , TRIM(msg))
 361          return
 362        endif
 363      endif
 364      DH%TimeIndex        = TimeIndex
 365      DH%Times(TimeIndex) = DateStr
 366      CALL adios2_put(DH%adios2Engine, DH%TimesVarID, DateStr, adios2_mode_sync, stat)
 367      call adios2_err(stat,Status)
 368      if(Status /= WRF_NO_ERR) then
 369        write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
 370        call wrf_debug ( WARN , TRIM(msg))
 371        return
 372      endif
 373    else
 374      do i=1,MaxTimes
 375        if(DH%Times(i)==DateStr) then
 376          Status = WRF_NO_ERR
 377          TimeIndex = i
 378          exit
 379        endif
 380        if(i==MaxTimes) then
 381          Status = WRF_WARN_TIME_NF
 382          write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__
 383          call wrf_debug ( WARN , TRIM(msg))
 384          return
 385        endif
 386      enddo
 387    endif
 388    return
 389  end subroutine GetTimeIndex
 390
 391  subroutine GetDim(MemoryOrder,NDim,Status)
 392    include 'wrf_status_codes.h'
 393    character*(*) ,intent(in)  :: MemoryOrder
 394    integer       ,intent(out) :: NDim
 395    integer       ,intent(out) :: Status
 396    character*3                :: MemOrd
 397
 398    call LowerCase(MemoryOrder,MemOrd)
 399    select case (MemOrd)
 400      case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
 401        NDim = 3
 402      case ('xy','yx','xs','xe','ys','ye')
 403        NDim = 2
 404      case ('z','c')
 405        NDim = 1
 406      case ('0')  ! NDim=0 for scalars.  TBH:  20060502
 407        NDim = 0
 408      case default
 409        print *, 'memory order = ',MemOrd,'  ',MemoryOrder
 410        Status = WRF_WARN_BAD_MEMORYORDER
 411        return
 412    end select
 413    Status = WRF_NO_ERR
 414    return
 415  end subroutine GetDim
 416
 417  subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2)
 418    integer              ,intent(in)  :: NDim
 419    integer ,dimension(*),intent(in)  :: Start,End
 420    integer              ,intent(out) :: i1,i2,j1,j2,k1,k2
 421
 422    i1=1
 423    i2=1
 424    j1=1
 425    j2=1
 426    k1=1
 427    k2=1
 428    if(NDim == 0) return  ! NDim=0 for scalars.  TBH:  20060502
 429    i1 = Start(1)
 430    i2 = End  (1)
 431    if(NDim == 1) return
 432    j1 = Start(2)
 433    j2 = End  (2)
 434    if(NDim == 2) return
 435    k1 = Start(3)
 436    k2 = End  (3)
 437    return
 438  end subroutine GetIndices
 439
 440  logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status)
 441    use wrf_data_adios2
 442    include 'wrf_status_codes.h'
 443    character*(*)              ,intent(in)    :: MemoryOrder
 444    integer,dimension(*)       ,intent(in)    :: Vector
 445    integer                    ,intent(out)   :: Status
 446    integer                                   :: NDim
 447    integer,dimension(NVarDims)               :: temp
 448    character*3                               :: MemOrd
 449    logical zero_length
 450
 451    call GetDim(MemoryOrder,NDim,Status)
 452    temp(1:NDim) = Vector(1:NDim)
 453    call LowerCase(MemoryOrder,MemOrd)
 454    zero_length = .false.
 455    select case (MemOrd)
 456      case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c')
 457        continue
 458      case ('0')
 459        continue  ! NDim=0 for scalars.  TBH:  20060502
 460      case ('xzy','yzx')
 461        zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1
 462      case ('xy','yx','xyz','yxz')
 463        zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1
 464      case ('zxy','zyx')
 465        zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1
 466      case default
 467        Status = WRF_WARN_BAD_MEMORYORDER
 468        ZeroLengthHorzDim = .true.
 469        return
 470    end select
 471    Status = WRF_NO_ERR
 472    ZeroLengthHorzDim = zero_length
 473    return
 474  end function ZeroLengthHorzDim
 475
 476  subroutine ExtOrder(MemoryOrder,Vector,Status)
 477    use wrf_data_adios2
 478    include 'wrf_status_codes.h'
 479    character*(*)              ,intent(in)    :: MemoryOrder
 480    integer,dimension(*)       ,intent(inout) :: Vector
 481    integer                    ,intent(out)   :: Status
 482    integer                                   :: NDim
 483    integer,dimension(NVarDims)               :: temp
 484    character*3                               :: MemOrd
 485
 486    call GetDim(MemoryOrder,NDim,Status)
 487    temp(1:NDim) = Vector(1:NDim)
 488    call LowerCase(MemoryOrder,MemOrd)
 489    select case (MemOrd)
 490      case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
 491        continue
 492      case ('0')
 493        continue  ! NDim=0 for scalars.  TBH:  20060502
 494      case ('xzy')
 495        Vector(2) = temp(3)
 496        Vector(3) = temp(2)
 497      case ('yxz')
 498        Vector(1) = temp(2)
 499        Vector(2) = temp(1)
 500      case ('yzx')
 501        Vector(1) = temp(3)
 502        Vector(2) = temp(1)
 503        Vector(3) = temp(2)
 504      case ('zxy')
 505        Vector(1) = temp(2)
 506        Vector(2) = temp(3)
 507        Vector(3) = temp(1)
 508      case ('zyx')
 509        Vector(1) = temp(3)
 510        Vector(3) = temp(1)
 511      case ('yx')
 512        Vector(1) = temp(2)
 513        Vector(2) = temp(1)
 514      case default
 515        Status = WRF_WARN_BAD_MEMORYORDER
 516        return
 517    end select
 518    Status = WRF_NO_ERR
 519    return
 520  end subroutine ExtOrder
 521
 522  subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status)
 523    use wrf_data_adios2
 524    include 'wrf_status_codes.h'
 525    character*(*)                    ,intent(in)    :: MemoryOrder
 526    character*(*),dimension(*)       ,intent(in)    :: Vector
 527    character(80),dimension(NVarDims),intent(out)   :: ROVector
 528    integer                          ,intent(out)   :: Status
 529    integer                                         :: NDim
 530    character*3                                     :: MemOrd
 531
 532    call GetDim(MemoryOrder,NDim,Status)
 533    ROVector(1:NDim) = Vector(1:NDim)
 534    call LowerCase(MemoryOrder,MemOrd)
 535    select case (MemOrd)
 536      case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
 537        continue
 538      case ('0')
 539        continue  ! NDim=0 for scalars.  TBH:  20060502
 540      case ('xzy')
 541        ROVector(2) = Vector(3)
 542        ROVector(3) = Vector(2)
 543      case ('yxz')
 544        ROVector(1) = Vector(2)
 545        ROVector(2) = Vector(1)
 546      case ('yzx')
 547        ROVector(1) = Vector(3)
 548        ROVector(2) = Vector(1)
 549        ROVector(3) = Vector(2)
 550      case ('zxy')
 551        ROVector(1) = Vector(2)
 552        ROVector(2) = Vector(3)
 553        ROVector(3) = Vector(1)
 554      case ('zyx')
 555        ROVector(1) = Vector(3)
 556        ROVector(3) = Vector(1)
 557      case ('yx')
 558        ROVector(1) = Vector(2)
 559        ROVector(2) = Vector(1)
 560      case default
 561        Status = WRF_WARN_BAD_MEMORYORDER
 562        return
 563    end select
 564    Status = WRF_NO_ERR
 565    return
 566  end subroutine ExtOrderStr
 567
 568
 569  subroutine LowerCase(MemoryOrder,MemOrd)
 570    character*(*) ,intent(in)  :: MemoryOrder
 571    character*(*) ,intent(out) :: MemOrd
 572    character*1                :: c
 573    integer       ,parameter   :: upper_to_lower =IACHAR('a')-IACHAR('A')
 574    integer                    :: i,N
 575
 576    MemOrd = ' '
 577    N = len(MemoryOrder)
 578    MemOrd(1:N) = MemoryOrder(1:N)
 579    do i=1,N
 580      c = MemoryOrder(i:i)
 581      if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
 582    enddo
 583    return
 584  end subroutine LowerCase
 585
 586  subroutine UpperCase(MemoryOrder,MemOrd)
 587    character*(*) ,intent(in)  :: MemoryOrder
 588    character*(*) ,intent(out) :: MemOrd
 589    character*1                :: c
 590    integer     ,parameter     :: lower_to_upper =IACHAR('A')-IACHAR('a')
 591    integer                    :: i,N
 592
 593    MemOrd = ' '
 594    N = len(MemoryOrder)
 595    MemOrd(1:N) = MemoryOrder(1:N)
 596    do i=1,N
 597      c = MemoryOrder(i:i)
 598      if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper)
 599    enddo
 600    return
 601  end subroutine UpperCase
 602
 603  subroutine adios2_err(err,Status)
 604    use wrf_data_adios2
 605    use adios2
 606    include 'wrf_status_codes.h'
 607    integer  ,intent(in)  :: err
 608    integer  ,intent(out) :: Status
 609    character(len=80)     :: errmsg
 610    integer               :: stat
 611
 612    if( err == adios2_error_none )then
 613      Status = WRF_NO_ERR
 614    else
 615      write(msg,*) 'adios2 error code: ',err
 616      call wrf_debug ( WARN , TRIM(msg))
 617      Status = WRF_WARN_ADIOS2
 618    endif
 619    return
 620  end subroutine adios2_err
 621
 622  subroutine FieldIO(IO,DataHandle,DateStr,Starts,Length,MemoryOrder &
 623                       ,FieldType,VarID,XField,Status)
 624    use wrf_data_adios2
 625    use adios2
 626    include 'wrf_status_codes.h'
 627    character (*)              ,intent(in)    :: IO
 628    integer                    ,intent(in)    :: DataHandle
 629    character*(*)              ,intent(in)    :: DateStr
 630    integer,dimension(NVarDims),intent(in)    :: Starts
 631    integer,dimension(NVarDims),intent(in)    :: Length
 632    character*(*)              ,intent(in)    :: MemoryOrder
 633    integer                    ,intent(in)    :: FieldType
 634    type(adios2_variable)      ,intent(in)    :: VarID
 635    integer,dimension(*)       ,intent(inout) :: XField
 636    integer                    ,intent(out)   :: Status
 637    integer                                   :: TimeIndex
 638    integer                                   :: NDim
 639    integer(kind=8),dimension(NVarDims)       :: VStart
 640    integer(kind=8),dimension(NVarDims)       :: VCount
 641    integer(kind=8)                           :: TimeIndex_int8
 642    integer                                   :: stat
 643
 644    call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
 645    if(Status /= WRF_NO_ERR) then
 646      write(msg,*) 'Warning in ',__FILE__,', line', __LINE__
 647      call wrf_debug ( WARN , TRIM(msg))
 648      write(msg,*) '  Bad time index for DateStr = ',DateStr
 649      call wrf_debug ( WARN , TRIM(msg))
 650      return
 651    endif
 652    if(IO == 'write') then
 653     TimeIndex_int8 = TimeIndex
 654     call adios2_set_step_selection(VarID, TimeIndex_int8 -1_8, 1_8, stat)
 655     call adios2_err(stat,Status)
 656     if(Status /= WRF_NO_ERR) then
 657       write(msg,*) 'adios2 error in FieldIO ',__FILE__,', line', __LINE__
 658       call wrf_debug ( WARN , TRIM(msg))
 659       return
 660     endif
 661    endif
 662    call GetDim(MemoryOrder,NDim,Status)
 663    VStart(:) = 1
 664    VCount(:) = 1
 665    VStart(1:NDim) = Starts(1:NDim)
 666    VCount(1:NDim) = Length(1:NDim)
 667    select case (FieldType)
 668      case (WRF_REAL)
 669        call ext_adios2_RealFieldIO    (IO, DataHandle,VarID,VStart,VCount,XField,Status)
 670      case (WRF_DOUBLE)
 671        call ext_adios2_DoubleFieldIO  (IO,DataHandle,VarID,VStart,VCount,XField,Status)
 672      case (WRF_INTEGER)
 673        call ext_adios2_IntFieldIO     (IO,DataHandle,VarID,VStart,VCount,XField,Status)
 674      case (WRF_LOGICAL)
 675        call ext_adios2_LogicalFieldIO (IO,DataHandle,VarID,VStart,VCount,XField,Status)
 676        if(Status /= WRF_NO_ERR) return
 677      case default
 678  !for wrf_complex, double_complex
 679        Status = WRF_WARN_DATA_TYPE_NOT_FOUND
 680        write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
 681        call wrf_debug ( WARN , TRIM(msg))
 682        return
 683    end select
 684    return
 685  end subroutine FieldIO
 686
 687  subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
 688                                        ,XField,x1,x2,y1,y2,z1,z2 &
 689                                               ,i1,i2,j1,j2,k1,k2 )
 690    character*(*)     ,intent(in)    :: IO
 691    character*(*)     ,intent(in)    :: MemoryOrder
 692    integer           ,intent(in)    :: l1,l2,m1,m2,n1,n2
 693    integer           ,intent(in)    :: di
 694    integer           ,intent(in)    :: x1,x2,y1,y2,z1,z2
 695    integer           ,intent(in)    :: i1,i2,j1,j2,k1,k2
 696    integer           ,intent(inout) ::  Field(di,l1:l2,m1:m2,n1:n2)
 697    integer           ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1))
 698    character*3                      :: MemOrd
 699    character*3                      :: MemO
 700    integer           ,parameter     :: MaxUpperCase=IACHAR('Z')
 701    integer                          :: i,j,k,ix,jx,kx
 702
 703    call LowerCase(MemoryOrder,MemOrd)
 704    select case (MemOrd)
 705 ! Cannot use following define due to gfortran cpp traditional mode concatenation limitations
 706 !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1))
 707 ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1))))
 708      case ('xzy')
 709 #undef  DFIELD
 710 #define DFIELD XField(1:di,XDEX(i,k,j))
 711 #include "transpose.code"
 712      case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
 713 #undef  DFIELD
 714 #define DFIELD XField(1:di,XDEX(i,j,k))
 715 #include "transpose.code"
 716      case ('yxz')
 717 #undef  DFIELD
 718 #define DFIELD XField(1:di,XDEX(j,i,k))
 719 #include "transpose.code"
 720      case ('zxy')
 721 #undef  DFIELD
 722 #define DFIELD XField(1:di,XDEX(k,i,j))
 723 #include "transpose.code"
 724      case ('yzx')
 725 #undef  DFIELD
 726 #define DFIELD XField(1:di,XDEX(j,k,i))
 727 #include "transpose.code"
 728      case ('zyx')
 729 #undef  DFIELD
 730 #define DFIELD XField(1:di,XDEX(k,j,i))
 731 #include "transpose.code"
 732      case ('yx')
 733 #undef  DFIELD
 734 #define DFIELD XField(1:di,XDEX(j,i,k))
 735 #include "transpose.code"
 736    end select
 737    return
 738  end subroutine Transpose
 739
 740  subroutine reorder (MemoryOrder,MemO)
 741    character*(*)     ,intent(in)    :: MemoryOrder
 742    character*3       ,intent(out)   :: MemO
 743    character*3                      :: MemOrd
 744    integer                          :: N,i,i1,i2,i3
 745
 746    MemO = MemoryOrder
 747    N = len_trim(MemoryOrder)
 748    if(N == 1) return
 749    call lowercase(MemoryOrder,MemOrd)
 750  ! never invert the boundary codes
 751    select case ( MemOrd )
 752       case ( 'xsz','xez','ysz','yez' )
 753         return
 754       case default
 755         continue
 756    end select
 757    i1 = 1
 758    i3 = 1
 759    do i=2,N
 760      if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i
 761      if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i
 762    enddo
 763    if(N == 2) then
 764      i2=i3
 765    else
 766      i2 = 6-i1-i3
 767    endif
 768    MemO(1:1) = MemoryOrder(i1:i1)
 769    MemO(2:2) = MemoryOrder(i2:i2)
 770    if(N == 3) MemO(3:3) = MemoryOrder(i3:i3)
 771    if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then
 772      MemO(1:N-1) = MemO(2:N)
 773      MemO(N:N  ) = MemoryOrder(i1:i1)
 774    endif
 775    return
 776  end subroutine reorder
 777
 778  ! Returns .TRUE. iff it is OK to write time-independent domain metadata to the
 779  ! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
 780  ! returned.
 781  LOGICAL FUNCTION adios2_ok_to_put_dom_ti( DataHandle )
 782      USE wrf_data_adios2
 783      include 'wrf_status_codes.h'
 784      INTEGER, INTENT(IN) :: DataHandle
 785      CHARACTER*80 :: fname
 786      INTEGER :: filestate
 787      INTEGER :: Status
 788      LOGICAL :: dryrun, first_output, retval
 789      call ext_adios2_inquire_filename( DataHandle, fname, filestate, Status )
 790      IF ( Status /= WRF_NO_ERR ) THEN
 791        write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 792                     ', line', __LINE__
 793        call wrf_debug ( WARN , TRIM(msg) )
 794        retval = .FALSE.
 795      ELSE
 796        dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
 797        first_output = adios2_is_first_operation( DataHandle )
 798  !      retval = .NOT. dryrun .AND. first_output
 799        retval = dryrun
 800      ENDIF
 801      adios2_ok_to_put_dom_ti = retval
 802      RETURN
 803  END FUNCTION adios2_ok_to_put_dom_ti
 804
 805  ! Returns .TRUE. iff it is OK to read time-independent domain metadata from the
 806  ! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
 807  ! returned.
 808  LOGICAL FUNCTION adios2_ok_to_get_dom_ti( DataHandle )
 809      USE wrf_data_adios2
 810      include 'wrf_status_codes.h'
 811      INTEGER, INTENT(IN) :: DataHandle
 812      CHARACTER*80 :: fname
 813      INTEGER :: filestate
 814      INTEGER :: Status
 815      LOGICAL :: dryrun, retval
 816      call ext_adios2_inquire_filename( DataHandle, fname, filestate, Status )
 817      IF ( Status /= WRF_NO_ERR ) THEN
 818        write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 819                     ', line', __LINE__
 820        call wrf_debug ( WARN , TRIM(msg) )
 821        retval = .FALSE.
 822      ELSE
 823        dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
 824        retval = .NOT. dryrun
 825      ENDIF
 826      adios2_ok_to_get_dom_ti = retval
 827      RETURN
 828  END FUNCTION adios2_ok_to_get_dom_ti
 829
 830  ! Returns .TRUE. iff nothing has been read from or written to the file
 831  ! referenced by DataHandle.  If DataHandle is invalid, .FALSE. is returned.
 832  LOGICAL FUNCTION adios2_is_first_operation( DataHandle )
 833      USE wrf_data_adios2
 834      INCLUDE 'wrf_status_codes.h'
 835      INTEGER, INTENT(IN) :: DataHandle
 836      TYPE(wrf_data_handle) ,POINTER :: DH
 837      INTEGER :: Status
 838      LOGICAL :: retval
 839      CALL GetDH( DataHandle, DH, Status )
 840      IF ( Status /= WRF_NO_ERR ) THEN
 841        write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 842                     ', line', __LINE__
 843        call wrf_debug ( WARN , TRIM(msg) )
 844        retval = .FALSE.
 845      ELSE
 846        retval = DH%first_operation
 847      ENDIF
 848      adios2_is_first_operation = retval
 849      RETURN
 850  END FUNCTION adios2_is_first_operation
 851
 852  end module ext_adios2_support_routines
 853
 854 subroutine ext_adios2_open_for_read(DatasetName, SysDepInfo, DataHandle, Status)
 855   use wrf_data_adios2
 856   use ext_adios2_support_routines
 857   use adios2
 858   implicit none
 859   include 'wrf_status_codes.h'
 860   character *(*), INTENT(IN)   :: DatasetName
 861   character *(*), INTENT(IN)   :: SysDepInfo
 862   integer       , INTENT(OUT)  :: DataHandle
 863   integer       , INTENT(OUT)  :: Status
 864
 865   DataHandle = 0   ! dummy setting to quiet warning message
 866   CALL ext_adios2_open_for_read_begin( DatasetName, SysDepInfo, DataHandle, Status )
 867   IF ( Status .EQ. WRF_NO_ERR ) THEN
 868     CALL ext_adios2_open_for_read_commit( DataHandle, Status )
 869   ENDIF
 870   return
 871 end subroutine ext_adios2_open_for_read
 872
 873 !ends training phase; switches internal flag to enable input
 874 !must be paired with call to ext_adios2_open_for_read_begin
 875 subroutine ext_adios2_open_for_read_commit(DataHandle, Status)
 876   use wrf_data_adios2
 877   use ext_adios2_support_routines
 878   use adios2
 879   implicit none
 880   include 'wrf_status_codes.h'
 881   integer, intent(in)              :: DataHandle
 882   integer, intent(out)             :: Status
 883   integer                          :: stat
 884   type(wrf_data_handle) ,pointer   :: DH
 885
 886   if(WrfIOnotInitialized) then
 887     Status = WRF_IO_NOT_INITIALIZED
 888     write(msg,*) 'ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
 889     call wrf_debug ( FATAL , msg)
 890     return
 891   endif
 892   call GetDH(DataHandle,DH,Status)
 893   if(Status /= WRF_NO_ERR) then
 894     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
 895     call wrf_debug ( WARN , TRIM(msg))
 896     return
 897   endif
 898   DH%FileStatus      = WRF_FILE_OPENED_FOR_READ
 899   DH%first_operation  = .TRUE.
 900   Status = WRF_NO_ERR
 901   return
 902 end subroutine ext_adios2_open_for_read_commit
 903
 904 subroutine ext_adios2_open_for_read_begin( FileName, SysDepInfo, DataHandle, Status)
 905   use wrf_data_adios2
 906   use ext_adios2_support_routines
 907   use adios2
 908   implicit none
 909   include 'wrf_status_codes.h'
 910   character*(*)         ,intent(IN)              :: FileName
 911   character*(*)         ,intent(in)              :: SysDepInfo
 912   integer               ,intent(out)             :: DataHandle
 913   integer               ,intent(out)             :: Status
 914   type(wrf_data_handle) ,pointer                 :: DH
 915   integer                                        :: XType
 916   integer                                        :: stat
 917   type(adios2_variable)                          :: VarIDTime
 918   type(adios2_variable)                          :: VarID
 919   integer                                        :: StoredDim
 920   integer                                        :: DimIDs(2)
 921   integer                                        :: TotalNumVars
 922   integer                                        :: NumVars
 923   integer                                        :: i
 924   integer(kind=8)                                :: timestep
 925   integer(kind=8)                                :: nsteps
 926   character(len=4096), dimension(:), allocatable :: varnamelist
 927   type(adios2_namestruct)                        :: namestruct
 928   character(len=256)                             :: Name
 929
 930   if(WrfIOnotInitialized) then
 931     Status = WRF_IO_NOT_INITIALIZED
 932     write(msg,*) 'ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
 933     call wrf_debug ( FATAL , msg)
 934     return
 935   endif
 936   call allocHandle(DataHandle,DH,Status)
 937   if(Status /= WRF_NO_ERR) then
 938     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 939     call wrf_debug ( WARN , TRIM(msg))
 940     return
 941   endif
 942   call adios2_declare_io(DH%adios2IO, adios, FileName, stat)
 943   call adios2_err(stat,Status)
 944   if(Status /= WRF_NO_ERR) then
 945     write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 946     call wrf_debug ( WARN , TRIM(msg))
 947     return
 948   endif
 949   call adios2_open(DH%adios2Engine, DH%adios2IO, FileName, adios2_mode_read, stat)
 950   call adios2_err(stat,Status)
 951   if(Status /= WRF_NO_ERR) then
 952     write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 953     call wrf_debug ( WARN , TRIM(msg))
 954     return
 955   endif
 956   call adios2_inquire_variable(VarIDTime, DH%adios2IO, DH%TimesName, stat)
 957   call adios2_err(stat,Status)
 958   if(Status /= WRF_NO_ERR) then
 959     write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 960     call wrf_debug ( WARN , TRIM(msg))
 961     return
 962   endif
 963   call adios2_steps(nsteps, DH%adios2Engine, stat)
 964   call adios2_err(stat,Status)
 965   if(Status /= WRF_NO_ERR) then
 966     write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 967     call wrf_debug ( WARN , TRIM(msg))
 968     return
 969   endif
 970   if(nsteps > MaxTimes) then
 971     Status = WRF_ERR_FATAL_TOO_MANY_TIMES
 972     write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
 973     call wrf_debug ( FATAL , TRIM(msg))
 974     return
 975   endif
 976   ! Read in times from different time steps
 977   do timestep=1,nsteps
 978     call adios2_set_step_selection(VarIDTime, timestep - 1, 1_8, stat)
 979     call adios2_err(stat,Status)
 980     if(Status /= WRF_NO_ERR) then
 981       write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 982       call wrf_debug ( WARN , TRIM(msg))
 983       return
 984     endif
 985     call adios2_get(DH%adios2Engine, VarIDTime, DH%Times(timestep), adios2_mode_sync, stat)
 986     call adios2_err(stat,Status)
 987     if(Status /= WRF_NO_ERR) then
 988       write(msg,*) 'adios2 error in ext_adios2_open_for_read_begin ',__FILE__,', line', __LINE__
 989       call wrf_debug ( WARN , TRIM(msg))
 990       return
 991     endif
 992   end do
 993   ! Get variable names
 994   call adios2_available_variables(DH%adios2IO, namestruct, stat)
 995   call adios2_err(stat,Status)
 996   if(Status /= WRF_NO_ERR) then
 997     write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
 998     call wrf_debug ( WARN , TRIM(msg))
 999     return
1000   endif
1001   allocate(varnamelist(namestruct%count))
1002   call adios2_retrieve_names(namestruct, varnamelist, stat)
1003   call adios2_err(stat,Status)
1004   if(Status /= WRF_NO_ERR) then
1005     write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1006     call wrf_debug ( WARN , TRIM(msg))
1007     return
1008   endif
1009   TotalNumVars = namestruct%count
1010   NumVars = 0
1011   do i=1,TotalNumVars
1012     Name = varnamelist(i)
1013     call adios2_inquire_variable(VarID, DH%adios2IO, Name, stat)
1014     call adios2_err(stat,Status)
1015     if(Status /= WRF_NO_ERR) then
1016       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1017       call wrf_debug ( WARN , TRIM(msg))
1018       return
1019     elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1020       NumVars              = NumVars + 1
1021       DH%VarNames(NumVars) = Name
1022       DH%VarIDs(NumVars)   = VarID
1023     endif
1024   enddo
1025   deallocate(varnamelist)
1026   DH%NumVars         = NumVars
1027   DH%NumberTimes     = nsteps
1028   DH%FileStatus      = WRF_FILE_OPENED_NOT_COMMITTED
1029   DH%FileName        = FileName
1030   DH%CurrentVariable = 0
1031   DH%CurrentTime     = 0
1032   DH%TimesVarID      = VarIDTime
1033   DH%TimeIndex       = 0
1034   return
1035 end subroutine ext_adios2_open_for_read_begin
1036
1037 subroutine ext_adios2_open_for_update( FileName, SysDepInfo, DataHandle, Status)
1038   use wrf_data_adios2
1039   use ext_adios2_support_routines
1040   use adios2
1041   implicit none
1042   include 'wrf_status_codes.h'
1043   character*(*)         ,intent(IN)              :: FileName
1044   character*(*)         ,intent(in)              :: SysDepInfo
1045   integer               ,intent(out)             :: DataHandle
1046   integer               ,intent(out)             :: Status
1047   type(wrf_data_handle) ,pointer                 :: DH
1048   integer                                        :: XType
1049   integer                                        :: stat
1050   type(adios2_variable)                          :: VarIDTime
1051   type(adios2_variable)                          :: VarID
1052   integer                                        :: StoredDim
1053   integer                                        :: DimIDs(2)
1054   integer                                        :: TotalNumVars
1055   integer                                        :: NumVars
1056   integer                                        :: i
1057   integer(kind=8)                                :: timestep
1058   integer(kind=8)                                :: nsteps
1059   character(len=4096), dimension(:), allocatable :: varnamelist
1060   type(adios2_namestruct)                        :: namestruct
1061   character(len=256)                             :: Name
1062
1063   if(WrfIOnotInitialized) then
1064     Status = WRF_IO_NOT_INITIALIZED
1065     write(msg,*) 'ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
1066     call wrf_debug ( FATAL , msg)
1067     return
1068   endif
1069   call allocHandle(DataHandle,DH,Status)
1070   if(Status /= WRF_NO_ERR) then
1071     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
1072     call wrf_debug ( WARN , TRIM(msg))
1073     return
1074   endif
1075   call adios2_declare_io(DH%adios2IO, adios, FileName, stat)
1076   call adios2_err(stat,Status)
1077   if(Status /= WRF_NO_ERR) then
1078     write(msg,*) 'adios2 error in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1079     call wrf_debug ( WARN , TRIM(msg))
1080     return
1081   endif
1082   call adios2_open(DH%adios2Engine, DH%adios2IO, FileName, adios2_mode_read, stat)
1083   call adios2_err(stat,Status)
1084   if(Status /= WRF_NO_ERR) then
1085     write(msg,*) 'adios2 error (',stat,') from adios2_open in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1086     call wrf_debug ( WARN , TRIM(msg))
1087     return
1088   endif
1089   call adios2_inquire_variable(VarIDTime, DH%adios2IO, DH%TimesName, stat)
1090   call adios2_err(stat,Status)
1091   if(Status /= WRF_NO_ERR) then
1092     write(msg,*) 'adios2 error in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1093     call wrf_debug ( WARN , TRIM(msg))
1094     return
1095   endif
1096   call adios2_steps(nsteps, DH%adios2Engine, stat)
1097   call adios2_err(stat,Status)
1098   if(Status /= WRF_NO_ERR) then
1099     write(msg,*) 'adios2 error in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1100     call wrf_debug ( WARN , TRIM(msg))
1101     return
1102   endif
1103   if(nsteps > MaxTimes) then
1104     Status = WRF_ERR_FATAL_TOO_MANY_TIMES
1105     write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
1106     call wrf_debug ( FATAL , TRIM(msg))
1107     return
1108   endif
1109   ! Read in times from different time steps
1110   do timestep=1,nsteps
1111     call adios2_set_step_selection(VarIDTime, timestep-1, 1_8, stat)
1112     call adios2_err(stat,Status)
1113     if(Status /= WRF_NO_ERR) then
1114       write(msg,*) 'adios2 error in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1115       call wrf_debug ( WARN , TRIM(msg))
1116       return
1117     endif
1118     call adios2_get(DH%adios2Engine, VarIDTime, DH%Times(timestep), adios2_mode_sync, stat)
1119     call adios2_err(stat,Status)
1120     if(Status /= WRF_NO_ERR) then
1121       write(msg,*) 'adios2 error in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1122       call wrf_debug ( WARN , TRIM(msg))
1123       return
1124     endif
1125   end do
1126   ! Get variable names
1127   call adios2_available_variables(DH%adios2IO, namestruct, stat)
1128   call adios2_err(stat,Status)
1129   if(Status /= WRF_NO_ERR) then
1130     write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1131     call wrf_debug ( WARN , TRIM(msg))
1132     return
1133   endif
1134   allocate(varnamelist(namestruct%count))
1135   call adios2_retrieve_names(namestruct, varnamelist, stat)
1136   call adios2_err(stat,Status)
1137   if(Status /= WRF_NO_ERR) then
1138     write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1139     call wrf_debug ( WARN , TRIM(msg))
1140     return
1141   endif
1142   TotalNumVars = namestruct%count
1143   NumVars = 0
1144   do i=1,TotalNumVars
1145     Name = varnamelist(i)
1146     call adios2_inquire_variable(VarID, DH%adios2IO, Name, stat)
1147     call adios2_err(stat,Status)
1148     if(Status /= WRF_NO_ERR) then
1149       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1150       call wrf_debug ( WARN , TRIM(msg))
1151       return
1152     elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1153       NumVars              = NumVars + 1
1154       DH%VarNames(NumVars) = Name
1155       DH%VarIDs(NumVars)   = VarID
1156     endif
1157   enddo
1158   deallocate(varnamelist)
1159   DH%NumVars         = NumVars
1160   DH%NumberTimes     = nsteps
1161   DH%FileStatus      = WRF_FILE_OPENED_FOR_UPDATE
1162   DH%FileName        = FileName
1163   DH%CurrentVariable = 0
1164   DH%CurrentTime     = 0
1165   DH%TimesVarID      = VarIDTime
1166   DH%TimeIndex       = 0
1167
1168   call adios2_close(DH%adios2Engine, stat)
1169   call adios2_err(stat,Status)
1170   if(Status /= WRF_NO_ERR) then
1171     write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
1172     call wrf_debug ( WARN , TRIM(msg))
1173     return
1174   endif
1175   call adios2_open(DH%adios2Engine, DH%adios2IO, FileName, adios2_mode_append, stat)
1176   call adios2_err(stat,Status)
1177   if(Status /= WRF_NO_ERR) then
1178     write(msg,*) 'adios2 error (',stat,') from adios2_open in ext_adios2_open_for_update ',__FILE__,', line', __LINE__
1179     call wrf_debug ( WARN , TRIM(msg))
1180     return
1181   endif
1182   return
1183 end subroutine ext_adios2_open_for_update
1184
1185 SUBROUTINE ext_adios2_open_for_write_begin(FileName,SysDepInfo,Iotype,DataHandle,Status)
1186   use wrf_data_adios2
1187   use ext_adios2_support_routines
1188   use adios2
1189   implicit none
1190   include 'wrf_status_codes.h'
1191   character*(*)        ,intent(in)  :: FileName
1192   character*(*)        ,intent(in)  :: SysDepInfo
1193   character*(*)        ,intent(in)  :: Iotype
1194   integer              ,intent(out) :: DataHandle
1195   integer              ,intent(out) :: Status
1196   type(wrf_data_handle),pointer     :: DH
1197   integer                           :: i
1198   integer                           :: stat
1199   character (7)                     :: Buffer
1200   integer                           :: ierr
1201   integer                           :: gridid
1202   type(adios2_variable)             :: var
1203   type(adios2_attribute)            :: attribute
1204   type(adios2_attribute)            :: timeAttribute
1205   logical                           :: compression_enabled
1206   character*32                      :: compressor
1207   character(80),dimension(2)        :: DimNamesOut
1208   logical                           :: in_config
1209   integer                           :: numaggregators
1210   character(256)                    :: s_numaggregators
1211
1212   if(WrfIOnotInitialized) then
1213     Status = WRF_IO_NOT_INITIALIZED
1214     write(msg,*) 'ext_adios2_open_for_write_begin: ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
1215     call wrf_debug ( FATAL , msg)
1216     return
1217   endif
1218   call allocHandle(DataHandle,DH,Status)
1219   if(Status /= WRF_NO_ERR) then
1220     write(msg,*) 'Fatal ALLOCATION ERROR in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1221     call wrf_debug ( FATAL , TRIM(msg))
1222     return
1223   endif
1224   DH%TimeIndex = 0
1225   DH%Times     = ZeroDate
1226   DH%FileStatus  = WRF_FILE_OPENED_NOT_COMMITTED
1227   DH%FileName    = FileName
1228   !ADIOS2 declare i/o
1229   if(DH%first_operation) then
1230     call adios2_declare_io(DH%adios2IO, adios, DH%FileName, stat)
1231     call adios2_err(stat,Status)
1232     if(Status /= WRF_NO_ERR) then
1233       write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1234       call wrf_debug ( WARN , TRIM(msg))
1235       return
1236     endif
1237     DH%first_operation = .false.
1238  end if
1239   DH%VarNames  (1:MaxVars) = NO_NAME
1240   DH%MDVarNames(1:MaxVars) = NO_NAME
1241   do i=1,MaxDims
1242     write(Buffer,FMT="('DIM',i4.4)") i
1243     DH%DimNames  (i) = Buffer
1244     DH%DimLengths(i) = NO_DIM
1245   enddo
1246   DH%DimNames(1) = 'DateStrLen'
1247   call adios2_define_attribute(DH%DimIDs(1), DH%adios2IO, '_DIM_DateStrLen', &
1248       DateStrLen, stat)
1249   call adios2_err(stat,Status)
1250   if(Status /= WRF_NO_ERR) then
1251     write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1252     call wrf_debug ( WARN , TRIM(msg))
1253     return
1254   endif
1255   !define "Times" variable and dimension attribute
1256   call adios2_define_variable(DH%TimesVarID, DH%adios2IO, DH%TimesName, adios2_type_character, stat)
1257   call adios2_err(stat,Status)
1258   if(Status /= WRF_NO_ERR) then
1259     write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1260     call wrf_debug ( WARN , TRIM(msg))
1261     return
1262   endif
1263   DimNamesOut(1) = 'DateStrLen'
1264   DimNamesOut(2) = 'Time'
1265   call adios2_define_attribute(timeAttribute,DH%adios2IO, 'Dims', DimNamesOut, 2, DH%TimesVarID%name, '/', stat)
1266   call adios2_err(stat,Status)
1267   if(Status /= WRF_NO_ERR) then
1268     write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1269   call wrf_debug ( WARN , TRIM(msg))
1270   return
1271   endif
1272   !ADIOS2 compression
1273   CALL nl_get_adios2_compression_enable(1,   compression_enabled)
1274   if (compression_enabled) then
1275     if (DH%compress_operator%name .ne. 'Compressor') then
1276       CALL nl_get_adios2_blosc_compressor(1,   compressor)
1277       DH%blosc_compressor = compressor
1278       call adios2_define_operator(DH%compress_operator, adios, 'Compressor', 'blosc', stat)
1279       call adios2_err(stat,Status)
1280       if(Status /= WRF_NO_ERR) then
1281         write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1282         call wrf_debug ( WARN , TRIM(msg))
1283         return
1284       endif
1285     endif
1286   endif
1287   !ADIOS2 number of aggregators (AKA substreams, subfiles). Overrules setting in adios2.xml.
1288   !numaggregators = 0 will set a single aggregator per node.
1289   CALL nl_get_adios2_numaggregators(1,   numaggregators)
1290   write(s_numaggregators,*) numaggregators
1291   call adios2_set_parameter(DH%adios2IO, 'NumAggregators', s_numaggregators, stat)
1292   call adios2_err(stat,Status)
1293   if(Status /= WRF_NO_ERR) then
1294     write(msg,*) 'adios2 error in ext_adios2_open_for_write_begin ',__FILE__,', line', __LINE__
1295     call wrf_debug ( WARN , TRIM(msg))
1296     return
1297   endif
1298
1299   DH%DimLengths(1) = DateStrLen
1300   return
1301 end subroutine ext_adios2_open_for_write_begin
1302
1303 !stub
1304 !opens a file for writing or coupler datastream for sending messages.
1305 !no training phase for this version of the open stmt.
1306 subroutine ext_adios2_open_for_write (DatasetName, SysDepInfo, DataHandle, Status)
1307   use wrf_data_adios2
1308   use ext_adios2_support_routines
1309   implicit none
1310   include 'wrf_status_codes.h'
1311   character *(*), intent(in)  :: DatasetName
1312   character *(*), intent(in)  :: SysDepInfo
1313   integer       , intent(out) :: DataHandle
1314   integer       , intent(out) :: Status
1315
1316   Status=WRF_WARN_NOOP
1317   DataHandle = 0    ! dummy setting to quiet warning message
1318   return
1319 end subroutine ext_adios2_open_for_write
1320
1321 SUBROUTINE ext_adios2_start_io_timestep(DataHandle, Status)
1322   use wrf_data_adios2
1323   use ext_adios2_support_routines
1324   use adios2
1325   implicit none
1326   include 'wrf_status_codes.h'
1327   integer              ,intent(in)  :: DataHandle
1328   integer              ,intent(out) :: Status
1329   type(wrf_data_handle),pointer     :: DH
1330   integer                           :: stat
1331
1332   call GetDH(DataHandle,DH,Status)
1333   if(Status /= WRF_NO_ERR) then
1334     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_start_io_timestep ',__FILE__,', line', __LINE__
1335     call wrf_debug ( WARN , TRIM(msg))
1336     return
1337   endif
1338   if (DH%adios2Engine%valid .eqv. .true.) then
1339     call adios2_begin_step(DH%adios2Engine, stat)
1340     call adios2_err(stat,Status)
1341     if(Status /= WRF_NO_ERR) then
1342       write(msg,*) 'adios2 error (',stat,') from adios2_begin_step in ext_adios2_start_io_timestep ',__FILE__,', line', __LINE__
1343       call wrf_debug ( WARN , TRIM(msg))
1344       return
1345     endif
1346   endif
1347   return
1348 end SUBROUTINE ext_adios2_start_io_timestep
1349
1350 SUBROUTINE ext_adios2_end_io_timestep(DataHandle, Status)
1351   use wrf_data_adios2
1352   use ext_adios2_support_routines
1353   use adios2
1354   implicit none
1355   include 'wrf_status_codes.h'
1356   integer              ,intent(in)  :: DataHandle
1357   integer              ,intent(out) :: Status
1358   type(wrf_data_handle),pointer     :: DH
1359   integer                           :: stat
1360
1361   call GetDH(DataHandle,DH,Status)
1362   if(Status /= WRF_NO_ERR) then
1363     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_end_io_timestep ',__FILE__,', line', __LINE__
1364     call wrf_debug ( WARN , TRIM(msg))
1365     return
1366   endif
1367   if (DH%adios2Engine%valid .eqv. .true.) then
1368     call adios2_end_step(DH%adios2Engine, stat)
1369     call adios2_err(stat,Status)
1370     if(Status /= WRF_NO_ERR) then
1371       write(msg,*) 'adios2 error (',stat,') from adios2_end_step in ext_adios2_end_io_timestep ',__FILE__,', line', __LINE__
1372       call wrf_debug ( WARN , TRIM(msg))
1373       return
1374     endif
1375   endif
1376   return
1377 end SUBROUTINE ext_adios2_end_io_timestep
1378
1379 SUBROUTINE ext_adios2_open_for_write_commit(DataHandle, Status)
1380   use wrf_data_adios2
1381   use ext_adios2_support_routines
1382   use adios2
1383   implicit none
1384   include 'wrf_status_codes.h'
1385   integer              ,intent(in)  :: DataHandle
1386   integer              ,intent(out) :: Status
1387   type(wrf_data_handle),pointer     :: DH
1388   integer                           :: i
1389   integer                           :: stat
1390
1391   if(WrfIOnotInitialized) then
1392     Status = WRF_IO_NOT_INITIALIZED
1393     write(msg,*) 'ext_adios2_open_for_write_commit: ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
1394     call wrf_debug ( FATAL , msg)
1395     return
1396   endif
1397   call GetDH(DataHandle,DH,Status)
1398   if(Status /= WRF_NO_ERR) then
1399     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_open_for_write_commit ',__FILE__,', line', __LINE__
1400     call wrf_debug ( WARN , TRIM(msg))
1401     return
1402   endif
1403   call adios2_open(DH%adios2Engine, DH%adios2IO, DH%FileName, adios2_mode_write, stat)
1404   call adios2_err(stat,Status)
1405   if(Status /= WRF_NO_ERR) then
1406     write(msg,*) 'adios2 error (',stat,') from adios2_open in ext_adios2_open_for_write_commit ',__FILE__,', line', __LINE__
1407     call wrf_debug ( WARN , TRIM(msg))
1408     return
1409   endif
1410   DH%FileStatus  = WRF_FILE_OPENED_FOR_WRITE
1411   DH%first_operation  = .TRUE.
1412   return
1413 end subroutine ext_adios2_open_for_write_commit
1414
1415 subroutine ext_adios2_ioclose(DataHandle, Status)
1416   use wrf_data_adios2
1417   use ext_adios2_support_routines
1418   use adios2
1419   implicit none
1420   include 'wrf_status_codes.h'
1421   integer              ,intent(in)  :: DataHandle
1422   integer              ,intent(out) :: Status
1423   type(wrf_data_handle),pointer     :: DH
1424   integer                           :: stat
1425
1426   call GetDH(DataHandle,DH,Status)
1427   if(Status /= WRF_NO_ERR) then
1428     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_ioclose ',__FILE__,', line', __LINE__
1429     call wrf_debug ( WARN , TRIM(msg))
1430     return
1431   endif
1432   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1433     Status = WRF_WARN_FILE_NOT_OPENED
1434     write(msg,*) 'Warning FILE NOT OPENED in ext_adios2_ioclose ',__FILE__,', line', __LINE__
1435     call wrf_debug ( WARN , TRIM(msg))
1436   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1437     Status = WRF_WARN_DRYRUN_CLOSE
1438     write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_adios2_ioclose ',__FILE__,', line', __LINE__
1439     call wrf_debug ( WARN , TRIM(msg))
1440   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1441     continue
1442   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1443     continue
1444   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
1445     continue
1446   else
1447     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1448     write(msg,*) 'Fatal error BAD FILE STATUS in ext_adios2_ioclose ',__FILE__,', line', __LINE__
1449     call wrf_debug ( FATAL , TRIM(msg))
1450     return
1451   endif
1452   call adios2_close(DH%adios2Engine, stat)
1453   call adios2_err(stat,Status)
1454   if(Status /= WRF_NO_ERR) then
1455     write(msg,*) 'adios2 error in ext_adios2_ioclose ',__FILE__,', line', __LINE__
1456     call wrf_debug ( WARN , TRIM(msg))
1457     return
1458   endif
1459   CALL deallocHandle( DataHandle, Status )
1460   DH%Free=.true.
1461   return
1462 end subroutine ext_adios2_ioclose
1463
1464 subroutine ext_adios2_iosync( DataHandle, Status)
1465   use wrf_data_adios2
1466   use ext_adios2_support_routines
1467   implicit none
1468   include 'wrf_status_codes.h'
1469   integer              ,intent(in)  :: DataHandle
1470   integer              ,intent(out) :: Status
1471   type(wrf_data_handle),pointer     :: DH
1472   integer                           :: stat
1473
1474   call GetDH(DataHandle,DH,Status)
1475   if(Status /= WRF_NO_ERR) then
1476     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_iosync ',__FILE__,', line', __LINE__
1477     call wrf_debug ( WARN , TRIM(msg))
1478     return
1479   endif
1480   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1481     Status = WRF_WARN_FILE_NOT_OPENED
1482     write(msg,*) 'Warning FILE NOT OPENED in ext_adios2_iosync ',__FILE__,', line', __LINE__
1483     call wrf_debug ( WARN , TRIM(msg))
1484   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1485     Status = WRF_WARN_FILE_NOT_COMMITTED
1486     write(msg,*) 'Warning FILE NOT COMMITTED in ext_adios2_iosync ',__FILE__,', line', __LINE__
1487     call wrf_debug ( WARN , TRIM(msg))
1488   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1489     continue
1490   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1491     continue
1492   else
1493     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1494     write(msg,*) 'Fatal error BAD FILE STATUS in ext_adios2_iosync ',__FILE__,', line', __LINE__
1495     call wrf_debug ( FATAL , TRIM(msg))
1496     return
1497   endif
1498   return
1499 end subroutine ext_adios2_iosync
1500
1501 subroutine ext_adios2_redef( DataHandle, Status)
1502   use wrf_data_adios2
1503   use ext_adios2_support_routines
1504   implicit none
1505   include 'wrf_status_codes.h'
1506   integer              ,intent(in)  :: DataHandle
1507   integer              ,intent(out) :: Status
1508   type(wrf_data_handle),pointer     :: DH
1509   integer                           :: stat
1510
1511   call GetDH(DataHandle,DH,Status)
1512   if(Status /= WRF_NO_ERR) then
1513     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1514     call wrf_debug ( WARN , TRIM(msg))
1515     return
1516   endif
1517   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1518     Status = WRF_WARN_FILE_NOT_OPENED
1519     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1520     call wrf_debug ( WARN , TRIM(msg))
1521   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1522     Status = WRF_WARN_FILE_NOT_COMMITTED
1523     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1524     call wrf_debug ( WARN , TRIM(msg))
1525   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1526     continue
1527   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1528     Status = WRF_WARN_FILE_OPEN_FOR_READ
1529     write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1530     call wrf_debug ( WARN , TRIM(msg))
1531   else
1532     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1533     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1534     call wrf_debug ( FATAL , TRIM(msg))
1535     return
1536   endif
1537   DH%FileStatus  = WRF_FILE_OPENED_NOT_COMMITTED
1538   return
1539 end subroutine ext_adios2_redef
1540
1541 subroutine ext_adios2_enddef( DataHandle, Status)
1542   use wrf_data_adios2
1543   use ext_adios2_support_routines
1544   implicit none
1545   include 'wrf_status_codes.h'
1546   integer              ,intent(in)  :: DataHandle
1547   integer              ,intent(out) :: Status
1548   type(wrf_data_handle),pointer     :: DH
1549   integer                           :: stat
1550
1551   call GetDH(DataHandle,DH,Status)
1552   if(Status /= WRF_NO_ERR) then
1553     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1554     call wrf_debug ( WARN , TRIM(msg))
1555     return
1556   endif
1557   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1558     Status = WRF_WARN_FILE_NOT_OPENED
1559     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1560     call wrf_debug ( WARN , TRIM(msg))
1561   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1562     Status = WRF_WARN_FILE_NOT_COMMITTED
1563     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1564     call wrf_debug ( WARN , TRIM(msg))
1565   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1566     continue
1567   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1568     Status = WRF_WARN_FILE_OPEN_FOR_READ
1569     write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1570     call wrf_debug ( WARN , TRIM(msg))
1571   else
1572     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1573     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1574     call wrf_debug ( FATAL , TRIM(msg))
1575     return
1576   endif
1577   DH%FileStatus  = WRF_FILE_OPENED_FOR_WRITE
1578   return
1579 end subroutine ext_adios2_enddef
1580
1581 subroutine ext_adios2_ioinit(SysDepInfo, Status)
1582   use wrf_data_adios2
1583   use ext_adios2_support_routines
1584   use adios2
1585   implicit none
1586   include 'wrf_status_codes.h'
1587   include 'mpif.h'
1588   CHARACTER*(*), INTENT(IN) :: SysDepInfo
1589   integer                   :: stat, rank, ierror
1590   INTEGER ,INTENT(INOUT)    :: Status
1591   logical                   :: file_exists=.FALSE.
1592
1593   WrfIOnotInitialized                             = .false.
1594   WrfDataHandles(1:WrfDataHandleMax)%Free         = .true.
1595   WrfDataHandles(1:WrfDataHandleMax)%TimesName    = 'Times'
1596   WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time'
1597   WrfDataHandles(1:WrfDataHandleMax)%FileStatus   = WRF_FILE_NOT_OPENED
1598   Status = WRF_NO_ERR
1599   !look for adios2 xml runtime configuration
1600   INQUIRE(FILE="adios2.xml", EXIST=file_exists)
1601   if(file_exists) then
1602     call adios2_init(adios, 'adios2.xml', MPI_COMM_WORLD, stat)
1603   else
1604     call adios2_init(adios, MPI_COMM_WORLD, stat)
1605   endif
1606   call adios2_err(stat,Status)
1607   if(Status /= WRF_NO_ERR) then
1608     write(msg,*) 'adios2 error in ext_adios2_ioinit ',__FILE__,', line', __LINE__
1609     call wrf_debug ( WARN , TRIM(msg))
1610     return
1611   endif
1612   return
1613 end subroutine ext_adios2_ioinit
1614
1615
1616 subroutine ext_adios2_inquiry (Inquiry, Result, Status)
1617   use wrf_data_adios2
1618   implicit none
1619   include 'wrf_status_codes.h'
1620   character *(*), INTENT(IN)    :: Inquiry
1621   character *(*), INTENT(OUT)   :: Result
1622   integer        ,INTENT(INOUT) :: Status
1623
1624   SELECT CASE (Inquiry)
1625   CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ")
1626         Result='ALLOW'
1627   CASE ("OPEN_READ","OPEN_COMMIT_WRITE")
1628         Result='REQUIRE'
1629   CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO")
1630         Result='NO'
1631   CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
1632         Result='YES'
1633   CASE ("MEDIUM")
1634         Result ='FILE'
1635   CASE DEFAULT
1636       Result = 'No Result for that inquiry!'
1637   END SELECT
1638   Status=WRF_NO_ERR
1639   return
1640 end subroutine ext_adios2_inquiry
1641
1642
1643 subroutine ext_adios2_ioexit(Status)
1644   use wrf_data_adios2
1645   use ext_adios2_support_routines
1646   use adios2
1647   implicit none
1648   include 'wrf_status_codes.h'
1649   integer       , INTENT(INOUT)     :: Status
1650   integer                           :: error
1651   type(wrf_data_handle),pointer     :: DH
1652   integer                           :: i
1653   integer                           :: stat
1654
1655   if(WrfIOnotInitialized) then
1656     Status = WRF_IO_NOT_INITIALIZED
1657     write(msg,*) 'ext_adios2_ioinit was not called ',__FILE__,', line', __LINE__
1658     call wrf_debug ( FATAL , msg)
1659     return
1660   endif
1661   do i=1,WrfDataHandleMax
1662     CALL deallocHandle( i , stat )
1663   enddo
1664   call adios2_finalize(adios, stat)
1665   call adios2_err(stat,Status)
1666   if(Status /= WRF_NO_ERR) then
1667     write(msg,*) 'adios2 error in ext_adios2_ioexit ',__FILE__,', line', __LINE__
1668     call wrf_debug ( WARN , TRIM(msg))
1669     return
1670   endif
1671   return
1672 end subroutine ext_adios2_ioexit
1673
1674 subroutine ext_adios2_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status)
1675 #define ROUTINE_TYPE 'REAL'
1676 #define TYPE_DATA real,intent(out) :: Data(*)
1677 #define TYPE_COUNT integer,intent(in) :: Count
1678 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1679 #define TYPE_BUFFER  real,allocatable :: Buffer(:)
1680 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1681 #include "ext_adios2_get_dom_ti.code"
1682   return
1683 end subroutine ext_adios2_get_dom_ti_real
1684
1685 subroutine ext_adios2_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status)
1686 #undef ROUTINE_TYPE
1687 #undef TYPE_DATA
1688 #undef TYPE_BUFFER
1689 #undef COPY
1690 #define ROUTINE_TYPE 'INTEGER'
1691 #define TYPE_DATA integer,intent(out) :: Data(*)
1692 #define TYPE_BUFFER  integer,allocatable :: Buffer(:)
1693 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1694 #include "ext_adios2_get_dom_ti.code"
1695   return
1696 end subroutine ext_adios2_get_dom_ti_integer
1697
1698 subroutine ext_adios2_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status)
1699 #undef ROUTINE_TYPE
1700 #undef TYPE_DATA
1701 #undef TYPE_BUFFER
1702 #undef COPY
1703 #define ROUTINE_TYPE 'DOUBLE'
1704 #define TYPE_DATA real*8,intent(out) :: Data(*)
1705 #define TYPE_BUFFER  real*8,allocatable :: Buffer(:)
1706 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1707 #include "ext_adios2_get_dom_ti.code"
1708   return
1709 end subroutine ext_adios2_get_dom_ti_double
1710
1711 subroutine ext_adios2_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status)
1712 #undef ROUTINE_TYPE
1713 #undef TYPE_DATA
1714 #undef TYPE_BUFFER
1715 #undef COPY
1716 #define ROUTINE_TYPE 'LOGICAL'
1717 #define TYPE_DATA logical,intent(out) :: Data(*)
1718 #define TYPE_BUFFER  integer,allocatable :: Buffer(:)
1719 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1
1720 #include "ext_adios2_get_dom_ti.code"
1721   return
1722 end subroutine ext_adios2_get_dom_ti_logical
1723
1724 subroutine ext_adios2_get_dom_ti_char(DataHandle,Element,Data,Status)
1725 #undef ROUTINE_TYPE
1726 #undef TYPE_DATA
1727 #undef TYPE_COUNT
1728 #undef TYPE_OUTCOUNT
1729 #undef TYPE_BUFFER
1730 #define ROUTINE_TYPE 'CHAR'
1731 #define TYPE_DATA character*(*),intent(out) :: Data
1732 #define TYPE_COUNT
1733 #define TYPE_OUTCOUNT
1734 #define TYPE_BUFFER
1735 #define CHAR_TYPE
1736 #include "ext_adios2_get_dom_ti.code"
1737 #undef CHAR_TYPE
1738   return
1739 end subroutine ext_adios2_get_dom_ti_char
1740
1741 subroutine ext_adios2_put_dom_ti_real(DataHandle,Element,Data,Count,Status)
1742 #undef ROUTINE_TYPE
1743 #undef TYPE_DATA
1744 #undef TYPE_COUNT
1745 #undef LOG
1746 #define ROUTINE_TYPE 'REAL'
1747 #define TYPE_DATA  real   ,intent(in) :: Data(Count)
1748 #define TYPE_COUNT integer,intent(in) :: Count
1749 #include "ext_adios2_put_dom_ti.code"
1750 end subroutine ext_adios2_put_dom_ti_real
1751
1752 subroutine ext_adios2_put_dom_ti_integer(DataHandle,Element,Data,Count,Status)
1753 #undef ROUTINE_TYPE
1754 #undef TYPE_DATA
1755 #undef TYPE_COUNT
1756 #undef LOG
1757 #define ROUTINE_TYPE 'INTEGER'
1758 #define TYPE_DATA  integer,intent(in) :: Data(Count)
1759 #define TYPE_COUNT integer,intent(in) :: Count
1760 #include "ext_adios2_put_dom_ti.code"
1761 end subroutine ext_adios2_put_dom_ti_integer
1762
1763 subroutine ext_adios2_put_dom_ti_double(DataHandle,Element,Data,Count,Status)
1764 #undef ROUTINE_TYPE
1765 #undef TYPE_DATA
1766 #undef TYPE_COUNT
1767 #undef LOG
1768 #define ROUTINE_TYPE 'DOUBLE'
1769 #define TYPE_DATA  real*8 ,intent(in) :: Data(:)
1770 #define TYPE_COUNT integer,intent(in) :: Count
1771 #include "ext_adios2_put_dom_ti.code"
1772 end subroutine ext_adios2_put_dom_ti_double
1773
1774 subroutine ext_adios2_put_dom_ti_logical(DataHandle,Element,Data,Count,Status)
1775 #undef ROUTINE_TYPE
1776 #undef TYPE_DATA
1777 #undef TYPE_COUNT
1778 #define ROUTINE_TYPE 'LOGICAL'
1779 #define TYPE_DATA  logical,intent(in) :: Data(Count)
1780 #define TYPE_COUNT integer,intent(in) :: Count
1781 #define LOG
1782 #include "ext_adios2_put_dom_ti.code"
1783 end subroutine ext_adios2_put_dom_ti_logical
1784
1785 subroutine ext_adios2_put_dom_ti_char(DataHandle,Element,Data,Status)
1786 #undef ROUTINE_TYPE
1787 #undef TYPE_DATA
1788 #undef TYPE_COUNT
1789 #undef LOG
1790 #define ROUTINE_TYPE 'CHAR'
1791 #define CHAR_TYPE
1792 #define TYPE_COUNT
1793 #define TYPE_DATA  character*(*), intent(in) :: Data
1794 #include "ext_adios2_put_dom_ti.code"
1795 #undef CHAR_TYPE
1796 end subroutine ext_adios2_put_dom_ti_char
1797
1798 subroutine ext_adios2_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status)
1799 #undef ROUTINE_TYPE
1800 #undef TYPE_DATA
1801 #undef TYPE_COUNT
1802 #undef LOG
1803 #define ROUTINE_TYPE 'REAL'
1804 #define TYPE_DATA  real    ,intent(in) :: Data(Count)
1805 #define TYPE_COUNT integer ,intent(in) :: Count
1806 #include "ext_adios2_put_var_ti.code"
1807 end subroutine ext_adios2_put_var_ti_real
1808
1809 subroutine ext_adios2_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status)
1810 #undef ROUTINE_TYPE
1811 #undef TYPE_DATA
1812 #undef TYPE_COUNT
1813 #undef ADIOS2TYPE
1814 #undef LENGTH
1815 #undef LOG
1816 #define ROUTINE_TYPE 'REAL'
1817 #define TYPE_DATA  real    ,intent(in) :: Data(Count)
1818 #define TYPE_COUNT integer ,intent(in) :: Count
1819 #define ADIOS2TYPE adios2_type_real
1820 #define LENGTH Count
1821 #include "ext_adios2_put_var_td.code"
1822 end subroutine ext_adios2_put_var_td_real
1823
1824 subroutine ext_adios2_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status)
1825 #undef ROUTINE_TYPE
1826 #undef TYPE_DATA
1827 #undef TYPE_COUNT
1828 #undef LOG
1829 #define ROUTINE_TYPE 'DOUBLE'
1830 #define TYPE_DATA  real*8 ,intent(in) :: Data(Count)
1831 #define TYPE_COUNT integer ,intent(in) :: Count
1832 #include "ext_adios2_put_var_ti.code"
1833 end subroutine ext_adios2_put_var_ti_double
1834
1835 subroutine ext_adios2_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status)
1836 #undef ROUTINE_TYPE
1837 #undef TYPE_DATA
1838 #undef TYPE_COUNT
1839 #undef ADIOS2TYPE
1840 #undef LENGTH
1841 #undef LOG
1842 #define ROUTINE_TYPE 'DOUBLE'
1843 #define TYPE_DATA  real*8,intent(in)   :: Data(Count)
1844 #define TYPE_COUNT integer ,intent(in) :: Count
1845 #define ADIOS2TYPE adios2_type_dp
1846 #define LENGTH Count
1847 #include "ext_adios2_put_var_td.code"
1848 end subroutine ext_adios2_put_var_td_double
1849
1850 subroutine ext_adios2_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status)
1851 #undef ROUTINE_TYPE
1852 #undef TYPE_DATA
1853 #undef TYPE_COUNT
1854 #undef LOG
1855 #define ROUTINE_TYPE 'INTEGER'
1856 #define TYPE_DATA  integer ,intent(in) :: Data(Count)
1857 #define TYPE_COUNT integer ,intent(in) :: Count
1858 #include "ext_adios2_put_var_ti.code"
1859 end subroutine ext_adios2_put_var_ti_integer
1860
1861 subroutine ext_adios2_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status)
1862 #undef ROUTINE_TYPE
1863 #undef TYPE_DATA
1864 #undef TYPE_COUNT
1865 #undef ADIOS2TYPE
1866 #undef LENGTH
1867 #undef LOG
1868 #define ROUTINE_TYPE 'INTEGER'
1869 #define TYPE_DATA  integer ,intent(in) :: Data(Count)
1870 #define TYPE_COUNT integer ,intent(in) :: Count
1871 #define ADIOS2TYPE adios2_type_integer4
1872 #define LENGTH Count
1873 #include "ext_adios2_put_var_td.code"
1874 end subroutine ext_adios2_put_var_td_integer
1875
1876 subroutine ext_adios2_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status)
1877 #undef ROUTINE_TYPE
1878 #undef TYPE_DATA
1879 #undef TYPE_COUNT
1880 #define ROUTINE_TYPE 'LOGICAL'
1881 #define TYPE_DATA  logical ,intent(in) :: Data(Count)
1882 #define TYPE_COUNT integer ,intent(in) :: Count
1883 #define LOG
1884 #include "ext_adios2_put_var_ti.code"
1885 end subroutine ext_adios2_put_var_ti_logical
1886
1887 subroutine ext_adios2_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status)
1888 #undef ROUTINE_TYPE
1889 #undef TYPE_DATA
1890 #undef TYPE_COUNT
1891 #undef ADIOS2TYPE
1892 #undef LENGTH
1893 #define ROUTINE_TYPE 'LOGICAL'
1894 #define TYPE_DATA  logical ,intent(in) :: Data(Count)
1895 #define TYPE_COUNT integer ,intent(in) :: Count
1896 #define ADIOS2TYPE adios2_type_integer4
1897 #define LOG
1898 #define LENGTH Count
1899 #include "ext_adios2_put_var_td.code"
1900 end subroutine ext_adios2_put_var_td_logical
1901
1902 subroutine ext_adios2_put_var_ti_char(DataHandle,Element,Var,Data,Status)
1903 #undef ROUTINE_TYPE
1904 #undef TYPE_DATA
1905 #undef TYPE_COUNT
1906 #undef LOG
1907 #define ROUTINE_TYPE 'CHAR'
1908 #define TYPE_DATA  character*(*) ,intent(in) :: Data(1)
1909 #define TYPE_COUNT
1910 #define CHAR_TYPE
1911 #include "ext_adios2_put_var_ti.code"
1912 #undef CHAR_TYPE
1913 end subroutine ext_adios2_put_var_ti_char
1914
1915 subroutine ext_adios2_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
1916 #undef ROUTINE_TYPE
1917 #undef TYPE_DATA
1918 #undef TYPE_COUNT
1919 #undef ADIOS2TYPE
1920 #undef LENGTH
1921 #undef LOG
1922 #define ROUTINE_TYPE 'CHAR'
1923 #define TYPE_DATA  character*(*) ,intent(in) :: Data
1924 #define TYPE_COUNT
1925 #define ADIOS2TYPE adios2_type_string
1926 #define LENGTH len(Data)
1927 #include "ext_adios2_put_var_td.code"
1928 end subroutine ext_adios2_put_var_td_char
1929
1930 subroutine ext_adios2_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status)
1931 #undef ROUTINE_TYPE
1932 #undef TYPE_DATA
1933 #undef TYPE_BUFFER
1934 #undef TYPE_COUNT
1935 #undef TYPE_OUTCOUNT
1936 #undef COPY
1937 #define ROUTINE_TYPE 'REAL'
1938 #define TYPE_DATA     real   ,intent(out) :: Data(Count)
1939 #define TYPE_BUFFER   real   ,allocatable :: Buffer(:)
1940 #define TYPE_COUNT    integer,intent(in)  :: Count
1941 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1942 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
1943 #include "ext_adios2_get_var_ti.code"
1944   return
1945 end subroutine ext_adios2_get_var_ti_real
1946
1947 subroutine ext_adios2_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
1948 #undef ROUTINE_TYPE
1949 #undef TYPE_DATA
1950 #undef TYPE_BUFFER
1951 #undef TYPE_COUNT
1952 #undef TYPE_OUTCOUNT
1953 #undef LENGTH
1954 #undef COPY
1955 #define ROUTINE_TYPE 'REAL'
1956 #define TYPE_DATA     real   ,intent(out) :: Data(Count)
1957 #define TYPE_BUFFER real
1958 #define TYPE_COUNT    integer,intent(in)  :: Count
1959 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1960 #define LENGTH min(Count,Len1)
1961 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
1962 #include "ext_adios2_get_var_td.code"
1963   return
1964 end subroutine ext_adios2_get_var_td_real
1965
1966 subroutine ext_adios2_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status)
1967 #undef ROUTINE_TYPE
1968 #undef TYPE_DATA
1969 #undef TYPE_BUFFER
1970 #undef TYPE_COUNT
1971 #undef TYPE_OUTCOUNT
1972 #undef COPY
1973 #define ROUTINE_TYPE 'DOUBLE'
1974 #define TYPE_DATA     real*8 ,intent(out) :: Data(Count)
1975 #define TYPE_BUFFER   real*8 ,allocatable :: Buffer(:)
1976 #define TYPE_COUNT    integer,intent(in)  :: Count
1977 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1978 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
1979 #include "ext_adios2_get_var_ti.code"
1980   return
1981 end subroutine ext_adios2_get_var_ti_double
1982
1983 subroutine ext_adios2_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
1984 #undef ROUTINE_TYPE
1985 #undef TYPE_DATA
1986 #undef TYPE_BUFFER
1987 #undef TYPE_COUNT
1988 #undef TYPE_OUTCOUNT
1989 #undef LENGTH
1990 #undef COPY
1991 #define ROUTINE_TYPE 'DOUBLE'
1992 #define TYPE_DATA     real*8 ,intent(out) :: Data(Count)
1993 #define TYPE_BUFFER real*8
1994 #define TYPE_COUNT    integer,intent(in)  :: Count
1995 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1996 #define LENGTH min(Count,Len1)
1997 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
1998 #include "ext_adios2_get_var_td.code"
1999   return
2000 end subroutine ext_adios2_get_var_td_double
2001
2002 subroutine ext_adios2_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status)
2003 #undef ROUTINE_TYPE
2004 #undef TYPE_DATA
2005 #undef TYPE_BUFFER
2006 #undef TYPE_COUNT
2007 #undef TYPE_OUTCOUNT
2008 #undef COPY
2009 #define ROUTINE_TYPE 'INTEGER'
2010 #define TYPE_DATA     integer,intent(out) :: Data(Count)
2011 #define TYPE_BUFFER   integer,allocatable :: Buffer(:)
2012 #define TYPE_COUNT    integer,intent(in)  :: Count
2013 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2014 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2015 #include "ext_adios2_get_var_ti.code"
2016   return
2017 end subroutine ext_adios2_get_var_ti_integer
2018
2019 subroutine ext_adios2_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2020 #undef ROUTINE_TYPE
2021 #undef TYPE_DATA
2022 #undef TYPE_BUFFER
2023 #undef TYPE_COUNT
2024 #undef TYPE_OUTCOUNT
2025 #undef LENGTH
2026 #undef COPY
2027 #define ROUTINE_TYPE 'INTEGER'
2028 #define TYPE_DATA     integer,intent(out) :: Data(Count)
2029 #define TYPE_BUFFER integer
2030 #define TYPE_COUNT    integer,intent(in)  :: Count
2031 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2032 #define LENGTH min(Count,Len1)
2033 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2034 #include "ext_adios2_get_var_td.code"
2035   return
2036 end subroutine ext_adios2_get_var_td_integer
2037
2038 subroutine ext_adios2_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status)
2039 #undef ROUTINE_TYPE
2040 #undef TYPE_DATA
2041 #undef TYPE_BUFFER
2042 #undef TYPE_COUNT
2043 #undef TYPE_OUTCOUNT
2044 #undef COPY
2045 #define ROUTINE_TYPE 'LOGICAL'
2046 #define TYPE_DATA     logical,intent(out) :: Data(Count)
2047 #define TYPE_BUFFER   integer,allocatable :: Buffer(:)
2048 #define TYPE_COUNT    integer,intent(in)  :: Count
2049 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2050 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1
2051 #include "ext_adios2_get_var_ti.code"
2052   return
2053 end subroutine ext_adios2_get_var_ti_logical
2054
2055 subroutine ext_adios2_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2056 #undef ROUTINE_TYPE
2057 #undef TYPE_DATA
2058 #undef TYPE_BUFFER
2059 #undef TYPE_COUNT
2060 #undef TYPE_OUTCOUNT
2061 #undef LENGTH
2062 #undef COPY
2063 #define ROUTINE_TYPE 'LOGICAL'
2064 #define TYPE_DATA     logical,intent(out) :: Data(Count)
2065 #define TYPE_BUFFER   integer
2066 #define TYPE_COUNT    integer,intent(in)  :: Count
2067 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2068 #define LENGTH min(Count,Len1)
2069 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1
2070 #include "ext_adios2_get_var_td.code"
2071   return
2072 end subroutine ext_adios2_get_var_td_logical
2073
2074 subroutine ext_adios2_get_var_ti_char(DataHandle,Element,Var,Data,Status)
2075 #undef ROUTINE_TYPE
2076 #undef TYPE_DATA
2077 #undef TYPE_BUFFER
2078 #undef TYPE_COUNT
2079 #undef TYPE_OUTCOUNT
2080 #undef COPY
2081 #define ROUTINE_TYPE 'CHAR'
2082 #define TYPE_DATA   character*(*) ,intent(out) :: Data
2083 #define TYPE_BUFFER
2084 #define TYPE_COUNT integer :: Count = 1
2085 #define TYPE_OUTCOUNT
2086 #define COPY
2087 #define CHAR_TYPE
2088 #include "ext_adios2_get_var_ti.code"
2089 #undef CHAR_TYPE
2090   return
2091 end subroutine ext_adios2_get_var_ti_char
2092
2093 subroutine ext_adios2_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
2094 #undef ROUTINE_TYPE
2095 #undef TYPE_DATA
2096 #undef TYPE_BUFFER
2097 #undef TYPE_COUNT
2098 #undef TYPE_OUTCOUNT
2099 #undef LENGTH
2100 #define ROUTINE_TYPE 'CHAR'
2101 #define TYPE_DATA character*(*) ,intent(out)    :: Data
2102 #define TYPE_BUFFER character (80)
2103 #define TYPE_COUNT integer :: Count = 1
2104 #define TYPE_OUTCOUNT
2105 #define LENGTH Len1
2106 #define CHAR_TYPE
2107 #include "ext_adios2_get_var_td.code"
2108 #undef CHAR_TYPE
2109   return
2110 end subroutine ext_adios2_get_var_td_char
2111
2112 subroutine ext_adios2_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status)
2113   integer               ,intent(in)     :: DataHandle
2114   character*(*)         ,intent(in)     :: Element
2115   character*(*)         ,intent(in)     :: DateStr
2116   real                  ,intent(in)     :: Data(*)
2117   integer               ,intent(in)     :: Count
2118   integer               ,intent(out)    :: Status
2119
2120   call ext_adios2_put_var_td_real(DataHandle,Element,DateStr, &
2121        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2122   return
2123 end subroutine ext_adios2_put_dom_td_real
2124
2125 subroutine ext_adios2_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status)
2126   integer               ,intent(in)     :: DataHandle
2127   character*(*)         ,intent(in)     :: Element
2128   character*(*)         ,intent(in)     :: DateStr
2129   integer               ,intent(in)     :: Data(*)
2130   integer               ,intent(in)     :: Count
2131   integer               ,intent(out)    :: Status
2132
2133   call ext_adios2_put_var_td_integer(DataHandle,Element,DateStr, &
2134        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,Status)
2135   return
2136 end subroutine ext_adios2_put_dom_td_integer
2137
2138 subroutine ext_adios2_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status)
2139   integer               ,intent(in)     :: DataHandle
2140   character*(*)         ,intent(in)     :: Element
2141   character*(*)         ,intent(in)     :: DateStr
2142   real*8                ,intent(in)     :: Data(*)
2143   integer               ,intent(in)     :: Count
2144   integer               ,intent(out)    :: Status
2145
2146   call ext_adios2_put_var_td_double(DataHandle,Element,DateStr, &
2147        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'   ,Data,Count,Status)
2148   return
2149 end subroutine ext_adios2_put_dom_td_double
2150
2151 subroutine ext_adios2_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status)
2152   integer               ,intent(in)     :: DataHandle
2153   character*(*)         ,intent(in)     :: Element
2154   character*(*)         ,intent(in)     :: DateStr
2155   logical               ,intent(in)     :: Data(*)
2156   integer               ,intent(in)     :: Count
2157   integer               ,intent(out)    :: Status
2158
2159   call ext_adios2_put_var_td_logical(DataHandle,Element,DateStr, &
2160        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,Status)
2161   return
2162 end subroutine ext_adios2_put_dom_td_logical
2163
2164 subroutine ext_adios2_put_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2165   integer               ,intent(in)     :: DataHandle
2166   character*(*)         ,intent(in)     :: Element
2167   character*(*)         ,intent(in)     :: DateStr
2168   character*(*)         ,intent(in)     :: Data
2169   integer               ,intent(out)    :: Status
2170
2171   call ext_adios2_put_var_td_char(DataHandle,Element,DateStr, &
2172        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2173   return
2174 end subroutine ext_adios2_put_dom_td_char
2175
2176 subroutine ext_adios2_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2177   integer               ,intent(in)     :: DataHandle
2178   character*(*)         ,intent(in)     :: Element
2179   character*(*)         ,intent(in)     :: DateStr
2180   real                  ,intent(out)    :: Data(*)
2181   integer               ,intent(in)     :: Count
2182   integer               ,intent(out)    :: OutCount
2183   integer               ,intent(out)    :: Status
2184
2185   call ext_adios2_get_var_td_real(DataHandle,Element,DateStr,          &
2186        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2187    return
2188 end subroutine ext_adios2_get_dom_td_real
2189
2190 subroutine ext_adios2_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2191   integer               ,intent(in)     :: DataHandle
2192   character*(*)         ,intent(in)     :: Element
2193   character*(*)         ,intent(in)     :: DateStr
2194   integer               ,intent(out)    :: Data(*)
2195   integer               ,intent(in)     :: Count
2196   integer               ,intent(out)    :: OutCount
2197   integer               ,intent(out)    :: Status
2198
2199   call ext_adios2_get_var_td_integer(DataHandle,Element,DateStr,          &
2200        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,OutCount,Status)
2201    return
2202 end subroutine ext_adios2_get_dom_td_integer
2203
2204 subroutine ext_adios2_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2205   integer               ,intent(in)     :: DataHandle
2206   character*(*)         ,intent(in)     :: Element
2207   character*(*)         ,intent(in)     :: DateStr
2208   real*8                ,intent(out)    :: Data(*)
2209   integer               ,intent(in)     :: Count
2210   integer               ,intent(out)    :: OutCount
2211   integer               ,intent(out)    :: Status
2212
2213   call ext_adios2_get_var_td_double(DataHandle,Element,DateStr,          &
2214        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'   ,Data,Count,OutCount,Status)
2215   return
2216 end subroutine ext_adios2_get_dom_td_double
2217
2218 subroutine ext_adios2_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2219   integer               ,intent(in)     :: DataHandle
2220   character*(*)         ,intent(in)     :: Element
2221   character*(*)         ,intent(in)     :: DateStr
2222   logical               ,intent(out)    :: Data(*)
2223   integer               ,intent(in)     :: Count
2224   integer               ,intent(out)    :: OutCount
2225   integer               ,intent(out)    :: Status
2226
2227   call ext_adios2_get_var_td_logical(DataHandle,Element,DateStr,          &
2228        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,OutCount,Status)
2229   return
2230 end subroutine ext_adios2_get_dom_td_logical
2231
2232 subroutine ext_adios2_get_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2233   integer               ,intent(in)     :: DataHandle
2234   character*(*)         ,intent(in)     :: Element
2235   character*(*)         ,intent(in)     :: DateStr
2236   character*(*)         ,intent(out)    :: Data
2237   integer               ,intent(out)    :: Status
2238
2239   call ext_adios2_get_var_td_char(DataHandle,Element,DateStr,          &
2240        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2241   return
2242 end subroutine ext_adios2_get_dom_td_char
2243
2244
2245 subroutine ext_adios2_write_field(DataHandle,DateStr,Var,Field,FieldType, &
2246   DomainDesc, MemoryOrdIn, Stagger,  DimNames,                            &
2247   DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2248   use wrf_data_adios2
2249   use ext_adios2_support_routines
2250   use adios2
2251   implicit none
2252   include 'wrf_status_codes.h'
2253   integer                       ,intent(in)    :: DataHandle
2254   character*(*)                 ,intent(in)    :: DateStr
2255   character*(*)                 ,intent(in)    :: Var
2256   integer                       ,intent(inout) :: Field(*)
2257   integer                       ,intent(in)    :: FieldType
2258   integer                       ,intent(in)    :: DomainDesc
2259   character*(*)                 ,intent(in)    :: MemoryOrdIn
2260   character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
2261   character*(*) ,dimension(*)   ,intent(in)    :: DimNames
2262   integer       ,dimension(*)   ,intent(in)    :: DomainStart, DomainEnd
2263   integer       ,dimension(*)   ,intent(in)    :: MemoryStart, MemoryEnd
2264   integer       ,dimension(*)   ,intent(in)    :: PatchStart,  PatchEnd
2265   integer                       ,intent(out)   :: Status
2266   character (3)                                :: MemoryOrder
2267   type(wrf_data_handle)         ,pointer       :: DH
2268   integer                                      :: NDim
2269   character (VarNameLen)                       :: VarName
2270   character (3)                                :: MemO
2271   character (3)                                :: UCMemO
2272   type(adios2_variable)                        :: VarID
2273   type(adios2_attribute)                       :: AttributeID
2274   integer      ,dimension(NVarDims)            :: Length_global, Length_native
2275   integer      ,dimension(NVarDims)            :: Length
2276   integer, dimension(NVarDims)                 :: VDimIDs
2277   character(80),dimension(NVarDims)            :: RODimNames
2278   integer      ,dimension(NVarDims)            :: StoredStart
2279   integer(kind=8)      ,dimension(NVarDims)    :: zero
2280   integer(kind=8)      ,dimension(NVarDims)    :: shape_dims
2281   integer      ,dimension(:,:,:,:),allocatable :: XField
2282   integer                                      :: stat
2283   integer                                      :: NVar
2284   integer                                      :: i,j
2285   integer                                      :: i1,i2,j1,j2,k1,k2
2286   integer                                      :: x1,x2,y1,y2,z1,z2
2287   integer                                      :: p1,p2,q1,q2,r1,r2
2288   integer                                      :: l1,l2,m1,m2,n1,n2
2289   integer                                      :: XType
2290   integer                                      :: di
2291   character (80)                               :: NullName
2292   logical                                      :: NotFound
2293   ! Local, possibly adjusted, copies of MemoryStart and MemoryEnd
2294   integer       ,dimension(NVarDims)           :: lMemoryStart, lMemoryEnd
2295   character(80),dimension(NVarDims+1)          :: DimNamesOut
2296   integer                                      :: operation_id
2297
2298   MemoryOrder = trim(adjustl(MemoryOrdIn))
2299   NullName=char(0)
2300   call GetDim(MemoryOrder,NDim,Status)
2301   if(Status /= WRF_NO_ERR) then
2302     write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__
2303     call wrf_debug ( WARN , TRIM(msg))
2304     return
2305   endif
2306   call DateCheck(DateStr,Status)
2307   if(Status /= WRF_NO_ERR) then
2308     write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__
2309     call wrf_debug ( WARN , TRIM(msg))
2310     return
2311   endif
2312   VarName = Var
2313   call GetDH(DataHandle,DH,Status)
2314   if(Status /= WRF_NO_ERR) then
2315     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2316     call wrf_debug ( WARN , TRIM(msg))
2317     return
2318   endif
2319   write(msg,*)'ext_adios2_write_field: called for ',TRIM(Var)
2320   CALL wrf_debug( 100, msg )
2321
2322 !jm 20061024
2323   Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2324   Length_native(1:NDim) = Length(1:NDim)
2325   Length_global(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
2326
2327   call ExtOrder(MemoryOrder,Length,Status)
2328   call ExtOrder(MemoryOrder,Length_global,Status)
2329   call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
2330
2331   lMemoryStart(1:NDim) = MemoryStart(1:NDim)
2332   lMemoryEnd(1:NDim) = MemoryEnd(1:NDim)
2333   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2334     Status = WRF_WARN_FILE_NOT_OPENED
2335     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2336     call wrf_debug ( WARN , TRIM(msg))
2337   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2338     Status = WRF_WARN_WRITE_RONLY_FILE
2339     write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__
2340     call wrf_debug ( WARN , TRIM(msg))
2341   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2342     do NVar=1,MaxVars
2343       if(DH%VarNames(NVar) == VarName ) then
2344         Status = WRF_WARN_2DRYRUNS_1VARIABLE
2345         write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE (',TRIM(VarName),') in ',__FILE__,', line', __LINE__
2346         call wrf_debug ( WARN , TRIM(msg))
2347         return
2348       elseif(DH%VarNames(NVar) == NO_NAME) then
2349         DH%VarNames(NVar) = VarName
2350         DH%NumVars        = NVar
2351         exit
2352       elseif(NVar == MaxVars) then
2353         Status = WRF_WARN_TOO_MANY_VARIABLES
2354         write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__
2355         call wrf_debug ( WARN , TRIM(msg))
2356         return
2357       endif
2358     enddo
2359     do j = 1,NDim
2360       if(RODimNames(j) == NullName .or. RODimNames(j) == '') then
2361         do i=1,MaxDims
2362           if(DH%DimLengths(i) == Length_global(j)) then
2363             exit
2364           elseif(DH%DimLengths(i) == NO_DIM) then
2365             call adios2_define_attribute(DH%DimIDs(i), DH%adios2IO, '_DIM_'//DH%DimNames(i), &
2366               Length_global(j), stat)
2367             call adios2_err(stat,Status)
2368             if(Status /= WRF_NO_ERR) then
2369               write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
2370               call wrf_debug ( WARN , TRIM(msg))
2371               return
2372             endif
2373             DH%DimLengths(i) = Length_global(j)
2374             exit
2375           elseif(i == MaxDims) then
2376             Status = WRF_WARN_TOO_MANY_DIMS
2377             write(msg,*) 'Warning TOO MANY DIMENSIONS (',i,') in (',TRIM(VarName),') ',__FILE__,', line', __LINE__
2378             call wrf_debug ( WARN , TRIM(msg))
2379             return
2380           endif
2381         enddo
2382       else !look for input name and check if already defined
2383         NotFound = .true.
2384         do i=1,MaxDims
2385           if (DH%DimNames(i) == RODimNames(j)) then
2386             if (DH%DimLengths(i) == Length_global(j)) then
2387               NotFound = .false.
2388               exit
2389             else
2390               Status = WRF_WARN_DIMNAME_REDEFINED
2391               write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED  by var ', &
2392                            TRIM(Var),' ',DH%DimLengths(i),Length_global(j) ,' in ', __FILE__ ,' line', __LINE__
2393               call wrf_debug ( WARN , TRIM(msg))
2394               return
2395             endif
2396           endif
2397         enddo
2398         if (NotFound) then
2399           do i=1,MaxDims
2400             if (DH%DimLengths(i) == NO_DIM) then
2401               DH%DimNames(i) = RODimNames(j)
2402               call adios2_define_attribute(DH%DimIDs(i), DH%adios2IO, '_DIM_'//DH%DimNames(i), &
2403               Length_global(j), stat)
2404               call adios2_err(stat,Status)
2405               if(Status /= WRF_NO_ERR) then
2406                 write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
2407                 call wrf_debug ( WARN , TRIM(msg))
2408                 return
2409               endif
2410               DH%DimLengths(i) = Length_global(j)
2411               exit
2412             elseif(i == MaxDims) then
2413               Status = WRF_WARN_TOO_MANY_DIMS
2414               write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__
2415               call wrf_debug ( WARN , TRIM(msg))
2416               return
2417             endif
2418           enddo
2419         endif
2420       endif
2421       VDimIDs(j) = i
2422       DH%VarDimLens(j,NVar) = Length_global(j)
2423     enddo
2424     select case (FieldType)
2425       case (WRF_REAL)
2426         XType = adios2_type_real
2427       case (WRF_DOUBLE)
2428         Xtype = adios2_type_dp
2429       case (WRF_INTEGER)
2430         XType = adios2_type_integer4
2431       case (WRF_LOGICAL)
2432         XType = adios2_type_integer4
2433       case default
2434         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2435         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2436         call wrf_debug ( WARN , TRIM(msg))
2437         return
2438     end select
2439     zero(:) = 0
2440     shape_dims(:) = Length_global(:)
2441     if(NDim == 0) then
2442       shape_dims(:) = 1
2443       call adios2_define_variable(VarID, DH%adios2IO, VarName, XType, &
2444                                1, shape_dims, zero, zero, &
2445                                adios2_variable_dims, stat)
2446     else
2447       call adios2_define_variable(VarID, DH%adios2IO, VarName, XType, &
2448                                NDim, shape_dims, zero, zero, &
2449                               adios2_variable_dims, stat)
2450     endif
2451     call adios2_err(stat,Status)
2452     if(Status /= WRF_NO_ERR) then
2453       write(msg,*) 'ext_adios2_write_field: adios2 error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2454       call wrf_debug ( WARN , TRIM(msg))
2455       return
2456     endif
2457     if (DH%compress_operator%valid .eqv. .true.) then
2458       if (DH%blosc_compressor == 'blosclz') then
2459         call adios2_add_operation(operation_id, VarID, DH%compress_operator, 'compressor', 'blosclz', stat)
2460       elseif (DH%blosc_compressor == 'zlib') then
2461         call adios2_add_operation(operation_id, VarID, DH%compress_operator, 'compressor', 'zlib', stat)
2462       elseif (DH%blosc_compressor == 'lz4') then
2463         call adios2_add_operation(operation_id, VarID, DH%compress_operator, 'compressor', 'lz4', stat)
2464       elseif (DH%blosc_compressor == 'lz4hc') then
2465         call adios2_add_operation(operation_id, VarID, DH%compress_operator, 'compressor', 'lz4hc', stat)
2466       elseif (DH%blosc_compressor == 'zstd') then
2467           call adios2_add_operation(operation_id, VarID, DH%compress_operator, 'compressor', 'zstd', stat)
2468       endif
2469       call adios2_err(stat,Status)
2470       if(Status /= WRF_NO_ERR) then
2471         write(msg,*) 'ext_adios2_write_field: adios2 error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2472         call wrf_debug ( WARN , TRIM(msg))
2473         return
2474       endif
2475     endif
2476     DH%VarIDs(NVar) = VarID
2477     ! add attribute of dimension names (for reconstructing NetCDF file with converter)
2478     do j = 1,NDim
2479       DimNamesOut(j) = DH%DimNames(VDimIDs(j))
2480     end do
2481     DimNamesOut(NDim+1) = DH%DimUnlimName
2482     call adios2_define_attribute(AttributeID,DH%adios2IO, 'Dims', &
2483               DimNamesOut, NDim+1, VarID%name, '/', stat)
2484     call adios2_err(stat,Status)
2485     if(Status /= WRF_NO_ERR) then
2486       write(msg,*) 'ext_adios2_write_field: adios2 error in ',__FILE__,', line', __LINE__
2487       call wrf_debug ( WARN , TRIM(msg))
2488       return
2489     endif
2490     call adios2_define_attribute(AttributeID,DH%adios2IO, 'FieldType', &
2491               FieldType, VarID%name, stat)
2492     call adios2_err(stat,Status)
2493     if(Status /= WRF_NO_ERR) then
2494       write(msg,*) 'ext_adios2_write_field: adios2 error in ',__FILE__,', line', __LINE__
2495       call wrf_debug ( WARN , TRIM(msg))
2496       return
2497     endif
2498     call reorder(MemoryOrder,MemO)
2499     call uppercase(MemO,UCMemO)
2500     call adios2_define_attribute(AttributeID, DH%adios2IO, 'MemoryOrder', &
2501              UCMemO, VarID%name, stat)
2502     call adios2_err(stat,Status)
2503     if(Status /= WRF_NO_ERR) then
2504       write(msg,*) 'ext_adios2_write_field: adios2 error in ',__FILE__,', line', __LINE__
2505       call wrf_debug ( WARN , TRIM(msg))
2506       return
2507     endif
2508   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
2509     do NVar=1,DH%NumVars
2510       if(DH%VarNames(NVar) == VarName) then
2511         exit
2512       elseif(NVar == DH%NumVars) then
2513         Status = WRF_WARN_VAR_NF
2514         write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__
2515         call wrf_debug ( WARN , TRIM(msg))
2516         return
2517       endif
2518     enddo
2519     VarID = DH%VarIDs(NVar)
2520     do j=1,NDim
2521       if(Length_global(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then
2522         Status = WRF_WARN_WRTLEN_NE_DRRUNLEN
2523         write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |',   &
2524                      VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__
2525         call wrf_debug ( WARN , TRIM(msg))
2526         write(msg,*) '   LENGTH ',Length_global(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar)
2527         call wrf_debug ( WARN , TRIM(msg))
2528         return
2529 !jm 061024      elseif(PatchStart(j) < MemoryStart(j)) then
2530 !jm      elseif(DomainStart(j) < MemoryStart(j)) then
2531       elseif(PatchStart(j) < lMemoryStart(j)) then
2532         Status = WRF_WARN_DIMENSION_ERROR
2533         write(msg,*) 'Warning DIMENSION ERROR for |',VarName,    &
2534                      '| in ',__FILE__,', line', __LINE__
2535         call wrf_debug ( WARN , TRIM(msg))
2536         return
2537       endif
2538     enddo
2539     StoredStart = 1
2540     call GetIndices(NDim,lMemoryStart,lMemoryEnd,l1,l2,m1,m2,n1,n2)
2541     call GetIndices(NDim,StoredStart,Length   ,x1,x2,y1,y2,z1,z2)
2542     call GetIndices(NDim,StoredStart,Length_native   ,p1,p2,q1,q2,r1,r2)
2543     call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
2544     di=1
2545     if(FieldType == WRF_DOUBLE) di=2
2546     allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
2547     if(stat/= 0) then
2548       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
2549       write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
2550       call wrf_debug ( FATAL , TRIM(msg))
2551       return
2552     endif
2553 #if 0
2554     WRITE(msg,*) 'ARPDBG: MemoryStart = ',lMemoryStart(1:NDim)
2555     CALL wrf_message(msg)
2556     WRITE(msg,*) 'ARPDBG:  lMemoryEnd = ',lMemoryEnd(1:NDim)
2557     CALL wrf_message(msg)
2558     WRITE(msg,*) 'ARPDBG:      Length = ',Length(1:NDim)
2559     CALL wrf_message(msg)
2560 #endif
2561     call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2562                                             ,XField,x1,x2,y1,y2,z1,z2 &
2563                                                    ,i1,i2,j1,j2,k1,k2 )
2564     StoredStart(1:NDim) = PatchStart(1:NDim)
2565     call ExtOrder(MemoryOrder,StoredStart,Status)
2566     call FieldIO('write',DataHandle,DateStr,StoredStart,Length,MemoryOrder, &
2567                   FieldType,VarID,XField,Status)
2568     if(Status /= WRF_NO_ERR) then
2569       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2570       call wrf_debug ( WARN , TRIM(msg))
2571       return
2572     endif
2573     deallocate(XField, STAT=stat)
2574     if(stat/= 0) then
2575       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
2576       write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
2577       call wrf_debug ( FATAL , TRIM(msg))
2578       return
2579     endif
2580   else
2581     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2582     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2583     call wrf_debug ( FATAL , TRIM(msg))
2584   endif
2585   DH%first_operation  = .FALSE.
2586   return
2587 end subroutine ext_adios2_write_field
2588
2589 subroutine ext_adios2_read_field(DataHandle,DateStr,Var,Field,FieldType,  &
2590     DomainDesc, MemoryOrdIn, Stagger, DimNames,                           &
2591     DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2592   use wrf_data_adios2
2593   use ext_adios2_support_routines
2594   use adios2
2595   implicit none
2596   include 'wrf_status_codes.h'
2597   integer                       ,intent(in)    :: DataHandle
2598   character*(*)                 ,intent(in)    :: DateStr
2599   character*(*)                 ,intent(in)    :: Var
2600   integer                       ,intent(out)   :: Field(*)
2601   integer                       ,intent(in)    :: FieldType
2602   integer                       ,intent(in)    :: DomainDesc
2603   character*(*)                 ,intent(in)    :: MemoryOrdIn
2604   character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
2605   character*(*) , dimension (*) ,intent(in)    :: DimNames
2606   integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
2607   integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
2608   integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
2609   integer                       ,intent(out)   :: Status
2610   character (3)                                :: MemoryOrder
2611   type(wrf_data_handle)         ,pointer       :: DH
2612   integer                                      :: NDim
2613   character (VarNameLen)                       :: VarName
2614   type(adios2_variable)                        :: VarID
2615   integer ,dimension(NVarDims)                 :: VCount
2616   integer ,dimension(NVarDims)                 :: VStart
2617   integer ,dimension(NVarDims)                 :: Length
2618   integer ,dimension(NVarDims)                 :: VDimIDs
2619   integer ,dimension(NVarDims)                 :: MemS
2620   integer ,dimension(NVarDims)                 :: MemE
2621   integer ,dimension(NVarDims)                 :: StoredStart
2622   integer ,dimension(NVarDims)                 :: StoredLen
2623   integer ,dimension(:,:,:,:)   ,allocatable   :: XField
2624   integer                                      :: NVar
2625   integer                                      :: j
2626   integer                                      :: i1,i2,j1,j2,k1,k2
2627   integer                                      :: x1,x2,y1,y2,z1,z2
2628   integer                                      :: l1,l2,m1,m2,n1,n2
2629   character (VarNameLen)                       :: Name
2630   integer                                      :: XType
2631   integer                                      :: StoredDim
2632   integer                                      :: NAtts
2633   integer                                      :: stat
2634   integer                                      :: di
2635   integer                                      :: FType
2636   type(adios2_attribute)                       :: attribute
2637
2638   MemoryOrder = trim(adjustl(MemoryOrdIn))
2639   call GetDim(MemoryOrder,NDim,Status)
2640   if(Status /= WRF_NO_ERR) then
2641     write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', &
2642                  TRIM(Var),'| in ext_adios2_read_field ',__FILE__,', line', __LINE__
2643     call wrf_debug ( WARN , TRIM(msg))
2644     return
2645   endif
2646   call DateCheck(DateStr,Status)
2647   if(Status /= WRF_NO_ERR) then
2648     write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), &
2649                  '| in ext_adios2_read_field ',__FILE__,', line', __LINE__
2650     call wrf_debug ( WARN , TRIM(msg))
2651     return
2652   endif
2653   VarName = Var
2654   call GetDH(DataHandle,DH,Status)
2655   if(Status /= WRF_NO_ERR) then
2656     write(msg,*) 'Warning Status = ',Status,' in ext_adios2_read_field ',__FILE__,', line', __LINE__
2657     call wrf_debug ( WARN , TRIM(msg))
2658     return
2659   endif
2660   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2661     Status = WRF_WARN_FILE_NOT_OPENED
2662     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2663     call wrf_debug ( WARN , TRIM(msg))
2664   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2665 ! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return.
2666 !    Status = WRF_WARN_DRYRUN_READ
2667 !    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2668 !    call wrf_debug ( WARN , TRIM(msg))
2669     Status = WRF_NO_ERR
2670     RETURN
2671   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2672     Status = WRF_WARN_READ_WONLY_FILE
2673     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2674     call wrf_debug ( WARN , TRIM(msg))
2675   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
2676     Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2677     StoredStart(1:NDim) = PatchStart(1:NDim)
2678     call ExtOrder(MemoryOrder,Length,Status)
2679     call adios2_inquire_variable(VarID, DH%adios2IO, VarName, stat)
2680     call adios2_err(stat,Status)
2681     if(Status /= WRF_NO_ERR) then
2682       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__,' Varname ',Varname
2683       call wrf_debug ( WARN , TRIM(msg))
2684       return
2685     endif
2686     call adios2_inquire_variable_attribute(attribute, DH%adios2IO, 'FieldType', VarName, '/', stat)
2687     call adios2_err(stat,Status)
2688     if(Status /= WRF_NO_ERR) then
2689       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
2690       call wrf_debug ( WARN , TRIM(msg))
2691       return
2692     endif
2693     call adios2_attribute_data(FType, attribute, stat)
2694     if(Status /= WRF_NO_ERR) then
2695       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
2696       call wrf_debug ( WARN , TRIM(msg))
2697       return
2698     endif
2699 ! allow coercion between double and single prec real
2700 !jm    if(FieldType /= Ftype) then
2701     if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
2702       if ( .NOT. (Ftype     == WRF_REAL .OR. Ftype     == WRF_DOUBLE ))  then
2703         Status = WRF_WARN_TYPE_MISMATCH
2704         write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2705         call wrf_debug ( WARN , TRIM(msg))
2706         return
2707       endif
2708     else if(FieldType /= Ftype) then
2709       Status = WRF_WARN_TYPE_MISMATCH
2710       write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2711       call wrf_debug ( WARN , TRIM(msg))
2712       return
2713     endif
2714     StoredDim = VarID%ndims
2715     XType = VarID%type
2716     select case (FieldType)
2717       case (WRF_REAL)
2718 ! allow coercion between double and single prec real
2719         if(.NOT. (XType == adios2_type_real .OR. XType == adios2_type_dp ) )  then
2720           Status = WRF_WARN_TYPE_MISMATCH
2721           write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2722         endif
2723       case (WRF_DOUBLE)
2724 ! allow coercion between double and single prec real
2725         if(.NOT. (XType == adios2_type_real .OR. XType == adios2_type_dp) )  then
2726           Status = WRF_WARN_TYPE_MISMATCH
2727           write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__
2728         endif
2729       case (WRF_INTEGER)
2730         if(XType /= adios2_type_integer4)  then
2731           Status = WRF_WARN_TYPE_MISMATCH
2732           write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__
2733         endif
2734       case (WRF_LOGICAL)
2735         if(XType /= adios2_type_integer4)  then
2736           Status = WRF_WARN_TYPE_MISMATCH
2737           write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2738         endif
2739       case default
2740         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2741         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2742     end select
2743     if(Status /= WRF_NO_ERR) then
2744       call wrf_debug ( WARN , TRIM(msg))
2745       return
2746     endif
2747     StoredStart = 1
2748     call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
2749     call GetIndices(NDim,StoredStart,Length,x1,x2,y1,y2,z1,z2)
2750 !jm    call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2)
2751     call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
2752
2753     StoredStart(1:NDim) = PatchStart(1:NDim)
2754     call ExtOrder(MemoryOrder,StoredStart,Status)
2755
2756     di=1
2757     if(FieldType == WRF_DOUBLE) di=2
2758     allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
2759     if(stat/= 0) then
2760       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
2761       write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
2762       call wrf_debug ( FATAL , msg)
2763       return
2764     endif
2765     call FieldIO('read',DataHandle,DateStr,StoredStart,Length,MemoryOrder, &
2766                   FieldType,VarID,XField,Status)
2767     if(Status /= WRF_NO_ERR) then
2768       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2769       call wrf_debug ( WARN , TRIM(msg))
2770       return
2771     endif
2772     call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2773                                         ,XField,x1,x2,y1,y2,z1,z2 &
2774                                                ,i1,i2,j1,j2,k1,k2 )
2775     deallocate(XField, STAT=stat)
2776     if(stat/= 0) then
2777       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
2778       write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
2779       call wrf_debug ( FATAL , msg)
2780       return
2781     endif
2782   else
2783     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2784     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2785     call wrf_debug ( FATAL , msg)
2786   endif
2787   DH%first_operation  = .FALSE.
2788   return
2789 end subroutine ext_adios2_read_field
2790
2791 subroutine ext_adios2_inquire_opened( DataHandle, FileName , FileStatus, Status )
2792   use wrf_data_adios2
2793   use ext_adios2_support_routines
2794   implicit none
2795   include 'wrf_status_codes.h'
2796   integer               ,intent(in)     :: DataHandle
2797   character*(*)         ,intent(in)     :: FileName
2798   integer               ,intent(out)    :: FileStatus
2799   integer               ,intent(out)    :: Status
2800   type(wrf_data_handle) ,pointer        :: DH
2801
2802   call GetDH(DataHandle,DH,Status)
2803   if(Status /= WRF_NO_ERR) then
2804     FileStatus = WRF_FILE_NOT_OPENED
2805     return
2806   endif
2807   if(FileName /= DH%FileName) then
2808     FileStatus = WRF_FILE_NOT_OPENED
2809   else
2810     FileStatus = DH%FileStatus
2811   endif
2812   Status = WRF_NO_ERR
2813   return
2814 end subroutine ext_adios2_inquire_opened
2815
2816 subroutine ext_adios2_inquire_filename( Datahandle, FileName,  FileStatus, Status )
2817   use wrf_data_adios2
2818   use ext_adios2_support_routines
2819   implicit none
2820   include 'wrf_status_codes.h'
2821   integer               ,intent(in)     :: DataHandle
2822   character*(*)         ,intent(out)    :: FileName
2823   integer               ,intent(out)    :: FileStatus
2824   integer               ,intent(out)    :: Status
2825   type(wrf_data_handle) ,pointer        :: DH
2826
2827   FileStatus = WRF_FILE_NOT_OPENED
2828   call GetDH(DataHandle,DH,Status)
2829   if(Status /= WRF_NO_ERR) then
2830     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2831     call wrf_debug ( WARN , TRIM(msg))
2832     return
2833   endif
2834   FileName = DH%FileName
2835   FileStatus = DH%FileStatus
2836   Status = WRF_NO_ERR
2837   return
2838 end subroutine ext_adios2_inquire_filename
2839
2840 subroutine ext_adios2_set_time(DataHandle, DateStr, Status)
2841   use wrf_data_adios2
2842   use ext_adios2_support_routines
2843   implicit none
2844   include 'wrf_status_codes.h'
2845   integer               ,intent(in)     :: DataHandle
2846   character*(*)         ,intent(in)     :: DateStr
2847   integer               ,intent(out)    :: Status
2848   type(wrf_data_handle) ,pointer        :: DH
2849   integer                               :: i
2850
2851   call DateCheck(DateStr,Status)
2852   if(Status /= WRF_NO_ERR) then
2853     write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2854     call wrf_debug ( WARN , TRIM(msg))
2855     return
2856   endif
2857   call GetDH(DataHandle,DH,Status)
2858   if(Status /= WRF_NO_ERR) then
2859     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2860     call wrf_debug ( WARN , TRIM(msg))
2861     return
2862   endif
2863   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2864     Status = WRF_WARN_FILE_NOT_OPENED
2865     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2866     call wrf_debug ( WARN , TRIM(msg))
2867   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2868     Status = WRF_WARN_FILE_NOT_COMMITTED
2869     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
2870     call wrf_debug ( WARN , TRIM(msg))
2871   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2872     Status = WRF_WARN_READ_WONLY_FILE
2873     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2874     call wrf_debug ( WARN , TRIM(msg))
2875   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2876     do i=1,MaxTimes
2877       if(DH%Times(i)==DateStr) then
2878         DH%CurrentTime = i
2879         exit
2880       endif
2881       if(i==MaxTimes) then
2882         Status = WRF_WARN_TIME_NF
2883         return
2884       endif
2885     enddo
2886     DH%CurrentVariable = 0
2887     Status = WRF_NO_ERR
2888   else
2889     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2890     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2891     call wrf_debug ( FATAL , msg)
2892   endif
2893   return
2894 end subroutine ext_adios2_set_time
2895
2896 subroutine ext_adios2_get_next_time(DataHandle, DateStr, Status)
2897   use wrf_data_adios2
2898   use ext_adios2_support_routines
2899   implicit none
2900   include 'wrf_status_codes.h'
2901   integer               ,intent(in)     :: DataHandle
2902   character*(*)         ,intent(out)    :: DateStr
2903   integer               ,intent(out)    :: Status
2904   type(wrf_data_handle) ,pointer        :: DH
2905
2906   call GetDH(DataHandle,DH,Status)
2907   if(Status /= WRF_NO_ERR) then
2908     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2909     call wrf_debug ( WARN , TRIM(msg))
2910     return
2911   endif
2912   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2913     Status = WRF_WARN_FILE_NOT_OPENED
2914     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2915     call wrf_debug ( WARN , TRIM(msg))
2916   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2917     Status = WRF_WARN_DRYRUN_READ
2918     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2919     call wrf_debug ( WARN , TRIM(msg))
2920   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2921     Status = WRF_WARN_READ_WONLY_FILE
2922     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2923     call wrf_debug ( WARN , TRIM(msg))
2924   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
2925     if(DH%CurrentTime >= DH%NumberTimes) then
2926       write(msg,*) 'Warning ext_adios2_get_next_time: DH%CurrentTime >= DH%NumberTimes ',DH%CurrentTime,DH%NumberTimes
2927       call wrf_debug ( WARN , TRIM(msg))
2928       Status = WRF_WARN_TIME_EOF
2929       return
2930     endif
2931     DH%CurrentTime     = DH%CurrentTime + 1
2932     DateStr            = DH%Times(DH%CurrentTime)
2933     DH%CurrentVariable = 0
2934     Status = WRF_NO_ERR
2935   else
2936     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2937     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2938     call wrf_debug ( FATAL , msg)
2939   endif
2940   return
2941 end subroutine ext_adios2_get_next_time
2942
2943 subroutine ext_adios2_get_previous_time(DataHandle, DateStr, Status)
2944   use wrf_data_adios2
2945   use ext_adios2_support_routines
2946   implicit none
2947   include 'wrf_status_codes.h'
2948   integer               ,intent(in)     :: DataHandle
2949   character*(*)         ,intent(out)    :: DateStr
2950   integer               ,intent(out)    :: Status
2951   type(wrf_data_handle) ,pointer        :: DH
2952
2953   call GetDH(DataHandle,DH,Status)
2954   if(Status /= WRF_NO_ERR) then
2955     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2956     call wrf_debug ( WARN , TRIM(msg))
2957     return
2958   endif
2959   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2960     Status = WRF_WARN_FILE_NOT_OPENED
2961     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2962     call wrf_debug ( WARN , TRIM(msg))
2963   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2964     Status = WRF_WARN_DRYRUN_READ
2965     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2966     call wrf_debug ( WARN , TRIM(msg))
2967   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2968     Status = WRF_WARN_READ_WONLY_FILE
2969     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2970     call wrf_debug ( WARN , TRIM(msg))
2971   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2972     if(DH%CurrentTime.GT.0) then
2973       DH%CurrentTime     = DH%CurrentTime -1
2974     endif
2975     DateStr            = DH%Times(DH%CurrentTime)
2976     DH%CurrentVariable = 0
2977     Status = WRF_NO_ERR
2978   else
2979     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2980     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2981     call wrf_debug ( FATAL , msg)
2982   endif
2983   return
2984 end subroutine ext_adios2_get_previous_time
2985
2986 subroutine ext_adios2_get_next_var(DataHandle, VarName, Status)
2987   use wrf_data_adios2
2988   use ext_adios2_support_routines
2989   implicit none
2990   include 'wrf_status_codes.h'
2991   integer               ,intent(in)     :: DataHandle
2992   character*(*)         ,intent(out)    :: VarName
2993   integer               ,intent(out)    :: Status
2994   type(wrf_data_handle) ,pointer        :: DH
2995   integer                               :: stat
2996   character (80)                        :: Name
2997
2998   call GetDH(DataHandle,DH,Status)
2999   if(Status /= WRF_NO_ERR) then
3000     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3001     call wrf_debug ( WARN , TRIM(msg))
3002     return
3003   endif
3004   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3005     Status = WRF_WARN_FILE_NOT_OPENED
3006     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3007     call wrf_debug ( WARN , TRIM(msg))
3008   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3009     Status = WRF_WARN_DRYRUN_READ
3010     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3011     call wrf_debug ( WARN , TRIM(msg))
3012   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3013     Status = WRF_WARN_READ_WONLY_FILE
3014     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3015     call wrf_debug ( WARN , TRIM(msg))
3016   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3017     DH%CurrentVariable = DH%CurrentVariable +1
3018     if(DH%CurrentVariable > DH%NumVars) then
3019       Status = WRF_WARN_VAR_EOF
3020       return
3021     endif
3022     VarName = DH%VarNames(DH%CurrentVariable)
3023     Status  = WRF_NO_ERR
3024   else
3025     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3026     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3027     call wrf_debug ( FATAL , msg)
3028   endif
3029   return
3030 end subroutine ext_adios2_get_next_var
3031
3032 subroutine ext_adios2_end_of_frame(DataHandle, Status)
3033   use wrf_data_adios2
3034   use ext_adios2_support_routines
3035   implicit none
3036   include 'wrf_status_codes.h'
3037   integer               ,intent(in)     :: DataHandle
3038   integer               ,intent(out)    :: Status
3039   type(wrf_data_handle) ,pointer        :: DH
3040
3041   call GetDH(DataHandle,DH,Status)
3042   return
3043 end subroutine ext_adios2_end_of_frame
3044
3045 subroutine ext_adios2_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status)
3046   use wrf_data_adios2
3047   use ext_adios2_support_routines
3048   use adios2
3049   implicit none
3050   include 'wrf_status_codes.h'
3051   integer               ,intent(in)          :: DataHandle
3052   character*(*)         ,intent(in)          :: Name
3053   integer               ,intent(out)         :: NDim
3054   character*(*)         ,intent(out)         :: MemoryOrder
3055   character*(*)                              :: Stagger ! Dummy for now
3056   integer ,dimension(*) ,intent(out)         :: DomainStart, DomainEnd
3057   integer               ,intent(out)         :: WrfType
3058   integer               ,intent(out)         :: Status
3059   type(wrf_data_handle) ,pointer             :: DH
3060   type(adios2_variable)                      :: VarID
3061   integer ,dimension(NVarDims)               :: VDimIDs
3062   integer                                    :: j
3063   integer                                    :: stat
3064   integer                                    :: XType
3065   type(adios2_attribute)                     :: attribute
3066   integer(kind=8), dimension(:), allocatable :: shape_dims
3067   integer                                    :: ndims_adios2
3068
3069   call GetDH(DataHandle,DH,Status)
3070   if(Status /= WRF_NO_ERR) then
3071     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3072     call wrf_debug ( WARN , TRIM(msg))
3073     return
3074   endif
3075   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3076     Status = WRF_WARN_FILE_NOT_OPENED
3077     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3078     call wrf_debug ( WARN , TRIM(msg))
3079     return
3080   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3081     Status = WRF_WARN_DRYRUN_READ
3082     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3083     call wrf_debug ( WARN , TRIM(msg))
3084     return
3085   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3086     Status = WRF_WARN_READ_WONLY_FILE
3087     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3088     call wrf_debug ( WARN , TRIM(msg))
3089     return
3090   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3091     call adios2_inquire_variable(VarID, DH%adios2IO, Name, stat)
3092     call adios2_err(stat,Status)
3093     if(Status /= WRF_NO_ERR) then
3094       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3095       call wrf_debug ( WARN , TRIM(msg))
3096       return
3097     endif
3098     XType = VarID%type
3099     call adios2_inquire_variable_attribute(attribute, DH%adios2IO, 'FieldType', Name, '/', stat)
3100     call adios2_err(stat,Status)
3101     if(Status /= WRF_NO_ERR) then
3102       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3103       call wrf_debug ( WARN , TRIM(msg))
3104       return
3105     endif
3106     call adios2_attribute_data(WrfType, attribute, stat)
3107     call adios2_err(stat,Status)
3108     if(Status /= WRF_NO_ERR) then
3109       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3110       call wrf_debug ( WARN , TRIM(msg))
3111       return
3112     endif
3113     select case (XType)
3114       case (adios2_type_character)
3115         Status = WRF_WARN_BAD_DATA_TYPE
3116         write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3117         call wrf_debug ( WARN , TRIM(msg))
3118         return
3119       case (adios2_type_integer4)
3120         if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then
3121           Status = WRF_WARN_BAD_DATA_TYPE
3122           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3123           call wrf_debug ( WARN , TRIM(msg))
3124           return
3125         endif
3126       case (adios2_type_real)
3127         if(WrfType /= WRF_REAL) then
3128           Status = WRF_WARN_BAD_DATA_TYPE
3129           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3130           call wrf_debug ( WARN , TRIM(msg))
3131           return
3132         endif
3133       case (adios2_type_dp)
3134         if(WrfType /= WRF_DOUBLE) then
3135           Status = WRF_WARN_BAD_DATA_TYPE
3136           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3137           call wrf_debug ( WARN , TRIM(msg))
3138           return
3139         endif
3140       case default
3141         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
3142         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
3143         call wrf_debug ( WARN , TRIM(msg))
3144         return
3145     end select
3146     call adios2_inquire_variable_attribute(attribute, DH%adios2IO, 'MemoryOrder', Name, '/', stat)
3147     call adios2_err(stat,Status)
3148     if(Status /= WRF_NO_ERR) then
3149       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3150       call wrf_debug ( WARN , TRIM(msg))
3151       return
3152     endif
3153     call adios2_attribute_data(MemoryOrder, attribute, stat)
3154     call adios2_err(stat,Status)
3155     if(Status /= WRF_NO_ERR) then
3156       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3157       call wrf_debug ( WARN , TRIM(msg))
3158       return
3159     endif
3160     call GetDim(MemoryOrder,NDim,Status)
3161     if(Status /= WRF_NO_ERR) then
3162       write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__
3163       call wrf_debug ( WARN , TRIM(msg))
3164       return
3165     endif
3166     call adios2_variable_shape(shape_dims, ndims_adios2, VarID, stat)
3167     call adios2_err(stat,Status)
3168     if(Status /= WRF_NO_ERR) then
3169       write(msg,*) 'adios2 error in ',__FILE__,', line', __LINE__
3170       call wrf_debug ( WARN , TRIM(msg))
3171       return
3172     endif
3173     DomainEnd(1:NDim) = shape_dims(1:NDim)
3174   else
3175     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3176     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3177     call wrf_debug ( FATAL , msg)
3178   endif
3179   return
3180 end subroutine ext_adios2_get_var_info