external/io_netcdf/wrf_io.F90

   1 !*------------------------------------------------------------------------------
   2 !*  Standard Disclaimer
   3 !*
   4 !*  Forecast Systems Laboratory
   5 !*  NOAA/OAR/ERL/FSL
   6 !*  325 Broadway
   7 !*  Boulder, CO     80303
   8 !*
   9 !*  AVIATION DIVISION
  10 !*  ADVANCED COMPUTING BRANCH
  11 !*  SMS/NNT Version: 2.0.0
  12 !*
  13 !*  This software and its documentation are in the public domain and
  14 !*  are furnished "as is".  The United States government, its
  15 !*  instrumentalities, officers, employees, and agents make no
  16 !*  warranty, express or implied, as to the usefulness of the software
  17 !*  and documentation for any purpose.  They assume no
  18 !*  responsibility (1) for the use of the software and documentation;
  19 !*  or (2) to provide technical support to users.
  20 !*
  21 !*  Permission to use, copy, modify, and distribute this software is
  22 !*  hereby granted, provided that this disclaimer notice appears in
  23 !*  all copies.  All modifications to this software must be clearly
  24 !*  documented, and are solely the responsibility of the agent making
  25 !*  the modification.  If significant modifications or enhancements
  26 !*  are made to this software, the SMS Development team
  27 !*  (sms-info@fsl.noaa.gov) should be notified.
  28 !*
  29 !*----------------------------------------------------------------------------
  30 !*
  31 !*  WRF NetCDF I/O
  32 !   Author:  Jacques Middlecoff jacquesm@fsl.noaa.gov
  33 !*  Date:    October 6, 2000
  34 !*
  35 !*----------------------------------------------------------------------------
  36
  37 module wrf_data
  38
  39   integer                , parameter      :: FATAL            = 1
  40   integer                , parameter      :: WARN             = 1
  41   integer                , parameter      :: WrfDataHandleMax = 99
  42   integer                , parameter      :: MaxDims          = 2000 ! = NF_MAX_VARS
  43 #if(WRF_CHEM == 1)
  44   integer                , parameter      :: MaxVars          = 10000
  45 #else
  46   integer                , parameter      :: MaxVars          = 3000
  47 #endif
  48   integer                , parameter      :: MaxTimes         = 60000
  49   integer                , parameter      :: DateStrLen       = 19
  50   integer                , parameter      :: VarNameLen       = 31
  51   integer                , parameter      :: NO_DIM           = 0
  52   integer                , parameter      :: NVarDims         = 4
  53   integer                , parameter      :: NMDVarDims       = 2
  54   character (8)          , parameter      :: NO_NAME          = 'NULL'
  55   character (DateStrLen) , parameter      :: ZeroDate = '0000-00-00-00:00:00'
  56
  57 #include "wrf_io_flags.h"
  58
  59   character (256)                         :: msg
  60   logical                                 :: WrfIOnotInitialized = .true.
  61
  62   type :: wrf_data_handle
  63     character (255)                       :: FileName
  64     integer                               :: FileStatus
  65     integer                               :: Comm
  66     integer                               :: NCID
  67     logical                               :: Free
  68     logical                               :: Write
  69     character (5)                         :: TimesName
  70     integer                               :: TimeIndex
  71     integer                               :: CurrentTime  !Only used for read
  72     integer                               :: NumberTimes  !Only used for read
  73     character (DateStrLen), pointer       :: Times(:)
  74     integer                               :: TimesVarID
  75     integer               , pointer       :: DimLengths(:)
  76     integer               , pointer       :: DimIDs(:)
  77     character (31)        , pointer       :: DimNames(:)
  78     integer                               :: DimUnlimID
  79     character (9)                         :: DimUnlimName
  80     integer       , dimension(NVarDims)   :: DimID
  81     integer       , dimension(NVarDims)   :: Dimension
  82     integer               , pointer       :: MDVarIDs(:)
  83     integer               , pointer       :: MDVarDimLens(:)
  84     character (80)        , pointer       :: MDVarNames(:)
  85     integer               , pointer       :: VarIDs(:)
  86     integer               , pointer       :: VarDimLens(:,:)
  87     character (VarNameLen), pointer       :: VarNames(:)
  88     integer                               :: CurrentVariable  !Only used for read
  89     integer                               :: NumVars
  90 ! first_operation is set to .TRUE. when a new handle is allocated
  91 ! or when open-for-write or open-for-read are committed.  It is set
  92 ! to .FALSE. when the first field is read or written.
  93     logical                               :: first_operation
  94     logical                               :: R4OnOutput
  95     logical                               :: nofill
  96     logical                               :: use_netcdf_classic
  97   end type wrf_data_handle
  98   type(wrf_data_handle),target            :: WrfDataHandles(WrfDataHandleMax)
  99 end module wrf_data
 100
 101 module ext_ncd_support_routines
 102
 103   implicit none
 104
 105 CONTAINS
 106
 107 subroutine allocHandle(DataHandle,DH,Comm,Status)
 108   use wrf_data
 109   include 'wrf_status_codes.h'
 110   integer              ,intent(out) :: DataHandle
 111   type(wrf_data_handle),pointer     :: DH
 112   integer              ,intent(IN)  :: Comm
 113   integer              ,intent(out) :: Status
 114   integer                           :: i
 115   integer                           :: stat
 116
 117   do i=1,WrfDataHandleMax
 118     if(WrfDataHandles(i)%Free) then
 119       DH => WrfDataHandles(i)
 120       DataHandle = i
 121       allocate(DH%Times(MaxTimes), STAT=stat)
 122       if(stat/= 0) then
 123         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 124         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 125         call wrf_debug ( FATAL , msg)
 126         return
 127       endif
 128       allocate(DH%DimLengths(MaxDims), STAT=stat)
 129       if(stat/= 0) then
 130         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 131         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 132         call wrf_debug ( FATAL , msg)
 133         return
 134       endif
 135       allocate(DH%DimIDs(MaxDims), STAT=stat)
 136       if(stat/= 0) then
 137         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 138         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 139         call wrf_debug ( FATAL , msg)
 140         return
 141       endif
 142       allocate(DH%DimNames(MaxDims), STAT=stat)
 143       if(stat/= 0) then
 144         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 145         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 146         call wrf_debug ( FATAL , msg)
 147         return
 148       endif
 149       allocate(DH%MDVarIDs(MaxVars), STAT=stat)
 150       if(stat/= 0) then
 151         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 152         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 153         call wrf_debug ( FATAL , msg)
 154         return
 155       endif
 156       allocate(DH%MDVarDimLens(MaxVars), STAT=stat)
 157       if(stat/= 0) then
 158         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 159         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 160         call wrf_debug ( FATAL , msg)
 161         return
 162       endif
 163       allocate(DH%MDVarNames(MaxVars), STAT=stat)
 164       if(stat/= 0) then
 165         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 166         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 167         call wrf_debug ( FATAL , msg)
 168         return
 169       endif
 170       allocate(DH%VarIDs(MaxVars), STAT=stat)
 171       if(stat/= 0) then
 172         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 173         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 174         call wrf_debug ( FATAL , msg)
 175         return
 176       endif
 177       allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat)
 178       if(stat/= 0) then
 179         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 180         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 181         call wrf_debug ( FATAL , msg)
 182         return
 183       endif
 184       allocate(DH%VarNames(MaxVars), STAT=stat)
 185       if(stat/= 0) then
 186         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 187         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 188         call wrf_debug ( FATAL , msg)
 189         return
 190       endif
 191       exit
 192     endif
 193     if(i==WrfDataHandleMax) then
 194       Status = WRF_WARN_TOO_MANY_FILES
 195       write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__
 196       call wrf_debug ( WARN , TRIM(msg))
 197       write(msg,*) 'Did you call ext_ncd_ioinit?'
 198       call wrf_debug ( WARN , TRIM(msg))
 199       return
 200     endif
 201   enddo
 202   DH%Free      =.false.
 203   DH%Comm      = Comm
 204   DH%Write     =.false.
 205   DH%first_operation  = .TRUE.
 206   DH%R4OnOutput = .false.
 207   DH%nofill = .false.
 208   Status = WRF_NO_ERR
 209 end subroutine allocHandle
 210
 211 subroutine deallocHandle(DataHandle, Status)
 212   use wrf_data
 213   include 'wrf_status_codes.h'
 214   integer              ,intent(in) :: DataHandle
 215   integer              ,intent(out) :: Status
 216   type(wrf_data_handle),pointer     :: DH
 217   integer                           :: i
 218   integer                           :: stat
 219
 220   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN
 221     if(.NOT. WrfDataHandles(DataHandle)%Free) then
 222       DH => WrfDataHandles(DataHandle)
 223       deallocate(DH%Times, STAT=stat)
 224       if(stat/= 0) then
 225         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 226         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 227         call wrf_debug ( FATAL , msg)
 228         return
 229       endif
 230       deallocate(DH%DimLengths, STAT=stat)
 231       if(stat/= 0) then
 232         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 233         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 234         call wrf_debug ( FATAL , msg)
 235         return
 236       endif
 237       deallocate(DH%DimIDs, STAT=stat)
 238       if(stat/= 0) then
 239         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 240         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 241         call wrf_debug ( FATAL , msg)
 242         return
 243       endif
 244       deallocate(DH%DimNames, STAT=stat)
 245       if(stat/= 0) then
 246         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 247         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
 248         call wrf_debug ( FATAL , msg)
 249         return
 250       endif
 251       deallocate(DH%MDVarIDs, STAT=stat)
 252       if(stat/= 0) then
 253         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 254         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 255         call wrf_debug ( FATAL , msg)
 256         return
 257       endif
 258       deallocate(DH%MDVarDimLens, STAT=stat)
 259       if(stat/= 0) then
 260         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 261         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 262         call wrf_debug ( FATAL , msg)
 263         return
 264       endif
 265       deallocate(DH%MDVarNames, STAT=stat)
 266       if(stat/= 0) then
 267         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 268         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 269         call wrf_debug ( FATAL , msg)
 270         return
 271       endif
 272       deallocate(DH%VarIDs, STAT=stat)
 273       if(stat/= 0) then
 274         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 275         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 276         call wrf_debug ( FATAL , msg)
 277         return
 278       endif
 279       deallocate(DH%VarDimLens, STAT=stat)
 280       if(stat/= 0) then
 281         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 282         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 283         call wrf_debug ( FATAL , msg)
 284         return
 285       endif
 286       deallocate(DH%VarNames, STAT=stat)
 287       if(stat/= 0) then
 288         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 289         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
 290         call wrf_debug ( FATAL , msg)
 291         return
 292       endif
 293       DH%Free      =.TRUE.
 294     endif
 295   ENDIF
 296   Status = WRF_NO_ERR
 297 end subroutine deallocHandle
 298
 299 subroutine GetDH(DataHandle,DH,Status)
 300   use wrf_data
 301   include 'wrf_status_codes.h'
 302   integer               ,intent(in)     :: DataHandle
 303   type(wrf_data_handle) ,pointer        :: DH
 304   integer               ,intent(out)    :: Status
 305
 306   if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then
 307     Status = WRF_WARN_BAD_DATA_HANDLE
 308     return
 309   endif
 310   DH => WrfDataHandles(DataHandle)
 311   if(DH%Free) then
 312     Status = WRF_WARN_BAD_DATA_HANDLE
 313     return
 314   endif
 315   Status = WRF_NO_ERR
 316   return
 317 end subroutine GetDH
 318
 319 subroutine DateCheck(Date,Status)
 320   use wrf_data
 321   include 'wrf_status_codes.h'
 322   character*(*) ,intent(in)      :: Date
 323   integer       ,intent(out)     :: Status
 324
 325   if(len(Date) /= DateStrLen) then
 326     Status = WRF_WARN_DATESTR_BAD_LENGTH
 327   else
 328     Status = WRF_NO_ERR
 329   endif
 330   return
 331 end subroutine DateCheck
 332
 333 subroutine GetName(Element,Var,Name,Status)
 334   use wrf_data
 335   include 'wrf_status_codes.h'
 336   character*(*) ,intent(in)     :: Element
 337   character*(*) ,intent(in)     :: Var
 338   character*(*) ,intent(out)    :: Name
 339   integer       ,intent(out)    :: Status
 340   character (VarNameLen)        :: VarName
 341   character (1)                 :: c
 342   integer                       :: i
 343   integer, parameter            ::  upper_to_lower =IACHAR('a')-IACHAR('A')
 344
 345   VarName = Var
 346   Name = 'MD___'//trim(Element)//VarName
 347   do i=1,len(Name)
 348     c=Name(i:i)
 349     if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower)
 350     if(c=='-'.or.c==':') Name(i:i)='_'
 351   enddo
 352   Status = WRF_NO_ERR
 353   return
 354 end subroutine GetName
 355
 356 subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
 357   use wrf_data
 358   include 'wrf_status_codes.h'
 359   include 'netcdf.inc'
 360   character (*)         ,intent(in)     :: IO
 361   integer               ,intent(in)     :: DataHandle
 362   character*(*)         ,intent(in)     :: DateStr
 363   integer               ,intent(out)    :: TimeIndex
 364   integer               ,intent(out)    :: Status
 365   type(wrf_data_handle) ,pointer        :: DH
 366   integer                               :: VStart(2)
 367   integer                               :: VCount(2)
 368   integer                               :: stat
 369   integer                               :: i
 370
 371   DH => WrfDataHandles(DataHandle)
 372   call DateCheck(DateStr,Status)
 373   if(Status /= WRF_NO_ERR) then
 374     Status =  WRF_WARN_DATESTR_ERROR
 375     write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
 376     call wrf_debug ( WARN , TRIM(msg))
 377     return
 378   endif
 379   if(IO == 'write') then
 380     TimeIndex = DH%TimeIndex
 381     if(TimeIndex <= 0) then
 382       TimeIndex = 1
 383     elseif(DateStr == DH%Times(TimeIndex)) then
 384       Status = WRF_NO_ERR
 385       return
 386     else
 387       TimeIndex = TimeIndex +1
 388       if(TimeIndex > MaxTimes) then
 389         Status = WRF_WARN_TIME_EOF
 390         write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__
 391         call wrf_debug ( WARN , TRIM(msg))
 392         return
 393       endif
 394     endif
 395     DH%TimeIndex        = TimeIndex
 396     DH%Times(TimeIndex) = DateStr
 397     VStart(1) = 1
 398     VStart(2) = TimeIndex
 399     VCount(1) = DateStrLen
 400     VCount(2) = 1
 401     stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr)
 402     call netcdf_err(stat,Status)
 403     if(Status /= WRF_NO_ERR) then
 404       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
 405       call wrf_debug ( WARN , TRIM(msg))
 406       return
 407     endif
 408   else
 409     do i=1,MaxTimes
 410       if(DH%Times(i)==DateStr) then
 411         Status = WRF_NO_ERR
 412         TimeIndex = i
 413         exit
 414       endif
 415       if(i==MaxTimes) then
 416         Status = WRF_WARN_TIME_NF
 417         write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__
 418         call wrf_debug ( WARN , TRIM(msg))
 419         return
 420       endif
 421     enddo
 422   endif
 423   return
 424 end subroutine GetTimeIndex
 425
 426 subroutine GetDim(MemoryOrder,NDim,Status)
 427   include 'wrf_status_codes.h'
 428   character*(*) ,intent(in)  :: MemoryOrder
 429   integer       ,intent(out) :: NDim
 430   integer       ,intent(out) :: Status
 431   character*3                :: MemOrd
 432
 433   call LowerCase(MemoryOrder,MemOrd)
 434   select case (MemOrd)
 435     case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
 436       NDim = 3
 437     case ('xy','yx','xs','xe','ys','ye','cc')
 438       NDim = 2
 439     case ('z','c')
 440       NDim = 1
 441     case ('0')  ! NDim=0 for scalars.  TBH:  20060502
 442       NDim = 0
 443     case default
 444       Status = WRF_WARN_BAD_MEMORYORDER
 445       return
 446   end select
 447   Status = WRF_NO_ERR
 448   return
 449 end subroutine GetDim
 450
 451 #ifdef USE_NETCDF4_FEATURES
 452 subroutine set_chunking(MemoryOrder,need_chunking)
 453   include 'wrf_status_codes.h'
 454   character*(*) ,intent(in)  :: MemoryOrder
 455   logical       ,intent(out) :: need_chunking
 456   character*3                :: MemOrd
 457
 458   call LowerCase(MemoryOrder,MemOrd)
 459   if(len(MemOrd) >= 2) then
 460      select case (MemOrd)
 461         case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
 462              need_chunking = .true.
 463         case ('xy','yx')
 464              need_chunking = .true.
 465         case default
 466              need_chunking = .false.
 467              return
 468       end select
 469   endif
 470 end subroutine set_chunking
 471 #endif
 472
 473 subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2)
 474   integer              ,intent(in)  :: NDim
 475   integer ,dimension(*),intent(in)  :: Start,End
 476   integer              ,intent(out) :: i1,i2,j1,j2,k1,k2
 477
 478   i1=1
 479   i2=1
 480   j1=1
 481   j2=1
 482   k1=1
 483   k2=1
 484   if(NDim == 0) return  ! NDim=0 for scalars.  TBH:  20060502
 485   i1 = Start(1)
 486   i2 = End  (1)
 487   if(NDim == 1) return
 488   j1 = Start(2)
 489   j2 = End  (2)
 490   if(NDim == 2) return
 491   k1 = Start(3)
 492   k2 = End  (3)
 493   return
 494 end subroutine GetIndices
 495
 496 logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status)
 497   use wrf_data
 498   include 'wrf_status_codes.h'
 499   character*(*)              ,intent(in)    :: MemoryOrder
 500   integer,dimension(*)       ,intent(in)    :: Vector
 501   integer                    ,intent(out)   :: Status
 502   integer                                   :: NDim
 503   integer,dimension(NVarDims)               :: temp
 504   character*3                               :: MemOrd
 505   logical zero_length
 506
 507   call GetDim(MemoryOrder,NDim,Status)
 508   temp(1:NDim) = Vector(1:NDim)
 509   call LowerCase(MemoryOrder,MemOrd)
 510   zero_length = .false.
 511   select case (MemOrd)
 512     case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c')
 513       continue
 514     case ('0')
 515       continue  ! NDim=0 for scalars.  TBH:  20060502
 516     case ('xzy','yzx')
 517       zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1
 518     case ('xy','yx','xyz','yxz')
 519       zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1
 520     case ('zxy','zyx')
 521       zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1
 522     case default
 523       Status = WRF_WARN_BAD_MEMORYORDER
 524       ZeroLengthHorzDim = .true.
 525       return
 526   end select
 527   Status = WRF_NO_ERR
 528   ZeroLengthHorzDim = zero_length
 529   return
 530 end function ZeroLengthHorzDim
 531
 532 subroutine ExtOrder(MemoryOrder,Vector,Status)
 533   use wrf_data
 534   include 'wrf_status_codes.h'
 535   character*(*)              ,intent(in)    :: MemoryOrder
 536   integer,dimension(*)       ,intent(inout) :: Vector
 537   integer                    ,intent(out)   :: Status
 538   integer                                   :: NDim
 539   integer,dimension(NVarDims)               :: temp
 540   character*3                               :: MemOrd
 541
 542   call GetDim(MemoryOrder,NDim,Status)
 543   temp(1:NDim) = Vector(1:NDim)
 544   call LowerCase(MemoryOrder,MemOrd)
 545   select case (MemOrd)
 546
 547     case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
 548       continue
 549     case ('0')
 550       continue  ! NDim=0 for scalars.  TBH:  20060502
 551     case ('xzy')
 552       Vector(2) = temp(3)
 553       Vector(3) = temp(2)
 554     case ('yxz')
 555       Vector(1) = temp(2)
 556       Vector(2) = temp(1)
 557     case ('yzx')
 558       Vector(1) = temp(3)
 559       Vector(2) = temp(1)
 560       Vector(3) = temp(2)
 561     case ('zxy')
 562       Vector(1) = temp(2)
 563       Vector(2) = temp(3)
 564       Vector(3) = temp(1)
 565     case ('zyx')
 566       Vector(1) = temp(3)
 567       Vector(3) = temp(1)
 568     case ('yx')
 569       Vector(1) = temp(2)
 570       Vector(2) = temp(1)
 571     case default
 572       Status = WRF_WARN_BAD_MEMORYORDER
 573       return
 574   end select
 575   Status = WRF_NO_ERR
 576   return
 577 end subroutine ExtOrder
 578
 579 subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status)
 580   use wrf_data
 581   include 'wrf_status_codes.h'
 582   character*(*)                    ,intent(in)    :: MemoryOrder
 583   character*(*),dimension(*)       ,intent(in)    :: Vector
 584   character(80),dimension(NVarDims),intent(out)   :: ROVector
 585   integer                          ,intent(out)   :: Status
 586   integer                                         :: NDim
 587   character*3                                     :: MemOrd
 588
 589   call GetDim(MemoryOrder,NDim,Status)
 590   ROVector(1:NDim) = Vector(1:NDim)
 591   call LowerCase(MemoryOrder,MemOrd)
 592   select case (MemOrd)
 593
 594     case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
 595       continue
 596     case ('0')
 597       continue  ! NDim=0 for scalars.  TBH:  20060502
 598     case ('xzy')
 599       ROVector(2) = Vector(3)
 600       ROVector(3) = Vector(2)
 601     case ('yxz')
 602       ROVector(1) = Vector(2)
 603       ROVector(2) = Vector(1)
 604     case ('yzx')
 605       ROVector(1) = Vector(3)
 606       ROVector(2) = Vector(1)
 607       ROVector(3) = Vector(2)
 608     case ('zxy')
 609       ROVector(1) = Vector(2)
 610       ROVector(2) = Vector(3)
 611       ROVector(3) = Vector(1)
 612     case ('zyx')
 613       ROVector(1) = Vector(3)
 614       ROVector(3) = Vector(1)
 615     case ('yx')
 616       ROVector(1) = Vector(2)
 617       ROVector(2) = Vector(1)
 618     case default
 619       Status = WRF_WARN_BAD_MEMORYORDER
 620       return
 621   end select
 622   Status = WRF_NO_ERR
 623   return
 624 end subroutine ExtOrderStr
 625
 626
 627 subroutine LowerCase(MemoryOrder,MemOrd)
 628   character*(*) ,intent(in)  :: MemoryOrder
 629   character*(*) ,intent(out) :: MemOrd
 630   character*1                :: c
 631   integer       ,parameter   :: upper_to_lower =IACHAR('a')-IACHAR('A')
 632   integer                    :: i,N
 633
 634   MemOrd = ' '
 635   N = len(MemoryOrder)
 636   MemOrd(1:N) = MemoryOrder(1:N)
 637   do i=1,N
 638     c = MemoryOrder(i:i)
 639     if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
 640   enddo
 641   return
 642 end subroutine LowerCase
 643
 644 subroutine UpperCase(MemoryOrder,MemOrd)
 645   character*(*) ,intent(in)  :: MemoryOrder
 646   character*(*) ,intent(out) :: MemOrd
 647   character*1                :: c
 648   integer     ,parameter     :: lower_to_upper =IACHAR('A')-IACHAR('a')
 649   integer                    :: i,N
 650
 651   MemOrd = ' '
 652   N = len(MemoryOrder)
 653   MemOrd(1:N) = MemoryOrder(1:N)
 654   do i=1,N
 655     c = MemoryOrder(i:i)
 656     if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper)
 657   enddo
 658   return
 659 end subroutine UpperCase
 660
 661 subroutine netcdf_err(err,Status)
 662   use wrf_data
 663   include 'wrf_status_codes.h'
 664   include 'netcdf.inc'
 665   integer  ,intent(in)  :: err
 666   integer  ,intent(out) :: Status
 667   character(len=80)     :: errmsg
 668   integer               :: stat
 669
 670   if( err==NF_NOERR )then
 671     Status = WRF_NO_ERR
 672   else
 673     errmsg = NF_STRERROR(err)
 674     write(msg,*) 'NetCDF error: ',errmsg
 675     call wrf_debug ( WARN , TRIM(msg))
 676     Status = WRF_WARN_NETCDF
 677   endif
 678   return
 679 end subroutine netcdf_err
 680
 681 subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder &
 682                      ,FieldType,NCID,VarID,XField,Status)
 683   use wrf_data
 684   include 'wrf_status_codes.h'
 685   include 'netcdf.inc'
 686   character (*)              ,intent(in)    :: IO
 687   integer                    ,intent(in)    :: DataHandle
 688   character*(*)              ,intent(in)    :: DateStr
 689   integer,dimension(NVarDims),intent(in)    :: Length
 690   character*(*)              ,intent(in)    :: MemoryOrder
 691   integer                    ,intent(in)    :: FieldType
 692   integer                    ,intent(in)    :: NCID
 693   integer                    ,intent(in)    :: VarID
 694   integer,dimension(*)       ,intent(inout) :: XField
 695   integer                    ,intent(out)   :: Status
 696   integer                                   :: TimeIndex
 697   integer                                   :: NDim
 698   integer,dimension(NVarDims)               :: VStart
 699   integer,dimension(NVarDims)               :: VCount
 700
 701   call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
 702   if(Status /= WRF_NO_ERR) then
 703     write(msg,*) 'Warning in ',__FILE__,', line', __LINE__
 704     call wrf_debug ( WARN , TRIM(msg))
 705     write(msg,*) '  Bad time index for DateStr = ',DateStr
 706     call wrf_debug ( WARN , TRIM(msg))
 707     return
 708   endif
 709   call GetDim(MemoryOrder,NDim,Status)
 710   VStart(:) = 1
 711   VCount(:) = 1
 712   VStart(1:NDim) = 1
 713   VCount(1:NDim) = Length(1:NDim)
 714   VStart(NDim+1) = TimeIndex
 715   VCount(NDim+1) = 1
 716
 717   ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
 718   IF (FieldType == WRF_REAL) THEN
 719     call ext_ncd_RealFieldIO    (IO,NCID,VarID,VStart,VCount,XField,Status)
 720   ELSE IF (FieldType == WRF_DOUBLE) THEN
 721     call ext_ncd_DoubleFieldIO  (IO,NCID,VarID,VStart,VCount,XField,Status)
 722   ELSE IF (FieldType == WRF_INTEGER) THEN
 723     call ext_ncd_IntFieldIO     (IO,NCID,VarID,VStart,VCount,XField,Status)
 724   ELSE IF (FieldType == WRF_LOGICAL) THEN
 725     call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status)
 726     if(Status /= WRF_NO_ERR) return
 727   ELSE
 728 !for wrf_complex, double_complex
 729       Status = WRF_WARN_DATA_TYPE_NOT_FOUND
 730       write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
 731       call wrf_debug ( WARN , TRIM(msg))
 732       return
 733   END IF
 734
 735   return
 736 end subroutine FieldIO
 737
 738 subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
 739                                       ,XField,x1,x2,y1,y2,z1,z2 &
 740                                              ,i1,i2,j1,j2,k1,k2 )
 741   character*(*)     ,intent(in)    :: IO
 742   character*(*)     ,intent(in)    :: MemoryOrder
 743   integer           ,intent(in)    :: l1,l2,m1,m2,n1,n2
 744   integer           ,intent(in)    :: di
 745   integer           ,intent(in)    :: x1,x2,y1,y2,z1,z2
 746   integer           ,intent(in)    :: i1,i2,j1,j2,k1,k2
 747   integer           ,intent(inout) ::  Field(di,l1:l2,m1:m2,n1:n2)
 748 !jm 010827  integer           ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2)
 749   integer           ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1))
 750   character*3                      :: MemOrd
 751   character*3                      :: MemO
 752   integer           ,parameter     :: MaxUpperCase=IACHAR('Z')
 753   integer                          :: i,j,k,ix,jx,kx
 754
 755   call LowerCase(MemoryOrder,MemOrd)
 756   select case (MemOrd)
 757
 758 !#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))
 759 ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1))))
 760
 761     case ('xzy')
 762 #undef  DFIELD
 763 #define DFIELD XField(1:di,XDEX(i,k,j))
 764 #include "transpose.code"
 765     case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
 766 #undef  DFIELD
 767 #define DFIELD XField(1:di,XDEX(i,j,k))
 768 #include "transpose.code"
 769     case ('yxz')
 770 #undef  DFIELD
 771 #define DFIELD XField(1:di,XDEX(j,i,k))
 772 #include "transpose.code"
 773     case ('zxy')
 774 #undef  DFIELD
 775 #define DFIELD XField(1:di,XDEX(k,i,j))
 776 #include "transpose.code"
 777     case ('yzx')
 778 #undef  DFIELD
 779 #define DFIELD XField(1:di,XDEX(j,k,i))
 780 #include "transpose.code"
 781     case ('zyx')
 782 #undef  DFIELD
 783 #define DFIELD XField(1:di,XDEX(k,j,i))
 784 #include "transpose.code"
 785     case ('yx')
 786 #undef  DFIELD
 787 #define DFIELD XField(1:di,XDEX(j,i,k))
 788 #include "transpose.code"
 789   end select
 790   return
 791 end subroutine Transpose
 792
 793 subroutine reorder (MemoryOrder,MemO)
 794   character*(*)     ,intent(in)    :: MemoryOrder
 795   character*3       ,intent(out)   :: MemO
 796   character*3                      :: MemOrd
 797   integer                          :: N,i,i1,i2,i3
 798
 799   MemO = MemoryOrder
 800   N = len_trim(MemoryOrder)
 801   if(N == 1) return
 802   call lowercase(MemoryOrder,MemOrd)
 803 ! never invert the boundary codes
 804   select case ( MemOrd )
 805      case ( 'xsz','xez','ysz','yez' )
 806        return
 807      case default
 808        continue
 809   end select
 810   i1 = 1
 811   i3 = 1
 812   do i=2,N
 813     if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i
 814     if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i
 815   enddo
 816   if(N == 2) then
 817     i2=i3
 818   else
 819     i2 = 6-i1-i3
 820   endif
 821   MemO(1:1) = MemoryOrder(i1:i1)
 822   MemO(2:2) = MemoryOrder(i2:i2)
 823   if(N == 3) MemO(3:3) = MemoryOrder(i3:i3)
 824   if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then
 825     MemO(1:N-1) = MemO(2:N)
 826     MemO(N:N  ) = MemoryOrder(i1:i1)
 827   endif
 828   return
 829 end subroutine reorder
 830
 831 ! Returns .TRUE. iff it is OK to write time-independent domain metadata to the
 832 ! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
 833 ! returned.
 834 LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle )
 835     USE wrf_data
 836     include 'wrf_status_codes.h'
 837     INTEGER, INTENT(IN) :: DataHandle
 838     CHARACTER*80 :: fname
 839     INTEGER :: filestate
 840     INTEGER :: Status
 841     LOGICAL :: dryrun, first_output, retval
 842     call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status )
 843     IF ( Status /= WRF_NO_ERR ) THEN
 844       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 845                    ', line', __LINE__
 846       call wrf_debug ( WARN , TRIM(msg) )
 847       retval = .FALSE.
 848     ELSE
 849       dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
 850       first_output = ncd_is_first_operation( DataHandle )
 851       retval = .NOT. dryrun .AND. first_output
 852     ENDIF
 853     ncd_ok_to_put_dom_ti = retval
 854     RETURN
 855 END FUNCTION ncd_ok_to_put_dom_ti
 856
 857 ! Returns .TRUE. iff it is OK to read time-independent domain metadata from the
 858 ! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
 859 ! returned.
 860 LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle )
 861     USE wrf_data
 862     include 'wrf_status_codes.h'
 863     INTEGER, INTENT(IN) :: DataHandle
 864     CHARACTER*80 :: fname
 865     INTEGER :: filestate
 866     INTEGER :: Status
 867     LOGICAL :: dryrun, retval
 868     call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status )
 869     IF ( Status /= WRF_NO_ERR ) THEN
 870       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 871                    ', line', __LINE__
 872       call wrf_debug ( WARN , TRIM(msg) )
 873       retval = .FALSE.
 874     ELSE
 875       dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
 876       retval = .NOT. dryrun
 877     ENDIF
 878     ncd_ok_to_get_dom_ti = retval
 879     RETURN
 880 END FUNCTION ncd_ok_to_get_dom_ti
 881
 882 ! Returns .TRUE. iff nothing has been read from or written to the file
 883 ! referenced by DataHandle.  If DataHandle is invalid, .FALSE. is returned.
 884 LOGICAL FUNCTION ncd_is_first_operation( DataHandle )
 885     USE wrf_data
 886     INCLUDE 'wrf_status_codes.h'
 887     INTEGER, INTENT(IN) :: DataHandle
 888     TYPE(wrf_data_handle) ,POINTER :: DH
 889     INTEGER :: Status
 890     LOGICAL :: retval
 891     CALL GetDH( DataHandle, DH, Status )
 892     IF ( Status /= WRF_NO_ERR ) THEN
 893       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
 894                    ', line', __LINE__
 895       call wrf_debug ( WARN , TRIM(msg) )
 896       retval = .FALSE.
 897     ELSE
 898       retval = DH%first_operation
 899     ENDIF
 900     ncd_is_first_operation = retval
 901     RETURN
 902 END FUNCTION ncd_is_first_operation
 903
 904 subroutine upgrade_filename(FileName)
 905   implicit none
 906
 907   character*(*), intent(inout) :: FileName
 908   integer :: i
 909
 910   do i = 1, len(trim(FileName))
 911      if(FileName(i:i) == '-') then
 912         FileName(i:i) = '_'
 913      else if(FileName(i:i) == ':') then
 914          FileName(i:i) = '_'
 915      endif
 916   enddo
 917
 918 end subroutine upgrade_filename
 919
 920 end module ext_ncd_support_routines
 921
 922 subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
 923                                       ,XField,x1,x2,y1,y2,z1,z2 &
 924                                              ,i1,i2,j1,j2,k1,k2 )
 925
 926   use ext_ncd_support_routines
 927
 928   character*(*)     ,intent(in)    :: IO
 929   character*(*)     ,intent(in)    :: MemoryOrder
 930   integer           ,intent(in)    :: l1,l2,m1,m2,n1,n2
 931   integer           ,intent(in)    :: di
 932   integer           ,intent(in)    :: x1,x2,y1,y2,z1,z2
 933   integer           ,intent(in)    :: i1,i2,j1,j2,k1,k2
 934   real*8            ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2)
 935   real*4            ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1))
 936   character*3                      :: MemOrd
 937   character*3                      :: MemO
 938   integer           ,parameter     :: MaxUpperCase=IACHAR('Z')
 939   integer                          :: i,j,k,ix,jx,kx
 940
 941   call LowerCase(MemoryOrder,MemOrd)
 942   select case (MemOrd)
 943
 944 !#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))
 945 ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1))))
 946
 947     case ('xzy')
 948 #undef  DFIELD
 949 #define DFIELD XField(1:di,XDEX(i,k,j))
 950 #include "transpose.code"
 951     case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
 952 #undef  DFIELD
 953 #define DFIELD XField(1:di,XDEX(i,j,k))
 954 #include "transpose.code"
 955     case ('yxz')
 956 #undef  DFIELD
 957 #define DFIELD XField(1:di,XDEX(j,i,k))
 958 #include "transpose.code"
 959     case ('zxy')
 960 #undef  DFIELD
 961 #define DFIELD XField(1:di,XDEX(k,i,j))
 962 #include "transpose.code"
 963     case ('yzx')
 964 #undef  DFIELD
 965 #define DFIELD XField(1:di,XDEX(j,k,i))
 966 #include "transpose.code"
 967     case ('zyx')
 968 #undef  DFIELD
 969 #define DFIELD XField(1:di,XDEX(k,j,i))
 970 #include "transpose.code"
 971     case ('yx')
 972 #undef  DFIELD
 973 #define DFIELD XField(1:di,XDEX(j,i,k))
 974 #include "transpose.code"
 975   end select
 976   return
 977 end subroutine TransposeToR4
 978
 979 subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status)
 980   use wrf_data
 981   use ext_ncd_support_routines
 982   implicit none
 983   include 'wrf_status_codes.h'
 984   include 'netcdf.inc'
 985   character *(*), INTENT(IN)   :: DatasetName
 986   integer       , INTENT(IN)   :: Comm1, Comm2
 987   character *(*), INTENT(IN)   :: SysDepInfo
 988   integer       , INTENT(OUT)  :: DataHandle
 989   integer       , INTENT(OUT)  :: Status
 990   DataHandle = 0   ! dummy setting to quiet warning message
 991   CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status )
 992   IF ( Status .EQ. WRF_NO_ERR ) THEN
 993     CALL ext_ncd_open_for_read_commit( DataHandle, Status )
 994   ENDIF
 995   return
 996 end subroutine ext_ncd_open_for_read
 997
 998 !ends training phase; switches internal flag to enable input
 999 !must be paired with call to ext_ncd_open_for_read_begin
1000 subroutine ext_ncd_open_for_read_commit(DataHandle, Status)
1001   use wrf_data
1002   use ext_ncd_support_routines
1003   implicit none
1004   include 'wrf_status_codes.h'
1005   include 'netcdf.inc'
1006   integer, intent(in) :: DataHandle
1007   integer, intent(out) :: Status
1008   type(wrf_data_handle) ,pointer         :: DH
1009
1010   if(WrfIOnotInitialized) then
1011     Status = WRF_IO_NOT_INITIALIZED
1012     write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1013     call wrf_debug ( FATAL , msg)
1014     return
1015   endif
1016   call GetDH(DataHandle,DH,Status)
1017   if(Status /= WRF_NO_ERR) then
1018     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1019     call wrf_debug ( WARN , TRIM(msg))
1020     return
1021   endif
1022   DH%FileStatus      = WRF_FILE_OPENED_FOR_READ
1023   DH%first_operation  = .TRUE.
1024   Status = WRF_NO_ERR
1025   return
1026 end subroutine ext_ncd_open_for_read_commit
1027
1028 subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status)
1029   use wrf_data
1030   use ext_ncd_support_routines
1031   implicit none
1032   include 'wrf_status_codes.h'
1033   include 'netcdf.inc'
1034   character*(*)         ,intent(INOUT)   :: FileName
1035   integer               ,intent(IN)      :: Comm
1036   integer               ,intent(IN)      :: IOComm
1037   character*(*)         ,intent(in)      :: SysDepInfo
1038   integer               ,intent(out)     :: DataHandle
1039   integer               ,intent(out)     :: Status
1040   type(wrf_data_handle) ,pointer         :: DH
1041   integer                                :: XType
1042   integer                                :: stat
1043   integer               ,allocatable     :: Buffer(:)
1044   integer                                :: VarID
1045   integer                                :: StoredDim
1046   integer                                :: NAtts
1047   integer                                :: DimIDs(2)
1048   integer                                :: VStart(2)
1049   integer                                :: VLen(2)
1050   integer                                :: TotalNumVars
1051   integer                                :: NumVars
1052   integer                                :: i
1053   character (NF_MAX_NAME)                :: Name
1054
1055 #ifdef USE_NETCDF4_FEATURES
1056   integer                                :: open_mode
1057 #endif
1058
1059   !call upgrade_filename(FileName)
1060
1061   if(WrfIOnotInitialized) then
1062     Status = WRF_IO_NOT_INITIALIZED
1063     write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1064     call wrf_debug ( FATAL , msg)
1065     return
1066   endif
1067   call allocHandle(DataHandle,DH,Comm,Status)
1068   if(Status /= WRF_NO_ERR) then
1069     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
1070     call wrf_debug ( WARN , TRIM(msg))
1071     return
1072   endif
1073
1074   stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID)
1075   call netcdf_err(stat,Status)
1076   if(Status /= WRF_NO_ERR) then
1077     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1078     call wrf_debug ( WARN , TRIM(msg))
1079     return
1080   endif
1081   stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID)
1082   call netcdf_err(stat,Status)
1083   if(Status /= WRF_NO_ERR) then
1084     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1085     call wrf_debug ( WARN , TRIM(msg))
1086     return
1087   endif
1088   stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts)
1089   call netcdf_err(stat,Status)
1090   if(Status /= WRF_NO_ERR) then
1091     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1092     call wrf_debug ( WARN , TRIM(msg))
1093     return
1094   endif
1095   if(XType/=NF_CHAR) then
1096     Status = WRF_WARN_TYPE_MISMATCH
1097     write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1098     call wrf_debug ( WARN , TRIM(msg))
1099     return
1100   endif
1101   stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1))
1102   call netcdf_err(stat,Status)
1103   if(Status /= WRF_NO_ERR) then
1104     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1105     call wrf_debug ( WARN , TRIM(msg))
1106     return
1107   endif
1108   if(VLen(1) /= DateStrLen) then
1109     Status = WRF_WARN_DATESTR_BAD_LENGTH
1110     write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__
1111     call wrf_debug ( WARN , TRIM(msg))
1112     return
1113   endif
1114   stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2))
1115   call netcdf_err(stat,Status)
1116   if(Status /= WRF_NO_ERR) then
1117     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1118     call wrf_debug ( WARN , TRIM(msg))
1119     return
1120   endif
1121   if(VLen(2) > MaxTimes) then
1122     Status = WRF_ERR_FATAL_TOO_MANY_TIMES
1123     write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
1124     call wrf_debug ( FATAL , TRIM(msg))
1125     return
1126   endif
1127   VStart(1) = 1
1128   VStart(2) = 1
1129   stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times)
1130   call netcdf_err(stat,Status)
1131   if(Status /= WRF_NO_ERR) then
1132     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1133     call wrf_debug ( WARN , TRIM(msg))
1134     return
1135   endif
1136   stat = NF_INQ_NVARS(DH%NCID,TotalNumVars)
1137   call netcdf_err(stat,Status)
1138   if(Status /= WRF_NO_ERR) then
1139     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1140     call wrf_debug ( WARN , TRIM(msg))
1141     return
1142   endif
1143   NumVars = 0
1144   do i=1,TotalNumVars
1145     stat = NF_INQ_VARNAME(DH%NCID,i,Name)
1146     call netcdf_err(stat,Status)
1147     if(Status /= WRF_NO_ERR) then
1148       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1149       call wrf_debug ( WARN , TRIM(msg))
1150       return
1151     elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1152       NumVars              = NumVars+1
1153       DH%VarNames(NumVars) = Name
1154       DH%VarIDs(NumVars)   = i
1155     endif
1156   enddo
1157   DH%NumVars         = NumVars
1158   DH%NumberTimes     = VLen(2)
1159   DH%FileStatus      = WRF_FILE_OPENED_NOT_COMMITTED
1160   DH%FileName        = trim(FileName)
1161   DH%CurrentVariable = 0
1162   DH%CurrentTime     = 0
1163   DH%TimesVarID      = VarID
1164   DH%TimeIndex       = 0
1165   return
1166 end subroutine ext_ncd_open_for_read_begin
1167
1168 subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status)
1169   use wrf_data
1170   use ext_ncd_support_routines
1171   implicit none
1172   include 'wrf_status_codes.h'
1173   include 'netcdf.inc'
1174   character*(*)         ,intent(INOUT)   :: FileName
1175   integer               ,intent(IN)      :: Comm
1176   integer               ,intent(IN)      :: IOComm
1177   character*(*)         ,intent(in)      :: SysDepInfo
1178   integer               ,intent(out)     :: DataHandle
1179   integer               ,intent(out)     :: Status
1180   type(wrf_data_handle) ,pointer         :: DH
1181   integer                                :: XType
1182   integer                                :: stat
1183   integer               ,allocatable     :: Buffer(:)
1184   integer                                :: VarID
1185   integer                                :: StoredDim
1186   integer                                :: NAtts
1187   integer                                :: DimIDs(2)
1188   integer                                :: VStart(2)
1189   integer                                :: VLen(2)
1190   integer                                :: TotalNumVars
1191   integer                                :: NumVars
1192   integer                                :: i
1193   character (NF_MAX_NAME)                :: Name
1194
1195 #ifdef USE_NETCDF4_FEATURES
1196   integer                                :: open_mode
1197 #endif
1198
1199   !call upgrade_filename(FileName)
1200
1201   if(WrfIOnotInitialized) then
1202     Status = WRF_IO_NOT_INITIALIZED
1203     write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1204     call wrf_debug ( FATAL , msg)
1205     return
1206   endif
1207   call allocHandle(DataHandle,DH,Comm,Status)
1208   if(Status /= WRF_NO_ERR) then
1209     write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
1210     call wrf_debug ( WARN , TRIM(msg))
1211     return
1212   endif
1213   stat = NF_OPEN(FileName, NF_WRITE, DH%NCID)
1214   call netcdf_err(stat,Status)
1215   if(Status /= WRF_NO_ERR) then
1216     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1217     call wrf_debug ( WARN , TRIM(msg))
1218     return
1219   endif
1220   stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID)
1221   call netcdf_err(stat,Status)
1222   if(Status /= WRF_NO_ERR) then
1223     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1224     call wrf_debug ( WARN , TRIM(msg))
1225     return
1226   endif
1227   stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts)
1228   call netcdf_err(stat,Status)
1229   if(Status /= WRF_NO_ERR) then
1230     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1231     call wrf_debug ( WARN , TRIM(msg))
1232     return
1233   endif
1234   if(XType/=NF_CHAR) then
1235     Status = WRF_WARN_TYPE_MISMATCH
1236     write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1237     call wrf_debug ( WARN , TRIM(msg))
1238     return
1239   endif
1240   stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1))
1241   call netcdf_err(stat,Status)
1242   if(Status /= WRF_NO_ERR) then
1243     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1244     call wrf_debug ( WARN , TRIM(msg))
1245     return
1246   endif
1247   if(VLen(1) /= DateStrLen) then
1248     Status = WRF_WARN_DATESTR_BAD_LENGTH
1249     write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__
1250     call wrf_debug ( WARN , TRIM(msg))
1251     return
1252   endif
1253   stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2))
1254   call netcdf_err(stat,Status)
1255   if(Status /= WRF_NO_ERR) then
1256     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1257     call wrf_debug ( WARN , TRIM(msg))
1258     return
1259   endif
1260   if(VLen(2) > MaxTimes) then
1261     Status = WRF_ERR_FATAL_TOO_MANY_TIMES
1262     write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
1263     call wrf_debug ( FATAL , TRIM(msg))
1264     return
1265   endif
1266   VStart(1) = 1
1267   VStart(2) = 1
1268   stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times)
1269   call netcdf_err(stat,Status)
1270   if(Status /= WRF_NO_ERR) then
1271     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1272     call wrf_debug ( WARN , TRIM(msg))
1273     return
1274   endif
1275   stat = NF_INQ_NVARS(DH%NCID,TotalNumVars)
1276   call netcdf_err(stat,Status)
1277   if(Status /= WRF_NO_ERR) then
1278     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1279     call wrf_debug ( WARN , TRIM(msg))
1280     return
1281   endif
1282   NumVars = 0
1283   do i=1,TotalNumVars
1284     stat = NF_INQ_VARNAME(DH%NCID,i,Name)
1285     call netcdf_err(stat,Status)
1286     if(Status /= WRF_NO_ERR) then
1287       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1288       call wrf_debug ( WARN , TRIM(msg))
1289       return
1290     elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1291       NumVars              = NumVars+1
1292       DH%VarNames(NumVars) = Name
1293       DH%VarIDs(NumVars)   = i
1294     endif
1295   enddo
1296   DH%NumVars         = NumVars
1297   DH%NumberTimes     = VLen(2)
1298   DH%FileStatus      = WRF_FILE_OPENED_FOR_UPDATE
1299   DH%FileName        = trim(FileName)
1300   DH%CurrentVariable = 0
1301   DH%CurrentTime     = 0
1302   DH%TimesVarID      = VarID
1303   DH%TimeIndex       = 0
1304   return
1305 end subroutine ext_ncd_open_for_update
1306
1307
1308 SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status)
1309   use wrf_data
1310   use ext_ncd_support_routines
1311   implicit none
1312   include 'wrf_status_codes.h'
1313   include 'netcdf.inc'
1314   character*(*)        ,intent(inout) :: FileName
1315   integer              ,intent(in)  :: Comm
1316   integer              ,intent(in)  :: IOComm
1317   character*(*)        ,intent(in)  :: SysDepInfo
1318   integer              ,intent(out) :: DataHandle
1319   integer              ,intent(out) :: Status
1320   type(wrf_data_handle),pointer     :: DH
1321   integer                           :: i
1322   integer                           :: stat
1323   character (7)                     :: Buffer
1324   integer                           :: VDimIDs(2)
1325
1326 #ifdef USE_NETCDF4_FEATURES
1327   integer                           :: create_mode
1328   integer, parameter                :: cache_size = 32, &
1329                                        cache_nelem = 37, &
1330                                        cache_preemption = 100
1331 #endif
1332
1333   !call upgrade_filename(FileName)
1334
1335   if(WrfIOnotInitialized) then
1336     Status = WRF_IO_NOT_INITIALIZED
1337     write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1338     call wrf_debug ( FATAL , msg)
1339     return
1340   endif
1341   call allocHandle(DataHandle,DH,Comm,Status)
1342   if(Status /= WRF_NO_ERR) then
1343     write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1344     call wrf_debug ( FATAL , TRIM(msg))
1345     return
1346   endif
1347   DH%TimeIndex = 0
1348   DH%Times     = ZeroDate
1349 #ifdef USE_NETCDF4_FEATURES
1350 ! create_mode = IOR(nf_netcdf4, nf_classic_model)
1351   if ( DH%use_netcdf_classic ) then
1352   write(msg,*) 'output will be in classic NetCDF format'
1353   call wrf_debug ( WARN , TRIM(msg))
1354 #ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
1355   stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
1356 #else
1357   stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
1358 #endif
1359   else
1360   create_mode = nf_netcdf4
1361   stat = NF_CREATE(FileName, create_mode, DH%NCID)
1362   stat = NF_SET_CHUNK_CACHE(cache_size, cache_nelem, cache_preemption)
1363   endif
1364 #else
1365 #ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
1366   stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
1367 #else
1368   stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
1369 #endif
1370 #endif
1371   call netcdf_err(stat,Status)
1372   if(Status /= WRF_NO_ERR) then
1373     write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1374     call wrf_debug ( WARN , TRIM(msg))
1375     return
1376   endif
1377   DH%FileStatus  = WRF_FILE_OPENED_NOT_COMMITTED
1378   DH%FileName    = trim(FileName)
1379   stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID)
1380   call netcdf_err(stat,Status)
1381   if(Status /= WRF_NO_ERR) then
1382     write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1383     call wrf_debug ( WARN , TRIM(msg))
1384     return
1385   endif
1386   DH%VarNames  (1:MaxVars) = NO_NAME
1387   DH%MDVarNames(1:MaxVars) = NO_NAME
1388   do i=1,MaxDims
1389     write(Buffer,FMT="('DIM',i4.4)") i
1390     DH%DimNames  (i) = Buffer
1391     DH%DimLengths(i) = NO_DIM
1392   enddo
1393   DH%DimNames(1) = 'DateStrLen'
1394   stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1))
1395   call netcdf_err(stat,Status)
1396   if(Status /= WRF_NO_ERR) then
1397     write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1398     call wrf_debug ( WARN , TRIM(msg))
1399     return
1400   endif
1401   VDimIDs(1) = DH%DimIDs(1)
1402   VDimIDs(2) = DH%DimUnlimID
1403   stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID)
1404   call netcdf_err(stat,Status)
1405   if(Status /= WRF_NO_ERR) then
1406     write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1407     call wrf_debug ( WARN , TRIM(msg))
1408     return
1409   endif
1410   DH%DimLengths(1) = DateStrLen
1411
1412   if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then
1413      DH%R4OnOutput = .true.
1414   end if
1415 !toggle on nofill mode
1416   if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then
1417      DH%nofill = .true.
1418   end if
1419
1420   return
1421 end subroutine ext_ncd_open_for_write_begin
1422
1423 !stub
1424 !opens a file for writing or coupler datastream for sending messages.
1425 !no training phase for this version of the open stmt.
1426 subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, &
1427                                    SysDepInfo, DataHandle, Status)
1428   use wrf_data
1429   use ext_ncd_support_routines
1430   implicit none
1431   include 'wrf_status_codes.h'
1432   include 'netcdf.inc'
1433   character *(*), intent(in)  ::DatasetName
1434   integer       , intent(in)  ::Comm1, Comm2
1435   character *(*), intent(in)  ::SysDepInfo
1436   integer       , intent(out) :: DataHandle
1437   integer       , intent(out) :: Status
1438   Status=WRF_WARN_NOOP
1439   DataHandle = 0    ! dummy setting to quiet warning message
1440   return
1441 end subroutine ext_ncd_open_for_write
1442
1443 SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status)
1444   use wrf_data
1445   use ext_ncd_support_routines
1446   implicit none
1447   include 'wrf_status_codes.h'
1448   include 'netcdf.inc'
1449   integer              ,intent(in)  :: DataHandle
1450   integer              ,intent(out) :: Status
1451   type(wrf_data_handle),pointer     :: DH
1452   integer                           :: i
1453   integer                           :: stat
1454   integer                           :: oldmode  ! for nf_set_fill, not used
1455
1456   if(WrfIOnotInitialized) then
1457     Status = WRF_IO_NOT_INITIALIZED
1458     write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1459     call wrf_debug ( FATAL , msg)
1460     return
1461   endif
1462   call GetDH(DataHandle,DH,Status)
1463   if(Status /= WRF_NO_ERR) then
1464     write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__
1465     call wrf_debug ( WARN , TRIM(msg))
1466     return
1467   endif
1468   if ( DH%nofill ) then
1469     Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode )
1470     if(Status /= WRF_NO_ERR) then
1471       write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',__FILE__,', line', __LINE__
1472       call wrf_debug ( WARN , TRIM(msg))
1473       return
1474     endif
1475     write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName)
1476     call wrf_debug ( WARN , TRIM(msg))
1477   endif
1478   stat = NF_ENDDEF(DH%NCID)
1479   call netcdf_err(stat,Status)
1480   if(Status /= WRF_NO_ERR) then
1481     write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__
1482     call wrf_debug ( WARN , TRIM(msg))
1483     return
1484   endif
1485   DH%FileStatus  = WRF_FILE_OPENED_FOR_WRITE
1486   DH%first_operation  = .TRUE.
1487   return
1488 end subroutine ext_ncd_open_for_write_commit
1489
1490 subroutine ext_ncd_ioclose(DataHandle, Status)
1491   use wrf_data
1492   use ext_ncd_support_routines
1493   implicit none
1494   include 'wrf_status_codes.h'
1495   include 'netcdf.inc'
1496   integer              ,intent(in)  :: DataHandle
1497   integer              ,intent(out) :: Status
1498   type(wrf_data_handle),pointer     :: DH
1499   integer                           :: stat
1500
1501   call GetDH(DataHandle,DH,Status)
1502   if(Status /= WRF_NO_ERR) then
1503     write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1504     call wrf_debug ( WARN , TRIM(msg))
1505     return
1506   endif
1507   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1508     Status = WRF_WARN_FILE_NOT_OPENED
1509     write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1510     call wrf_debug ( WARN , TRIM(msg))
1511   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1512     Status = WRF_WARN_DRYRUN_CLOSE
1513     write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1514     call wrf_debug ( WARN , TRIM(msg))
1515   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1516     continue
1517   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1518     continue
1519   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
1520     continue
1521   else
1522     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1523     write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1524     call wrf_debug ( FATAL , TRIM(msg))
1525     return
1526   endif
1527
1528   stat = NF_CLOSE(DH%NCID)
1529   call netcdf_err(stat,Status)
1530   if(Status /= WRF_NO_ERR) then
1531     write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1532     call wrf_debug ( WARN , TRIM(msg))
1533     return
1534   endif
1535   CALL deallocHandle( DataHandle, Status )
1536   DH%Free=.true.
1537   return
1538 end subroutine ext_ncd_ioclose
1539
1540 subroutine ext_ncd_iosync( DataHandle, Status)
1541   use wrf_data
1542   use ext_ncd_support_routines
1543   implicit none
1544   include 'wrf_status_codes.h'
1545   include 'netcdf.inc'
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 ext_ncd_iosync ',__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 ext_ncd_iosync ',__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 ext_ncd_iosync ',__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     continue
1569   else
1570     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1571     write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__
1572     call wrf_debug ( FATAL , TRIM(msg))
1573     return
1574   endif
1575   stat = NF_SYNC(DH%NCID)
1576   call netcdf_err(stat,Status)
1577   if(Status /= WRF_NO_ERR) then
1578     write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__
1579     call wrf_debug ( WARN , TRIM(msg))
1580     return
1581   endif
1582   return
1583 end subroutine ext_ncd_iosync
1584
1585
1586
1587 subroutine ext_ncd_redef( DataHandle, Status)
1588   use wrf_data
1589   use ext_ncd_support_routines
1590   implicit none
1591   include 'wrf_status_codes.h'
1592   include 'netcdf.inc'
1593   integer              ,intent(in)  :: DataHandle
1594   integer              ,intent(out) :: Status
1595   type(wrf_data_handle),pointer     :: DH
1596   integer                           :: stat
1597
1598   call GetDH(DataHandle,DH,Status)
1599   if(Status /= WRF_NO_ERR) then
1600     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1601     call wrf_debug ( WARN , TRIM(msg))
1602     return
1603   endif
1604   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1605     Status = WRF_WARN_FILE_NOT_OPENED
1606     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1607     call wrf_debug ( WARN , TRIM(msg))
1608   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1609     Status = WRF_WARN_FILE_NOT_COMMITTED
1610     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1611     call wrf_debug ( WARN , TRIM(msg))
1612   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1613     continue
1614   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
1615     continue
1616   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1617     Status = WRF_WARN_FILE_OPEN_FOR_READ
1618     write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1619     call wrf_debug ( WARN , TRIM(msg))
1620   else
1621     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1622     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1623     call wrf_debug ( FATAL , TRIM(msg))
1624     return
1625   endif
1626   stat = NF_REDEF(DH%NCID)
1627   call netcdf_err(stat,Status)
1628   if(Status /= WRF_NO_ERR) then
1629     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1630     call wrf_debug ( WARN , TRIM(msg))
1631     return
1632   endif
1633   DH%FileStatus  = WRF_FILE_OPENED_NOT_COMMITTED
1634   return
1635 end subroutine ext_ncd_redef
1636
1637 subroutine ext_ncd_enddef( DataHandle, Status)
1638   use wrf_data
1639   use ext_ncd_support_routines
1640   implicit none
1641   include 'wrf_status_codes.h'
1642   include 'netcdf.inc'
1643   integer              ,intent(in)  :: DataHandle
1644   integer              ,intent(out) :: Status
1645   type(wrf_data_handle),pointer     :: DH
1646   integer                           :: stat
1647
1648   call GetDH(DataHandle,DH,Status)
1649   if(Status /= WRF_NO_ERR) then
1650     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1651     call wrf_debug ( WARN , TRIM(msg))
1652     return
1653   endif
1654   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1655     Status = WRF_WARN_FILE_NOT_OPENED
1656     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1657     call wrf_debug ( WARN , TRIM(msg))
1658   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1659     Status = WRF_WARN_FILE_NOT_COMMITTED
1660     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1661     call wrf_debug ( WARN , TRIM(msg))
1662   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1663     continue
1664   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1665     Status = WRF_WARN_FILE_OPEN_FOR_READ
1666     write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1667     call wrf_debug ( WARN , TRIM(msg))
1668   else
1669     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1670     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1671     call wrf_debug ( FATAL , TRIM(msg))
1672     return
1673   endif
1674   stat = NF_ENDDEF(DH%NCID)
1675   call netcdf_err(stat,Status)
1676   if(Status /= WRF_NO_ERR) then
1677     write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1678     call wrf_debug ( WARN , TRIM(msg))
1679     return
1680   endif
1681   DH%FileStatus  = WRF_FILE_OPENED_FOR_WRITE
1682   return
1683 end subroutine ext_ncd_enddef
1684
1685 subroutine ext_ncd_ioinit(SysDepInfo, Status)
1686   use wrf_data
1687   implicit none
1688   include 'wrf_status_codes.h'
1689   CHARACTER*(*), INTENT(IN) :: SysDepInfo
1690   INTEGER ,INTENT(INOUT)    :: Status
1691
1692   WrfIOnotInitialized                             = .false.
1693   WrfDataHandles(1:WrfDataHandleMax)%Free         = .true.
1694   WrfDataHandles(1:WrfDataHandleMax)%TimesName    = 'Times'
1695   WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time'
1696   WrfDataHandles(1:WrfDataHandleMax)%FileStatus   = WRF_FILE_NOT_OPENED
1697   if(trim(SysDepInfo) == "use_netcdf_classic" ) then
1698      WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true.
1699   else
1700      WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false.
1701   endif
1702   Status = WRF_NO_ERR
1703   return
1704 end subroutine ext_ncd_ioinit
1705
1706
1707 subroutine ext_ncd_inquiry (Inquiry, Result, Status)
1708   use wrf_data
1709   implicit none
1710   include 'wrf_status_codes.h'
1711   character *(*), INTENT(IN)    :: Inquiry
1712   character *(*), INTENT(OUT)   :: Result
1713   integer        ,INTENT(INOUT) :: Status
1714   SELECT CASE (Inquiry)
1715   CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ")
1716         Result='ALLOW'
1717   CASE ("OPEN_READ","OPEN_COMMIT_WRITE")
1718         Result='REQUIRE'
1719   CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO")
1720         Result='NO'
1721   CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
1722         Result='YES'
1723   CASE ("MEDIUM")
1724         Result ='FILE'
1725   CASE DEFAULT
1726       Result = 'No Result for that inquiry!'
1727   END SELECT
1728   Status=WRF_NO_ERR
1729   return
1730 end subroutine ext_ncd_inquiry
1731
1732
1733
1734
1735 subroutine ext_ncd_ioexit(Status)
1736   use wrf_data
1737   use ext_ncd_support_routines
1738   implicit none
1739   include 'wrf_status_codes.h'
1740   include 'netcdf.inc'
1741   integer       , INTENT(INOUT)     ::Status
1742   integer                           :: error
1743   type(wrf_data_handle),pointer     :: DH
1744   integer                           :: i
1745   integer                           :: stat
1746   if(WrfIOnotInitialized) then
1747     Status = WRF_IO_NOT_INITIALIZED
1748     write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1749     call wrf_debug ( FATAL , msg)
1750     return
1751   endif
1752   do i=1,WrfDataHandleMax
1753     CALL deallocHandle( i , stat )
1754   enddo
1755   return
1756 end subroutine ext_ncd_ioexit
1757
1758 subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status)
1759 #define ROUTINE_TYPE 'REAL'
1760 #define TYPE_DATA real,intent(out) :: Data(*)
1761 #define TYPE_COUNT integer,intent(in) :: Count
1762 #define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt
1763 #define TYPE_BUFFER  real,allocatable :: Buffer(:)
1764 #define NF_TYPE NF_FLOAT
1765 #define NF_ROUTINE NF_GET_ATT_REAL
1766 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1767 #include "ext_ncd_get_dom_ti.code"
1768 end subroutine ext_ncd_get_dom_ti_real
1769
1770 subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status)
1771 #undef ROUTINE_TYPE
1772 #undef TYPE_DATA
1773 #undef TYPE_BUFFER
1774 #undef NF_TYPE
1775 #undef NF_ROUTINE
1776 #undef COPY
1777 #define ROUTINE_TYPE 'INTEGER'
1778 #define TYPE_DATA integer,intent(out) :: Data(*)
1779 #define TYPE_BUFFER  integer,allocatable :: Buffer(:)
1780 #define NF_TYPE NF_INT
1781 #define NF_ROUTINE NF_GET_ATT_INT
1782 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1783 #include "ext_ncd_get_dom_ti.code"
1784 end subroutine ext_ncd_get_dom_ti_integer
1785
1786 subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status)
1787 #undef ROUTINE_TYPE
1788 #undef TYPE_DATA
1789 #undef TYPE_BUFFER
1790 #undef NF_TYPE
1791 #undef NF_ROUTINE
1792 #undef COPY
1793 #define ROUTINE_TYPE 'DOUBLE'
1794 #define TYPE_DATA real*8,intent(out) :: Data(*)
1795 #define TYPE_BUFFER  real*8,allocatable :: Buffer(:)
1796 #define NF_TYPE NF_DOUBLE
1797 #define NF_ROUTINE NF_GET_ATT_DOUBLE
1798 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1799 #include "ext_ncd_get_dom_ti.code"
1800 end subroutine ext_ncd_get_dom_ti_double
1801
1802 subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status)
1803 #undef ROUTINE_TYPE
1804 #undef TYPE_DATA
1805 #undef TYPE_BUFFER
1806 #undef NF_TYPE
1807 #undef NF_ROUTINE
1808 #undef COPY
1809 #define ROUTINE_TYPE 'LOGICAL'
1810 #define TYPE_DATA logical,intent(out) :: Data(*)
1811 #define TYPE_BUFFER  integer,allocatable :: Buffer(:)
1812 #define NF_TYPE NF_INT
1813 #define NF_ROUTINE NF_GET_ATT_INT
1814 #define COPY   Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1
1815 #include "ext_ncd_get_dom_ti.code"
1816 end subroutine ext_ncd_get_dom_ti_logical
1817
1818 subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status)
1819 #undef ROUTINE_TYPE
1820 #undef TYPE_DATA
1821 #undef TYPE_COUNT
1822 #undef TYPE_OUTCOUNT
1823 #undef TYPE_BUFFER
1824 #undef NF_TYPE
1825 #define ROUTINE_TYPE 'CHAR'
1826 #define TYPE_DATA character*(*),intent(out) :: Data
1827 #define TYPE_COUNT
1828 #define TYPE_OUTCOUNT
1829 #define TYPE_BUFFER
1830 #define NF_TYPE NF_CHAR
1831 #define CHAR_TYPE
1832 #include "ext_ncd_get_dom_ti.code"
1833 #undef CHAR_TYPE
1834 end subroutine ext_ncd_get_dom_ti_char
1835
1836 subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status)
1837 #undef ROUTINE_TYPE
1838 #undef TYPE_DATA
1839 #undef TYPE_COUNT
1840 #undef NF_ROUTINE
1841 #undef ARGS
1842 #undef LOG
1843 #define ROUTINE_TYPE 'REAL'
1844 #define TYPE_DATA  real   ,intent(in) :: Data(*)
1845 #define TYPE_COUNT integer,intent(in) :: Count
1846 #define NF_ROUTINE NF_PUT_ATT_REAL
1847 #define ARGS NF_FLOAT,Count,Data
1848 #include "ext_ncd_put_dom_ti.code"
1849 end subroutine ext_ncd_put_dom_ti_real
1850
1851 subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status)
1852 #undef ROUTINE_TYPE
1853 #undef TYPE_DATA
1854 #undef TYPE_COUNT
1855 #undef NF_ROUTINE
1856 #undef ARGS
1857 #undef LOG
1858 #define ROUTINE_TYPE 'INTEGER'
1859 #define TYPE_DATA  integer,intent(in) :: Data(*)
1860 #define TYPE_COUNT integer,intent(in) :: Count
1861 #define NF_ROUTINE NF_PUT_ATT_INT
1862 #define ARGS NF_INT,Count,Data
1863 #include "ext_ncd_put_dom_ti.code"
1864 end subroutine ext_ncd_put_dom_ti_integer
1865
1866 subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status)
1867 #undef ROUTINE_TYPE
1868 #undef TYPE_DATA
1869 #undef TYPE_COUNT
1870 #undef NF_ROUTINE
1871 #undef ARGS
1872 #undef LOG
1873 #define ROUTINE_TYPE 'DOUBLE'
1874 #define TYPE_DATA  real*8 ,intent(in) :: Data(*)
1875 #define TYPE_COUNT integer,intent(in) :: Count
1876 #define NF_ROUTINE NF_PUT_ATT_DOUBLE
1877 #define ARGS NF_DOUBLE,Count,Data
1878 #include "ext_ncd_put_dom_ti.code"
1879 end subroutine ext_ncd_put_dom_ti_double
1880
1881 subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status)
1882 #undef ROUTINE_TYPE
1883 #undef TYPE_DATA
1884 #undef TYPE_COUNT
1885 #undef NF_ROUTINE
1886 #undef ARGS
1887 #define ROUTINE_TYPE 'LOGICAL'
1888 #define TYPE_DATA  logical,intent(in) :: Data(*)
1889 #define TYPE_COUNT integer,intent(in) :: Count
1890 #define NF_ROUTINE NF_PUT_ATT_INT
1891 #define ARGS NF_INT,Count,Buffer
1892 #define LOG
1893 #include "ext_ncd_put_dom_ti.code"
1894 end subroutine ext_ncd_put_dom_ti_logical
1895
1896 subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status)
1897 #undef ROUTINE_TYPE
1898 #undef TYPE_DATA
1899 #undef TYPE_COUNT
1900 #undef NF_ROUTINE
1901 #undef ARGS
1902 #undef LOG
1903 #define ROUTINE_TYPE 'CHAR'
1904 #define TYPE_DATA  character*(*),intent(in) :: Data
1905 #define TYPE_COUNT integer,parameter :: Count=1
1906 #define NF_ROUTINE NF_PUT_ATT_TEXT
1907 #define ARGS len_trim(Data),Data
1908 #include "ext_ncd_put_dom_ti.code"
1909 end subroutine ext_ncd_put_dom_ti_char
1910
1911 subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status)
1912 #undef ROUTINE_TYPE
1913 #undef TYPE_DATA
1914 #undef TYPE_COUNT
1915 #undef NF_ROUTINE
1916 #undef ARGS
1917 #undef LOG
1918 #define ROUTINE_TYPE 'REAL'
1919 #define TYPE_DATA  real    ,intent(in) :: Data(*)
1920 #define TYPE_COUNT integer ,intent(in) :: Count
1921 #define NF_ROUTINE NF_PUT_ATT_REAL
1922 #define ARGS NF_FLOAT,Count,Data
1923 #include "ext_ncd_put_var_ti.code"
1924 end subroutine ext_ncd_put_var_ti_real
1925
1926 subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status)
1927 #undef ROUTINE_TYPE
1928 #undef TYPE_DATA
1929 #undef TYPE_COUNT
1930 #undef NF_ROUTINE
1931 #undef NF_TYPE
1932 #undef LENGTH
1933 #undef ARG
1934 #undef LOG
1935 #define ROUTINE_TYPE 'REAL'
1936 #define TYPE_DATA  real    ,intent(in) :: Data(*)
1937 #define TYPE_COUNT integer ,intent(in) :: Count
1938 #define NF_ROUTINE NF_PUT_VARA_REAL
1939 #define NF_TYPE NF_FLOAT
1940 #define LENGTH Count
1941 #define ARG
1942 #include "ext_ncd_put_var_td.code"
1943 end subroutine ext_ncd_put_var_td_real
1944
1945 subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status)
1946 #undef ROUTINE_TYPE
1947 #undef TYPE_DATA
1948 #undef TYPE_COUNT
1949 #undef NF_ROUTINE
1950 #undef ARGS
1951 #undef LOG
1952 #define ROUTINE_TYPE 'DOUBLE'
1953 #define TYPE_DATA  real*8 ,intent(in) :: Data(*)
1954 #define TYPE_COUNT integer ,intent(in) :: Count
1955 #define NF_ROUTINE NF_PUT_ATT_DOUBLE
1956 #define ARGS NF_DOUBLE,Count,Data
1957 #include "ext_ncd_put_var_ti.code"
1958 end subroutine ext_ncd_put_var_ti_double
1959
1960 subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status)
1961 #undef ROUTINE_TYPE
1962 #undef TYPE_DATA
1963 #undef TYPE_COUNT
1964 #undef NF_ROUTINE
1965 #undef NF_TYPE
1966 #undef LENGTH
1967 #undef ARG
1968 #undef LOG
1969 #define ROUTINE_TYPE 'DOUBLE'
1970 #define TYPE_DATA  real*8,intent(in) :: Data(*)
1971 #define TYPE_COUNT integer ,intent(in) :: Count
1972 #define NF_ROUTINE NF_PUT_VARA_DOUBLE
1973 #define NF_TYPE NF_DOUBLE
1974 #define LENGTH Count
1975 #define ARG
1976 #include "ext_ncd_put_var_td.code"
1977 end subroutine ext_ncd_put_var_td_double
1978
1979 subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status)
1980 #undef ROUTINE_TYPE
1981 #undef TYPE_DATA
1982 #undef TYPE_COUNT
1983 #undef NF_ROUTINE
1984 #undef ARGS
1985 #undef LOG
1986 #define ROUTINE_TYPE 'INTEGER'
1987 #define TYPE_DATA  integer ,intent(in) :: Data(*)
1988 #define TYPE_COUNT integer ,intent(in) :: Count
1989 #define NF_ROUTINE NF_PUT_ATT_INT
1990 #define ARGS NF_INT,Count,Data
1991 #include "ext_ncd_put_var_ti.code"
1992 end subroutine ext_ncd_put_var_ti_integer
1993
1994 subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status)
1995 #undef ROUTINE_TYPE
1996 #undef TYPE_DATA
1997 #undef TYPE_COUNT
1998 #undef NF_ROUTINE
1999 #undef NF_TYPE
2000 #undef LENGTH
2001 #undef ARG
2002 #undef LOG
2003 #define ROUTINE_TYPE 'INTEGER'
2004 #define TYPE_DATA  integer ,intent(in) :: Data(*)
2005 #define TYPE_COUNT integer ,intent(in) :: Count
2006 #define NF_ROUTINE NF_PUT_VARA_INT
2007 #define NF_TYPE NF_INT
2008 #define LENGTH Count
2009 #define ARG
2010 #include "ext_ncd_put_var_td.code"
2011 end subroutine ext_ncd_put_var_td_integer
2012
2013 subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status)
2014 #undef ROUTINE_TYPE
2015 #undef TYPE_DATA
2016 #undef TYPE_COUNT
2017 #undef NF_ROUTINE
2018 #undef ARGS
2019 #define ROUTINE_TYPE 'LOGICAL'
2020 #define TYPE_DATA  logical ,intent(in) :: Data(*)
2021 #define TYPE_COUNT integer ,intent(in) :: Count
2022 #define NF_ROUTINE NF_PUT_ATT_INT
2023 #define LOG
2024 #define ARGS NF_INT,Count,Buffer
2025 #include "ext_ncd_put_var_ti.code"
2026 end subroutine ext_ncd_put_var_ti_logical
2027
2028 subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status)
2029 #undef ROUTINE_TYPE
2030 #undef TYPE_DATA
2031 #undef TYPE_COUNT
2032 #undef NF_ROUTINE
2033 #undef NF_TYPE
2034 #undef LENGTH
2035 #undef ARG
2036 #define ROUTINE_TYPE 'LOGICAL'
2037 #define TYPE_DATA  logical ,intent(in) :: Data(*)
2038 #define TYPE_COUNT integer ,intent(in) :: Count
2039 #define NF_ROUTINE NF_PUT_VARA_INT
2040 #define NF_TYPE NF_INT
2041 #define LOG
2042 #define LENGTH Count
2043 #define ARG
2044 #include "ext_ncd_put_var_td.code"
2045 end subroutine ext_ncd_put_var_td_logical
2046
2047 subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status)
2048 #undef ROUTINE_TYPE
2049 #undef TYPE_DATA
2050 #undef TYPE_COUNT
2051 #undef NF_ROUTINE
2052 #undef ARGS
2053 #undef LOG
2054 #define ROUTINE_TYPE 'CHAR'
2055 #define TYPE_DATA  character*(*) ,intent(in) :: Data
2056 #define TYPE_COUNT
2057 #define NF_ROUTINE NF_PUT_ATT_TEXT
2058 #define ARGS len_trim(Data),trim(Data)
2059 #define CHAR_TYPE
2060 #include "ext_ncd_put_var_ti.code"
2061 #undef CHAR_TYPE
2062 end subroutine ext_ncd_put_var_ti_char
2063
2064 subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
2065 #undef ROUTINE_TYPE
2066 #undef TYPE_DATA
2067 #undef TYPE_COUNT
2068 #undef NF_ROUTINE
2069 #undef NF_TYPE
2070 #undef LENGTH
2071 #undef ARG
2072 #undef LOG
2073 #define ROUTINE_TYPE 'CHAR'
2074 #define TYPE_DATA  character*(*) ,intent(in) :: Data
2075 #define TYPE_COUNT
2076 #define NF_ROUTINE NF_PUT_VARA_TEXT
2077 #define NF_TYPE NF_CHAR
2078 #define LENGTH len(Data)
2079 #include "ext_ncd_put_var_td.code"
2080 end subroutine ext_ncd_put_var_td_char
2081
2082 subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status)
2083 #undef ROUTINE_TYPE
2084 #undef TYPE_DATA
2085 #undef TYPE_BUFFER
2086 #undef TYPE_COUNT
2087 #undef TYPE_OUTCOUNT
2088 #undef NF_TYPE
2089 #undef NF_ROUTINE
2090 #undef COPY
2091 #define ROUTINE_TYPE 'REAL'
2092 #define TYPE_DATA     real   ,intent(out) :: Data(*)
2093 #define TYPE_BUFFER   real   ,allocatable :: Buffer(:)
2094 #define TYPE_COUNT    integer,intent(in)  :: Count
2095 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2096 #define NF_TYPE NF_FLOAT
2097 #define NF_ROUTINE NF_GET_ATT_REAL
2098 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2099 #include "ext_ncd_get_var_ti.code"
2100 end subroutine ext_ncd_get_var_ti_real
2101
2102 subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2103 #undef ROUTINE_TYPE
2104 #undef TYPE_DATA
2105 #undef TYPE_BUFFER
2106 #undef TYPE_COUNT
2107 #undef TYPE_OUTCOUNT
2108 #undef NF_TYPE
2109 #undef NF_ROUTINE
2110 #undef LENGTH
2111 #undef COPY
2112 #define ROUTINE_TYPE 'REAL'
2113 #define TYPE_DATA     real   ,intent(out) :: Data(*)
2114 #define TYPE_BUFFER real
2115 #define TYPE_COUNT    integer,intent(in)  :: Count
2116 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2117 #define NF_TYPE NF_FLOAT
2118 #define NF_ROUTINE NF_GET_VARA_REAL
2119 #define LENGTH min(Count,Len1)
2120 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2121 #include "ext_ncd_get_var_td.code"
2122 end subroutine ext_ncd_get_var_td_real
2123
2124 subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status)
2125 #undef ROUTINE_TYPE
2126 #undef TYPE_DATA
2127 #undef TYPE_BUFFER
2128 #undef TYPE_COUNT
2129 #undef TYPE_OUTCOUNT
2130 #undef NF_TYPE
2131 #undef NF_ROUTINE
2132 #undef COPY
2133 #define ROUTINE_TYPE 'DOUBLE'
2134 #define TYPE_DATA     real*8 ,intent(out) :: Data(*)
2135 #define TYPE_BUFFER   real*8 ,allocatable :: Buffer(:)
2136 #define TYPE_COUNT    integer,intent(in)  :: Count
2137 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2138 #define NF_TYPE NF_DOUBLE
2139 #define NF_ROUTINE NF_GET_ATT_DOUBLE
2140 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2141 #include "ext_ncd_get_var_ti.code"
2142 end subroutine ext_ncd_get_var_ti_double
2143
2144 subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2145 #undef ROUTINE_TYPE
2146 #undef TYPE_DATA
2147 #undef TYPE_BUFFER
2148 #undef TYPE_COUNT
2149 #undef TYPE_OUTCOUNT
2150 #undef NF_TYPE
2151 #undef NF_ROUTINE
2152 #undef LENGTH
2153 #undef COPY
2154 #define ROUTINE_TYPE 'DOUBLE'
2155 #define TYPE_DATA     real*8 ,intent(out) :: Data(*)
2156 #define TYPE_BUFFER real*8
2157 #define TYPE_COUNT    integer,intent(in)  :: Count
2158 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2159 #define NF_TYPE NF_DOUBLE
2160 #define NF_ROUTINE NF_GET_VARA_DOUBLE
2161 #define LENGTH min(Count,Len1)
2162 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2163 #include "ext_ncd_get_var_td.code"
2164 end subroutine ext_ncd_get_var_td_double
2165
2166 subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status)
2167 #undef ROUTINE_TYPE
2168 #undef TYPE_DATA
2169 #undef TYPE_BUFFER
2170 #undef TYPE_COUNT
2171 #undef TYPE_OUTCOUNT
2172 #undef NF_TYPE
2173 #undef NF_ROUTINE
2174 #undef COPY
2175 #define ROUTINE_TYPE 'INTEGER'
2176 #define TYPE_DATA     integer,intent(out) :: Data(*)
2177 #define TYPE_BUFFER   integer,allocatable :: Buffer(:)
2178 #define TYPE_COUNT    integer,intent(in)  :: Count
2179 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2180 #define NF_TYPE NF_INT
2181 #define NF_ROUTINE NF_GET_ATT_INT
2182 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2183 #include "ext_ncd_get_var_ti.code"
2184 end subroutine ext_ncd_get_var_ti_integer
2185
2186 subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2187 #undef ROUTINE_TYPE
2188 #undef TYPE_DATA
2189 #undef TYPE_BUFFER
2190 #undef TYPE_COUNT
2191 #undef TYPE_OUTCOUNT
2192 #undef NF_TYPE
2193 #undef NF_ROUTINE
2194 #undef LENGTH
2195 #undef COPY
2196 #define ROUTINE_TYPE 'INTEGER'
2197 #define TYPE_DATA     integer,intent(out) :: Data(*)
2198 #define TYPE_BUFFER integer
2199 #define TYPE_COUNT    integer,intent(in)  :: Count
2200 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2201 #define NF_TYPE NF_INT
2202 #define NF_ROUTINE NF_GET_VARA_INT
2203 #define LENGTH min(Count,Len1)
2204 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2205 #include "ext_ncd_get_var_td.code"
2206 end subroutine ext_ncd_get_var_td_integer
2207
2208 subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status)
2209 #undef ROUTINE_TYPE
2210 #undef TYPE_DATA
2211 #undef TYPE_BUFFER
2212 #undef TYPE_COUNT
2213 #undef TYPE_OUTCOUNT
2214 #undef NF_TYPE
2215 #undef NF_ROUTINE
2216 #undef COPY
2217 #define ROUTINE_TYPE 'LOGICAL'
2218 #define TYPE_DATA     logical,intent(out) :: Data(*)
2219 #define TYPE_BUFFER   integer,allocatable :: Buffer(:)
2220 #define TYPE_COUNT    integer,intent(in)  :: Count
2221 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2222 #define NF_TYPE NF_INT
2223 #define NF_ROUTINE NF_GET_ATT_INT
2224 #define COPY   Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1
2225 #include "ext_ncd_get_var_ti.code"
2226 end subroutine ext_ncd_get_var_ti_logical
2227
2228 subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2229 #undef ROUTINE_TYPE
2230 #undef TYPE_DATA
2231 #undef TYPE_BUFFER
2232 #undef TYPE_COUNT
2233 #undef TYPE_OUTCOUNT
2234 #undef NF_TYPE
2235 #undef NF_ROUTINE
2236 #undef LENGTH
2237 #undef COPY
2238 #define ROUTINE_TYPE 'LOGICAL'
2239 #define TYPE_DATA     logical,intent(out) :: Data(*)
2240 #define TYPE_BUFFER   integer
2241 #define TYPE_COUNT    integer,intent(in)  :: Count
2242 #define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2243 #define NF_TYPE NF_INT
2244 #define NF_ROUTINE NF_GET_VARA_INT
2245 #define LENGTH min(Count,Len1)
2246 #define COPY   Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1
2247 #include "ext_ncd_get_var_td.code"
2248 end subroutine ext_ncd_get_var_td_logical
2249
2250 subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status)
2251 #undef ROUTINE_TYPE
2252 #undef TYPE_DATA
2253 #undef TYPE_BUFFER
2254 #undef TYPE_COUNT
2255 #undef TYPE_OUTCOUNT
2256 #undef NF_TYPE
2257 #undef NF_ROUTINE
2258 #undef COPY
2259 #define ROUTINE_TYPE 'CHAR'
2260 #define TYPE_DATA   character*(*) ,intent(out) :: Data
2261 #define TYPE_BUFFER
2262 #define TYPE_COUNT integer :: Count = 1
2263 #define TYPE_OUTCOUNT
2264 #define NF_TYPE NF_CHAR
2265 #define NF_ROUTINE NF_GET_ATT_TEXT
2266 #define COPY
2267 #define CHAR_TYPE
2268 #include "ext_ncd_get_var_ti.code"
2269 #undef CHAR_TYPE
2270 end subroutine ext_ncd_get_var_ti_char
2271
2272 subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
2273 #undef ROUTINE_TYPE
2274 #undef TYPE_DATA
2275 #undef TYPE_BUFFER
2276 #undef TYPE_COUNT
2277 #undef TYPE_OUTCOUNT
2278 #undef NF_TYPE
2279 #undef NF_ROUTINE
2280 #undef LENGTH
2281 #define ROUTINE_TYPE 'CHAR'
2282 #define TYPE_DATA character*(*) ,intent(out)    :: Data
2283 #define TYPE_BUFFER character (80)
2284 #define TYPE_COUNT integer :: Count = 1
2285 #define TYPE_OUTCOUNT
2286 #define NF_TYPE NF_CHAR
2287 #define NF_ROUTINE NF_GET_VARA_TEXT
2288 #define LENGTH Len1
2289 #define CHAR_TYPE
2290 #include "ext_ncd_get_var_td.code"
2291 #undef CHAR_TYPE
2292 end subroutine ext_ncd_get_var_td_char
2293
2294 subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status)
2295   integer               ,intent(in)     :: DataHandle
2296   character*(*)         ,intent(in)     :: Element
2297   character*(*)         ,intent(in)     :: DateStr
2298   real                  ,intent(in)     :: Data(*)
2299   integer               ,intent(in)     :: Count
2300   integer               ,intent(out)    :: Status
2301
2302   call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, &
2303        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2304   return
2305 end subroutine ext_ncd_put_dom_td_real
2306
2307 subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status)
2308   integer               ,intent(in)     :: DataHandle
2309   character*(*)         ,intent(in)     :: Element
2310   character*(*)         ,intent(in)     :: DateStr
2311   integer               ,intent(in)     :: Data(*)
2312   integer               ,intent(in)     :: Count
2313   integer               ,intent(out)    :: Status
2314
2315   call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, &
2316        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,Status)
2317   return
2318 end subroutine ext_ncd_put_dom_td_integer
2319
2320 subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status)
2321   integer               ,intent(in)     :: DataHandle
2322   character*(*)         ,intent(in)     :: Element
2323   character*(*)         ,intent(in)     :: DateStr
2324   real*8                ,intent(in)     :: Data(*)
2325   integer               ,intent(in)     :: Count
2326   integer               ,intent(out)    :: Status
2327
2328   call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, &
2329        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'   ,Data,Count,Status)
2330   return
2331 end subroutine ext_ncd_put_dom_td_double
2332
2333 subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status)
2334   integer               ,intent(in)     :: DataHandle
2335   character*(*)         ,intent(in)     :: Element
2336   character*(*)         ,intent(in)     :: DateStr
2337   logical               ,intent(in)     :: Data(*)
2338   integer               ,intent(in)     :: Count
2339   integer               ,intent(out)    :: Status
2340
2341   call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, &
2342        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,Status)
2343   return
2344 end subroutine ext_ncd_put_dom_td_logical
2345
2346 subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2347   integer               ,intent(in)     :: DataHandle
2348   character*(*)         ,intent(in)     :: Element
2349   character*(*)         ,intent(in)     :: DateStr
2350   character*(*)         ,intent(in)     :: Data
2351   integer               ,intent(out)    :: Status
2352
2353   call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, &
2354        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2355   return
2356 end subroutine ext_ncd_put_dom_td_char
2357
2358 subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2359   integer               ,intent(in)     :: DataHandle
2360   character*(*)         ,intent(in)     :: Element
2361   character*(*)         ,intent(in)     :: DateStr
2362   real                  ,intent(out)    :: Data(*)
2363   integer               ,intent(in)     :: Count
2364   integer               ,intent(out)    :: OutCount
2365   integer               ,intent(out)    :: Status
2366   call ext_ncd_get_var_td_real(DataHandle,Element,DateStr,          &
2367        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2368   return
2369 end subroutine ext_ncd_get_dom_td_real
2370
2371 subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2372   integer               ,intent(in)     :: DataHandle
2373   character*(*)         ,intent(in)     :: Element
2374   character*(*)         ,intent(in)     :: DateStr
2375   integer               ,intent(out)    :: Data(*)
2376   integer               ,intent(in)     :: Count
2377   integer               ,intent(out)    :: OutCount
2378   integer               ,intent(out)    :: Status
2379   call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,          &
2380        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,OutCount,Status)
2381   return
2382 end subroutine ext_ncd_get_dom_td_integer
2383
2384 subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2385   integer               ,intent(in)     :: DataHandle
2386   character*(*)         ,intent(in)     :: Element
2387   character*(*)         ,intent(in)     :: DateStr
2388   real*8                ,intent(out)    :: Data(*)
2389   integer               ,intent(in)     :: Count
2390   integer               ,intent(out)    :: OutCount
2391   integer               ,intent(out)    :: Status
2392   call ext_ncd_get_var_td_double(DataHandle,Element,DateStr,          &
2393        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'   ,Data,Count,OutCount,Status)
2394   return
2395 end subroutine ext_ncd_get_dom_td_double
2396
2397 subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2398   integer               ,intent(in)     :: DataHandle
2399   character*(*)         ,intent(in)     :: Element
2400   character*(*)         ,intent(in)     :: DateStr
2401   logical               ,intent(out)    :: Data(*)
2402   integer               ,intent(in)     :: Count
2403   integer               ,intent(out)    :: OutCount
2404   integer               ,intent(out)    :: Status
2405   call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,          &
2406        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_'    ,Data,Count,OutCount,Status)
2407   return
2408 end subroutine ext_ncd_get_dom_td_logical
2409
2410 subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2411   integer               ,intent(in)     :: DataHandle
2412   character*(*)         ,intent(in)     :: Element
2413   character*(*)         ,intent(in)     :: DateStr
2414   character*(*)         ,intent(out)    :: Data
2415   integer               ,intent(out)    :: Status
2416   call ext_ncd_get_var_td_char(DataHandle,Element,DateStr,          &
2417        'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2418   return
2419 end subroutine ext_ncd_get_dom_td_char
2420
2421 subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn,  &
2422   Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger,  DimNames,              &
2423   DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2424   use wrf_data
2425   use ext_ncd_support_routines
2426   implicit none
2427   include 'wrf_status_codes.h'
2428   include 'netcdf.inc'
2429   integer                       ,intent(in)    :: DataHandle
2430   character*(*)                 ,intent(in)    :: DateStr
2431   character*(*)                 ,intent(in)    :: Var
2432   integer                       ,intent(inout) :: Field(*)
2433   integer                       ,intent(in)    :: FieldTypeIn
2434   integer                       ,intent(inout) :: Comm
2435   integer                       ,intent(inout) :: IOComm
2436   integer                       ,intent(in)    :: DomainDesc
2437   character*(*)                 ,intent(in)    :: MemoryOrdIn
2438   character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
2439   character*(*) ,dimension(*)   ,intent(in)    :: DimNames
2440   integer       ,dimension(*)   ,intent(in)    :: DomainStart, DomainEnd
2441   integer       ,dimension(*)   ,intent(in)    :: MemoryStart, MemoryEnd
2442   integer       ,dimension(*)   ,intent(in)    :: PatchStart,  PatchEnd
2443   integer                       ,intent(out)   :: Status
2444   integer                                      :: FieldType
2445   character (3)                                :: MemoryOrder
2446   type(wrf_data_handle)         ,pointer       :: DH
2447   integer                                      :: NCID
2448   integer                                      :: NDim
2449   character (VarNameLen)                       :: VarName
2450   character (3)                                :: MemO
2451   character (3)                                :: UCMemO
2452   integer                                      :: VarID
2453   integer      ,dimension(NVarDims)            :: Length
2454   integer      ,dimension(NVarDims)            :: VDimIDs
2455   character(80),dimension(NVarDims)            :: RODimNames
2456   integer      ,dimension(NVarDims)            :: StoredStart
2457   integer      ,dimension(:,:,:,:),allocatable :: XField
2458   integer                                      :: stat
2459   integer                                      :: NVar
2460   integer                                      :: i,j
2461   integer                                      :: i1,i2,j1,j2,k1,k2
2462   integer                                      :: x1,x2,y1,y2,z1,z2
2463   integer                                      :: l1,l2,m1,m2,n1,n2
2464   integer                                      :: XType
2465   integer                                      :: di
2466   character (80)                               :: NullName
2467   logical                                      :: NotFound
2468
2469 #ifdef USE_NETCDF4_FEATURES
2470   integer, parameter                           :: cache_size = 32000000
2471   integer,dimension(NVarDims)                  :: chunks
2472   logical                                      :: need_chunking
2473   integer                                      :: compression_level
2474   integer                                      :: block_size
2475 #endif
2476
2477   MemoryOrder = trim(adjustl(MemoryOrdIn))
2478   NullName=char(0)
2479   call GetDim(MemoryOrder,NDim,Status)
2480   if(Status /= WRF_NO_ERR) then
2481     write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__
2482     call wrf_debug ( WARN , TRIM(msg))
2483     return
2484   endif
2485
2486   call DateCheck(DateStr,Status)
2487   if(Status /= WRF_NO_ERR) then
2488     write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__
2489     call wrf_debug ( WARN , TRIM(msg))
2490     return
2491   endif
2492   VarName = Var
2493   call GetDH(DataHandle,DH,Status)
2494   if(Status /= WRF_NO_ERR) then
2495     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2496     call wrf_debug ( WARN , TRIM(msg))
2497     return
2498   endif
2499   NCID = DH%NCID
2500
2501 #ifdef USE_NETCDF4_FEATURES
2502 if ( .not. DH%use_netcdf_classic ) then
2503   call set_chunking(MemoryOrder,need_chunking)
2504   compression_level = 2
2505 else
2506   need_chunking = .false.
2507 endif
2508 #endif
2509
2510   if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then
2511      FieldType = WRF_REAL
2512   else
2513      FieldType = FieldTypeIn
2514   end if
2515
2516   write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var)
2517
2518 !jm 010827  Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
2519
2520   Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2521
2522   IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN
2523      write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring'
2524      call wrf_debug ( WARN , TRIM(msg))
2525      return
2526   ENDIF
2527
2528   call ExtOrder(MemoryOrder,Length,Status)
2529   call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
2530   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2531     Status = WRF_WARN_FILE_NOT_OPENED
2532     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2533     call wrf_debug ( WARN , TRIM(msg))
2534   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2535     Status = WRF_WARN_WRITE_RONLY_FILE
2536     write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__
2537     call wrf_debug ( WARN , TRIM(msg))
2538   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2539     do NVar=1,MaxVars
2540       if(DH%VarNames(NVar) == VarName ) then
2541         Status = WRF_WARN_2DRYRUNS_1VARIABLE
2542         write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__
2543         call wrf_debug ( WARN , TRIM(msg))
2544         return
2545       elseif(DH%VarNames(NVar) == NO_NAME) then
2546         DH%VarNames(NVar) = VarName
2547         DH%NumVars        = NVar
2548         exit
2549       elseif(NVar == MaxVars) then
2550         Status = WRF_WARN_TOO_MANY_VARIABLES
2551         write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__
2552         call wrf_debug ( WARN , TRIM(msg))
2553         return
2554       endif
2555     enddo
2556     do j = 1,NDim
2557       if(RODimNames(j) == NullName .or. RODimNames(j) == '') then
2558         do i=1,MaxDims
2559           if(DH%DimLengths(i) == Length(j)) then
2560             exit
2561           elseif(DH%DimLengths(i) == NO_DIM) then
2562             stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
2563             call netcdf_err(stat,Status)
2564             if(Status /= WRF_NO_ERR) then
2565               write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2566               call wrf_debug ( WARN , TRIM(msg))
2567               return
2568             endif
2569             DH%DimLengths(i) = Length(j)
2570             exit
2571           elseif(i == MaxDims) then
2572             Status = WRF_WARN_TOO_MANY_DIMS
2573             write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__
2574             call wrf_debug ( WARN , TRIM(msg))
2575             return
2576           endif
2577         enddo
2578       else !look for input name and check if already defined
2579         NotFound = .true.
2580         do i=1,MaxDims
2581           if (DH%DimNames(i) == RODimNames(j)) then
2582             if (DH%DimLengths(i) == Length(j)) then
2583               NotFound = .false.
2584               exit
2585             else
2586               Status = WRF_WARN_DIMNAME_REDEFINED
2587               write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED  by var ', &
2588                            TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__
2589               call wrf_debug ( WARN , TRIM(msg))
2590               return
2591             endif
2592           endif
2593         enddo
2594         if (NotFound) then
2595           do i=1,MaxDims
2596             if (DH%DimLengths(i) == NO_DIM) then
2597               DH%DimNames(i) = RODimNames(j)
2598               stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
2599               call netcdf_err(stat,Status)
2600               if(Status /= WRF_NO_ERR) then
2601                 write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2602                 call wrf_debug ( WARN , TRIM(msg))
2603                 return
2604               endif
2605               DH%DimLengths(i) = Length(j)
2606               exit
2607             elseif(i == MaxDims) then
2608               Status = WRF_WARN_TOO_MANY_DIMS
2609               write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__
2610               call wrf_debug ( WARN , TRIM(msg))
2611               return
2612             endif
2613           enddo
2614         endif
2615       endif
2616       VDimIDs(j) = DH%DimIDs(i)
2617       DH%VarDimLens(j,NVar) = Length(j)
2618     enddo
2619     VDimIDs(NDim+1) = DH%DimUnlimID
2620
2621     ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
2622     IF (FieldType == WRF_REAL) THEN
2623       XType = NF_FLOAT
2624     ELSE IF (FieldType == WRF_DOUBLE) THEN
2625       Xtype = NF_DOUBLE
2626     ELSE IF (FieldType == WRF_INTEGER) THEN
2627       XType = NF_INT
2628     ELSE IF (FieldType == WRF_LOGICAL) THEN
2629       XType = NF_INT
2630     ELSE
2631         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2632         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2633         call wrf_debug ( WARN , TRIM(msg))
2634         return
2635     END IF
2636
2637     stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID)
2638     call netcdf_err(stat,Status)
2639     if(Status /= WRF_NO_ERR) then
2640       write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2641       call wrf_debug ( WARN , TRIM(msg))
2642       return
2643     endif
2644
2645 #ifdef USE_NETCDF4_FEATURES
2646   if(need_chunking) then
2647      chunks(1:NDim) = Length(1:NDim)
2648      chunks(NDim+1) = 1
2649      chunks(1) = (Length(1) + 1)/2
2650      chunks(2) = (Length(2) + 1)/2
2651
2652      block_size = 1
2653      do i = 1, NDim
2654         block_size = block_size * chunks(i)
2655      end do
2656
2657      do while (block_size > cache_size)
2658         chunks(1) = (chunks(1) + 1)/2
2659         chunks(2) = (chunks(2) + 1)/2
2660
2661         block_size = 1
2662         do i = 1, NDim
2663            block_size = block_size * chunks(i)
2664         end do
2665      end do
2666
2667 !    write(unit=0, fmt='(2x, 3a,i6)')  'file: ', __FILE__, ', line: ', __LINE__
2668 !    write(unit=0, fmt='(2x, 3a)') TRIM(VarName),':'
2669 !    write(unit=0, fmt='(10x, 2(a,i6))') 'length 1 = ', Length(1), ', chunk 1 = ', chunks(1)
2670 !    write(unit=0, fmt='(10x, 2(a,i6))') 'length 2 = ', Length(2), ', chunk 2 = ', chunks(2)
2671 !    write(unit=0, fmt='(10x, 2(a,i6))') 'length NDim+1 = ', Length(NDim+1), ', chunk NDim+1 = ', chunks(NDim+1)
2672 !    write(unit=0, fmt='(10x, a,i6)')    'compression_level = ', compression_level
2673
2674      stat = NF_DEF_VAR_CHUNKING(NCID, VarID, NF_CHUNKED, chunks(1:NDim+1))
2675      call netcdf_err(stat,Status)
2676      if(Status /= WRF_NO_ERR) then
2677        write(msg,*) 'ext_ncd_write_field: NetCDF def chunking error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2678        call wrf_debug ( WARN , TRIM(msg))
2679        return
2680      endif
2681
2682       stat = NF_DEF_VAR_DEFLATE(NCID, VarID, 1, 1, compression_level)
2683       call netcdf_err(stat,Status)
2684       if(Status /= WRF_NO_ERR) then
2685          write(msg,*) 'ext_ncd_write_field: NetCDF def compression  error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2686          call wrf_debug ( WARN , TRIM(msg))
2687          return
2688       endif
2689   endif
2690 #endif
2691
2692     DH%VarIDs(NVar) = VarID
2693     stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType)
2694     call netcdf_err(stat,Status)
2695     if(Status /= WRF_NO_ERR) then
2696       write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__
2697       call wrf_debug ( WARN , TRIM(msg))
2698       return
2699     endif
2700     call reorder(MemoryOrder,MemO)
2701     call uppercase(MemO,UCMemO)
2702     stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO)
2703     call netcdf_err(stat,Status)
2704     if(Status /= WRF_NO_ERR) then
2705       write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__
2706       call wrf_debug ( WARN , TRIM(msg))
2707       return
2708     endif
2709   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
2710     do NVar=1,DH%NumVars
2711       if(DH%VarNames(NVar) == VarName) then
2712         exit
2713       elseif(NVar == DH%NumVars) then
2714         Status = WRF_WARN_VAR_NF
2715         write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__
2716         call wrf_debug ( WARN , TRIM(msg))
2717         return
2718       endif
2719     enddo
2720     VarID = DH%VarIDs(NVar)
2721     do j=1,NDim
2722       if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then
2723         Status = WRF_WARN_WRTLEN_NE_DRRUNLEN
2724         write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |',   &
2725                      VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__
2726         call wrf_debug ( WARN , TRIM(msg))
2727         write(msg,*) '   LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar)
2728         call wrf_debug ( WARN , TRIM(msg))
2729         return
2730 !jm 010825      elseif(DomainStart(j) < MemoryStart(j)) then
2731       elseif(PatchStart(j) < MemoryStart(j)) then
2732         Status = WRF_WARN_DIMENSION_ERROR
2733         write(msg,*) 'Warning DIMENSION ERROR for |',VarName,    &
2734                      '| in ',__FILE__,', line', __LINE__
2735         call wrf_debug ( WARN , TRIM(msg))
2736         return
2737       endif
2738     enddo
2739     StoredStart = 1
2740     call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
2741     call GetIndices(NDim,StoredStart,Length   ,x1,x2,y1,y2,z1,z2)
2742     call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
2743     di=1
2744     if(FieldType == WRF_DOUBLE) di=2
2745     allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
2746     if(stat/= 0) then
2747       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
2748       write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
2749       call wrf_debug ( FATAL , TRIM(msg))
2750       return
2751     endif
2752     if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then
2753        call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2754                                                 ,XField,x1,x2,y1,y2,z1,z2 &
2755                                                    ,i1,i2,j1,j2,k1,k2 )
2756     else
2757        call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2758                                             ,XField,x1,x2,y1,y2,z1,z2 &
2759                                                    ,i1,i2,j1,j2,k1,k2 )
2760     end if
2761     call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, &
2762                   FieldType,NCID,VarID,XField,Status)
2763     if(Status /= WRF_NO_ERR) then
2764       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2765       call wrf_debug ( WARN , TRIM(msg))
2766       return
2767     endif
2768     deallocate(XField, STAT=stat)
2769     if(stat/= 0) then
2770       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
2771       write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
2772       call wrf_debug ( FATAL , TRIM(msg))
2773       return
2774     endif
2775   else
2776     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2777     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2778     call wrf_debug ( FATAL , TRIM(msg))
2779   endif
2780   DH%first_operation  = .FALSE.
2781   return
2782 end subroutine ext_ncd_write_field
2783
2784 subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm,  &
2785   IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames,                       &
2786   DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2787   use wrf_data
2788   use ext_ncd_support_routines
2789   implicit none
2790   include 'wrf_status_codes.h'
2791   include 'netcdf.inc'
2792   integer                       ,intent(in)    :: DataHandle
2793   character*(*)                 ,intent(in)    :: DateStr
2794   character*(*)                 ,intent(in)    :: Var
2795   integer                       ,intent(out)   :: Field(*)
2796   integer                       ,intent(in)    :: FieldType
2797   integer                       ,intent(inout) :: Comm
2798   integer                       ,intent(inout) :: IOComm
2799   integer                       ,intent(in)    :: DomainDesc
2800   character*(*)                 ,intent(in)    :: MemoryOrdIn
2801   character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
2802   character*(*) , dimension (*) ,intent(in)    :: DimNames
2803   integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
2804   integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
2805   integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
2806   integer                       ,intent(out)   :: Status
2807   character (3)                                :: MemoryOrder
2808   character (NF_MAX_NAME)                      :: dimname
2809   type(wrf_data_handle)         ,pointer       :: DH
2810   integer                                      :: NDim
2811   integer                                      :: NCID
2812   character (VarNameLen)                       :: VarName
2813   integer                                      :: VarID
2814   integer ,dimension(NVarDims)                 :: VCount
2815   integer ,dimension(NVarDims)                 :: VStart
2816   integer ,dimension(NVarDims)                 :: Length
2817   integer ,dimension(NVarDims)                 :: VDimIDs
2818   integer ,dimension(NVarDims)                 :: MemS
2819   integer ,dimension(NVarDims)                 :: MemE
2820   integer ,dimension(NVarDims)                 :: StoredStart
2821   integer ,dimension(NVarDims)                 :: StoredLen
2822   integer ,dimension(:,:,:,:)   ,allocatable   :: XField
2823   integer                                      :: NVar
2824   integer                                      :: j
2825   integer                                      :: i1,i2,j1,j2,k1,k2
2826   integer                                      :: x1,x2,y1,y2,z1,z2
2827   integer                                      :: l1,l2,m1,m2,n1,n2
2828   character (VarNameLen)                       :: Name
2829   integer                                      :: XType
2830   integer                                      :: StoredDim
2831   integer                                      :: NAtts
2832   integer                                      :: Len
2833   integer                                      :: stat
2834   integer                                      :: di
2835   integer                                      :: FType
2836
2837   MemoryOrder = trim(adjustl(MemoryOrdIn))
2838   call GetDim(MemoryOrder,NDim,Status)
2839   if(Status /= WRF_NO_ERR) then
2840     write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', &
2841                  TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__
2842     call wrf_debug ( WARN , TRIM(msg))
2843     return
2844   endif
2845   call DateCheck(DateStr,Status)
2846   if(Status /= WRF_NO_ERR) then
2847     write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), &
2848                  '| in ext_ncd_read_field ',__FILE__,', line', __LINE__
2849     call wrf_debug ( WARN , TRIM(msg))
2850     return
2851   endif
2852   VarName = Var
2853   call GetDH(DataHandle,DH,Status)
2854   if(Status /= WRF_NO_ERR) then
2855     write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__
2856     call wrf_debug ( WARN , TRIM(msg))
2857     return
2858   endif
2859   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2860     Status = WRF_WARN_FILE_NOT_OPENED
2861     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2862     call wrf_debug ( WARN , TRIM(msg))
2863   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2864 ! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return.
2865 !    Status = WRF_WARN_DRYRUN_READ
2866 !    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2867 !    call wrf_debug ( WARN , TRIM(msg))
2868     Status = WRF_NO_ERR
2869     RETURN
2870   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2871     Status = WRF_WARN_READ_WONLY_FILE
2872     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2873     call wrf_debug ( WARN , TRIM(msg))
2874   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
2875     NCID = DH%NCID
2876
2877 !jm    Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
2878     Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2879     call ExtOrder(MemoryOrder,Length,Status)
2880     stat = NF_INQ_VARID(NCID,VarName,VarID)
2881     call netcdf_err(stat,Status)
2882     if(Status /= WRF_NO_ERR) then
2883       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname
2884       call wrf_debug ( WARN , TRIM(msg))
2885       return
2886     endif
2887     stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts)
2888     call netcdf_err(stat,Status)
2889     if(Status /= WRF_NO_ERR) then
2890       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2891       call wrf_debug ( WARN , TRIM(msg))
2892       return
2893     endif
2894     stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType)
2895     call netcdf_err(stat,Status)
2896     if(Status /= WRF_NO_ERR) then
2897       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2898       call wrf_debug ( WARN , TRIM(msg))
2899       return
2900     endif
2901 ! allow coercion between double and single prec real
2902 !jm    if(FieldType /= Ftype) then
2903     if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
2904       if ( .NOT. (Ftype     == WRF_REAL .OR. Ftype     == WRF_DOUBLE ))  then
2905         Status = WRF_WARN_TYPE_MISMATCH
2906         write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2907         call wrf_debug ( WARN , TRIM(msg))
2908         return
2909       endif
2910     else if(FieldType /= Ftype) then
2911       Status = WRF_WARN_TYPE_MISMATCH
2912       write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2913       call wrf_debug ( WARN , TRIM(msg))
2914       return
2915     endif
2916
2917     ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
2918     IF (FieldType == WRF_REAL) THEN
2919 ! allow coercion between double and single prec real
2920         if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) )  then
2921           Status = WRF_WARN_TYPE_MISMATCH
2922           write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2923         endif
2924     ELSE IF (FieldType == WRF_DOUBLE) THEN
2925 ! allow coercion between double and single prec real
2926         if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) )  then
2927           Status = WRF_WARN_TYPE_MISMATCH
2928           write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__
2929         endif
2930     ELSE IF (FieldType == WRF_INTEGER) THEN
2931         if(XType /= NF_INT)  then
2932           Status = WRF_WARN_TYPE_MISMATCH
2933           write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__
2934         endif
2935     ELSE IF (FieldType == WRF_LOGICAL) THEN
2936         if(XType /= NF_INT)  then
2937           Status = WRF_WARN_TYPE_MISMATCH
2938           write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2939         endif
2940     ELSE
2941         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2942         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2943     END IF
2944
2945     if(Status /= WRF_NO_ERR) then
2946       call wrf_debug ( WARN , TRIM(msg))
2947       return
2948     endif
2949     ! NDim=0 for scalars.  Handle read of old NDim=1 files.  TBH:  20060502
2950     IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN
2951       stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname)
2952       call netcdf_err(stat,Status)
2953       if(Status /= WRF_NO_ERR) then
2954         write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2955         call wrf_debug ( WARN , TRIM(msg))
2956         return
2957       endif
2958       IF ( dimname(1:10) == 'ext_scalar' ) THEN
2959         NDim = 1
2960         Length(1) = 1
2961       ENDIF
2962     ENDIF
2963     if(StoredDim /= NDim+1) then
2964       Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM
2965       write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr)
2966       call wrf_debug ( FATAL , msg)
2967       write(msg,*) '  StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1
2968       call wrf_debug ( FATAL , msg)
2969       return
2970     endif
2971     do j=1,NDim
2972       stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j))
2973       call netcdf_err(stat,Status)
2974       if(Status /= WRF_NO_ERR) then
2975         write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2976         call wrf_debug ( WARN , TRIM(msg))
2977         return
2978       endif
2979       if(Length(j) > StoredLen(j)) then
2980         Status = WRF_WARN_READ_PAST_EOF
2981         write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j)
2982         call wrf_debug ( WARN , TRIM(msg))
2983         return
2984       elseif(Length(j) <= 0) then
2985         Status = WRF_WARN_ZERO_LENGTH_READ
2986         write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__
2987         call wrf_debug ( WARN , TRIM(msg))
2988         return
2989       elseif(DomainStart(j) < MemoryStart(j)) then
2990         Status = WRF_WARN_DIMENSION_ERROR
2991         write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), &
2992                      ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__
2993         call wrf_debug ( WARN , TRIM(msg))
2994 !        return
2995       endif
2996     enddo
2997
2998     StoredStart = 1
2999     call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
3000     call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2)
3001 !jm    call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2)
3002     call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
3003
3004     di=1
3005     if(FieldType == WRF_DOUBLE) di=2
3006     allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
3007     if(stat/= 0) then
3008       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
3009       write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
3010       call wrf_debug ( FATAL , msg)
3011       return
3012     endif
3013     call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, &
3014                   FieldType,NCID,VarID,XField,Status)
3015     if(Status /= WRF_NO_ERR) then
3016       write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3017       call wrf_debug ( WARN , TRIM(msg))
3018       return
3019     endif
3020     call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
3021                                         ,XField,x1,x2,y1,y2,z1,z2 &
3022                                                ,i1,i2,j1,j2,k1,k2 )
3023     deallocate(XField, STAT=stat)
3024     if(stat/= 0) then
3025       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
3026       write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
3027       call wrf_debug ( FATAL , msg)
3028       return
3029     endif
3030   else
3031     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3032     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3033     call wrf_debug ( FATAL , msg)
3034   endif
3035   DH%first_operation  = .FALSE.
3036   return
3037 end subroutine ext_ncd_read_field
3038
3039 subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status )
3040   use wrf_data
3041   use ext_ncd_support_routines
3042   implicit none
3043   include 'wrf_status_codes.h'
3044   integer               ,intent(in)     :: DataHandle
3045   character*(*)         ,intent(inout)  :: FileName
3046   integer               ,intent(out)    :: FileStatus
3047   integer               ,intent(out)    :: Status
3048   type(wrf_data_handle) ,pointer        :: DH
3049
3050   !call upgrade_filename(FileName)
3051
3052   call GetDH(DataHandle,DH,Status)
3053   if(Status /= WRF_NO_ERR) then
3054     FileStatus = WRF_FILE_NOT_OPENED
3055     return
3056   endif
3057   if(trim(FileName) /= trim(DH%FileName)) then
3058     FileStatus = WRF_FILE_NOT_OPENED
3059   else
3060     FileStatus = DH%FileStatus
3061   endif
3062   Status = WRF_NO_ERR
3063   return
3064 end subroutine ext_ncd_inquire_opened
3065
3066 subroutine ext_ncd_inquire_filename( Datahandle, FileName,  FileStatus, Status )
3067   use wrf_data
3068   use ext_ncd_support_routines
3069   implicit none
3070   include 'wrf_status_codes.h'
3071   integer               ,intent(in)     :: DataHandle
3072   character*(*)         ,intent(out)    :: FileName
3073   integer               ,intent(out)    :: FileStatus
3074   integer               ,intent(out)    :: Status
3075   type(wrf_data_handle) ,pointer        :: DH
3076   FileStatus = WRF_FILE_NOT_OPENED
3077   call GetDH(DataHandle,DH,Status)
3078   if(Status /= WRF_NO_ERR) then
3079     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3080     call wrf_debug ( WARN , TRIM(msg))
3081     return
3082   endif
3083   FileName = trim(DH%FileName)
3084   FileStatus = DH%FileStatus
3085   Status = WRF_NO_ERR
3086   return
3087 end subroutine ext_ncd_inquire_filename
3088
3089 subroutine ext_ncd_set_time(DataHandle, DateStr, Status)
3090   use wrf_data
3091   use ext_ncd_support_routines
3092   implicit none
3093   include 'wrf_status_codes.h'
3094   integer               ,intent(in)     :: DataHandle
3095   character*(*)         ,intent(in)     :: DateStr
3096   integer               ,intent(out)    :: Status
3097   type(wrf_data_handle) ,pointer        :: DH
3098   integer                               :: i
3099
3100   call DateCheck(DateStr,Status)
3101   if(Status /= WRF_NO_ERR) then
3102     write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
3103     call wrf_debug ( WARN , TRIM(msg))
3104     return
3105   endif
3106   call GetDH(DataHandle,DH,Status)
3107   if(Status /= WRF_NO_ERR) then
3108     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3109     call wrf_debug ( WARN , TRIM(msg))
3110     return
3111   endif
3112   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3113     Status = WRF_WARN_FILE_NOT_OPENED
3114     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3115     call wrf_debug ( WARN , TRIM(msg))
3116   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3117     Status = WRF_WARN_FILE_NOT_COMMITTED
3118     write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
3119     call wrf_debug ( WARN , TRIM(msg))
3120   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3121     Status = WRF_WARN_READ_WONLY_FILE
3122     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3123     call wrf_debug ( WARN , TRIM(msg))
3124   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3125     do i=1,MaxTimes
3126       if(DH%Times(i)==DateStr) then
3127         DH%CurrentTime = i
3128         exit
3129       endif
3130       if(i==MaxTimes) then
3131         Status = WRF_WARN_TIME_NF
3132         return
3133       endif
3134     enddo
3135     DH%CurrentVariable = 0
3136     Status = WRF_NO_ERR
3137   else
3138     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3139     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3140     call wrf_debug ( FATAL , msg)
3141   endif
3142   return
3143 end subroutine ext_ncd_set_time
3144
3145 subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status)
3146   use wrf_data
3147   use ext_ncd_support_routines
3148   implicit none
3149   include 'wrf_status_codes.h'
3150   integer               ,intent(in)     :: DataHandle
3151   character*(*)         ,intent(out)    :: DateStr
3152   integer               ,intent(out)    :: Status
3153   type(wrf_data_handle) ,pointer        :: DH
3154
3155   call GetDH(DataHandle,DH,Status)
3156   if(Status /= WRF_NO_ERR) then
3157     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3158     call wrf_debug ( WARN , TRIM(msg))
3159     return
3160   endif
3161   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3162     Status = WRF_WARN_FILE_NOT_OPENED
3163     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3164     call wrf_debug ( WARN , TRIM(msg))
3165   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3166     Status = WRF_WARN_DRYRUN_READ
3167     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3168     call wrf_debug ( WARN , TRIM(msg))
3169   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3170     Status = WRF_WARN_READ_WONLY_FILE
3171     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3172     call wrf_debug ( WARN , TRIM(msg))
3173   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
3174     if(DH%CurrentTime >= DH%NumberTimes) then
3175       Status = WRF_WARN_TIME_EOF
3176       return
3177     endif
3178     DH%CurrentTime     = DH%CurrentTime +1
3179     DateStr            = DH%Times(DH%CurrentTime)
3180     DH%CurrentVariable = 0
3181     Status = WRF_NO_ERR
3182   else
3183     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3184     write(msg,*) 'DH%FileStatus ',DH%FileStatus
3185     call wrf_debug ( FATAL , msg)
3186     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3187     call wrf_debug ( FATAL , msg)
3188   endif
3189   return
3190 end subroutine ext_ncd_get_next_time
3191
3192 subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status)
3193   use wrf_data
3194   use ext_ncd_support_routines
3195   implicit none
3196   include 'wrf_status_codes.h'
3197   integer               ,intent(in)     :: DataHandle
3198   character*(*)         ,intent(out)    :: DateStr
3199   integer               ,intent(out)    :: Status
3200   type(wrf_data_handle) ,pointer        :: DH
3201
3202   call GetDH(DataHandle,DH,Status)
3203   if(Status /= WRF_NO_ERR) then
3204     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3205     call wrf_debug ( WARN , TRIM(msg))
3206     return
3207   endif
3208   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3209     Status = WRF_WARN_FILE_NOT_OPENED
3210     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3211     call wrf_debug ( WARN , TRIM(msg))
3212   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3213     Status = WRF_WARN_DRYRUN_READ
3214     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3215     call wrf_debug ( WARN , TRIM(msg))
3216   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3217     Status = WRF_WARN_READ_WONLY_FILE
3218     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3219     call wrf_debug ( WARN , TRIM(msg))
3220   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3221     if(DH%CurrentTime.GT.0) then
3222       DH%CurrentTime     = DH%CurrentTime -1
3223     endif
3224     DateStr            = DH%Times(MAX(1,DH%CurrentTime))
3225     DH%CurrentVariable = 0
3226     Status = WRF_NO_ERR
3227   else
3228     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3229     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3230     call wrf_debug ( FATAL , msg)
3231   endif
3232   return
3233 end subroutine ext_ncd_get_previous_time
3234
3235 subroutine ext_ncd_get_next_var(DataHandle, VarName, Status)
3236   use wrf_data
3237   use ext_ncd_support_routines
3238   implicit none
3239   include 'wrf_status_codes.h'
3240   include 'netcdf.inc'
3241   integer               ,intent(in)     :: DataHandle
3242   character*(*)         ,intent(out)    :: VarName
3243   integer               ,intent(out)    :: Status
3244   type(wrf_data_handle) ,pointer        :: DH
3245   integer                               :: stat
3246   character (80)                        :: Name
3247
3248   call GetDH(DataHandle,DH,Status)
3249   if(Status /= WRF_NO_ERR) then
3250     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3251     call wrf_debug ( WARN , TRIM(msg))
3252     return
3253   endif
3254   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3255     Status = WRF_WARN_FILE_NOT_OPENED
3256     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3257     call wrf_debug ( WARN , TRIM(msg))
3258   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3259     Status = WRF_WARN_DRYRUN_READ
3260     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3261     call wrf_debug ( WARN , TRIM(msg))
3262   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3263     Status = WRF_WARN_READ_WONLY_FILE
3264     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3265     call wrf_debug ( WARN , TRIM(msg))
3266   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3267
3268     DH%CurrentVariable = DH%CurrentVariable +1
3269     if(DH%CurrentVariable > DH%NumVars) then
3270       Status = WRF_WARN_VAR_EOF
3271       return
3272     endif
3273     VarName = DH%VarNames(DH%CurrentVariable)
3274     Status  = WRF_NO_ERR
3275   else
3276     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3277     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3278     call wrf_debug ( FATAL , msg)
3279   endif
3280   return
3281 end subroutine ext_ncd_get_next_var
3282
3283 subroutine ext_ncd_end_of_frame(DataHandle, Status)
3284   use wrf_data
3285   use ext_ncd_support_routines
3286   implicit none
3287   include 'netcdf.inc'
3288   include 'wrf_status_codes.h'
3289   integer               ,intent(in)     :: DataHandle
3290   integer               ,intent(out)    :: Status
3291   type(wrf_data_handle) ,pointer        :: DH
3292
3293   call GetDH(DataHandle,DH,Status)
3294   return
3295 end subroutine ext_ncd_end_of_frame
3296
3297 ! NOTE:  For scalar variables NDim is set to zero and DomainStart and
3298 ! NOTE:  DomainEnd are left unmodified.
3299 subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status)
3300   use wrf_data
3301   use ext_ncd_support_routines
3302   implicit none
3303   include 'netcdf.inc'
3304   include 'wrf_status_codes.h'
3305   integer               ,intent(in)     :: DataHandle
3306   character*(*)         ,intent(in)     :: Name
3307   integer               ,intent(out)    :: NDim
3308   character*(*)         ,intent(out)    :: MemoryOrder
3309   character*(*)                         :: Stagger ! Dummy for now
3310   integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
3311   integer               ,intent(out)    :: WrfType
3312   integer               ,intent(out)    :: Status
3313   type(wrf_data_handle) ,pointer        :: DH
3314   integer                               :: VarID
3315   integer ,dimension(NVarDims)          :: VDimIDs
3316   integer                               :: j
3317   integer                               :: stat
3318   integer                               :: XType
3319
3320   call GetDH(DataHandle,DH,Status)
3321   if(Status /= WRF_NO_ERR) then
3322     write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3323     call wrf_debug ( WARN , TRIM(msg))
3324     return
3325   endif
3326   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3327     Status = WRF_WARN_FILE_NOT_OPENED
3328     write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3329     call wrf_debug ( WARN , TRIM(msg))
3330     return
3331   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3332     Status = WRF_WARN_DRYRUN_READ
3333     write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3334     call wrf_debug ( WARN , TRIM(msg))
3335     return
3336   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3337     Status = WRF_WARN_READ_WONLY_FILE
3338     write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3339     call wrf_debug ( WARN , TRIM(msg))
3340     return
3341   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3342     stat = NF_INQ_VARID(DH%NCID,Name,VarID)
3343     call netcdf_err(stat,Status)
3344     if(Status /= WRF_NO_ERR) then
3345       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3346       call wrf_debug ( WARN , TRIM(msg))
3347       return
3348     endif
3349     stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType)
3350     call netcdf_err(stat,Status)
3351     if(Status /= WRF_NO_ERR) then
3352       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3353       call wrf_debug ( WARN , TRIM(msg))
3354       return
3355     endif
3356     stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType)
3357     call netcdf_err(stat,Status)
3358     if(Status /= WRF_NO_ERR) then
3359       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3360       call wrf_debug ( WARN , TRIM(msg))
3361       return
3362     endif
3363     select case (XType)
3364       case (NF_BYTE)
3365         Status = WRF_WARN_BAD_DATA_TYPE
3366         write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3367         call wrf_debug ( WARN , TRIM(msg))
3368         return
3369       case (NF_CHAR)
3370         Status = WRF_WARN_BAD_DATA_TYPE
3371         write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3372         call wrf_debug ( WARN , TRIM(msg))
3373         return
3374       case (NF_SHORT)
3375         Status = WRF_WARN_BAD_DATA_TYPE
3376         write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3377         call wrf_debug ( WARN , TRIM(msg))
3378         return
3379       case (NF_INT)
3380         if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then
3381           Status = WRF_WARN_BAD_DATA_TYPE
3382           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3383           call wrf_debug ( WARN , TRIM(msg))
3384           return
3385         endif
3386       case (NF_FLOAT)
3387         if(WrfType /= WRF_REAL) then
3388           Status = WRF_WARN_BAD_DATA_TYPE
3389           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3390           call wrf_debug ( WARN , TRIM(msg))
3391           return
3392         endif
3393       case (NF_DOUBLE)
3394         if(WrfType /= WRF_DOUBLE) then
3395           Status = WRF_WARN_BAD_DATA_TYPE
3396           write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3397           call wrf_debug ( WARN , TRIM(msg))
3398           return
3399         endif
3400       case default
3401         Status = WRF_WARN_DATA_TYPE_NOT_FOUND
3402         write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
3403         call wrf_debug ( WARN , TRIM(msg))
3404         return
3405     end select
3406
3407     stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder)
3408     call netcdf_err(stat,Status)
3409     if(Status /= WRF_NO_ERR) then
3410       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3411       call wrf_debug ( WARN , TRIM(msg))
3412       return
3413     endif
3414     call GetDim(MemoryOrder,NDim,Status)
3415     if(Status /= WRF_NO_ERR) then
3416       write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__
3417       call wrf_debug ( WARN , TRIM(msg))
3418       return
3419     endif
3420     stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs)
3421     call netcdf_err(stat,Status)
3422     if(Status /= WRF_NO_ERR) then
3423       write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3424       call wrf_debug ( WARN , TRIM(msg))
3425       return
3426     endif
3427     do j = 1, NDim
3428       DomainStart(j) = 1
3429       stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j))
3430       call netcdf_err(stat,Status)
3431       if(Status /= WRF_NO_ERR) then
3432         write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3433         call wrf_debug ( WARN , TRIM(msg))
3434         return
3435       endif
3436     enddo
3437   else
3438     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3439     write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3440     call wrf_debug ( FATAL , msg)
3441   endif
3442   return
3443 end subroutine ext_ncd_get_var_info
3444
3445 subroutine ext_ncd_warning_str( Code, ReturnString, Status)
3446   use wrf_data
3447   use ext_ncd_support_routines
3448   implicit none
3449   include 'netcdf.inc'
3450   include 'wrf_status_codes.h'
3451
3452   integer  , intent(in)  ::Code
3453   character *(*), intent(out) :: ReturnString
3454   integer, intent(out) ::Status
3455
3456   SELECT CASE (Code)
3457   CASE (0)
3458       ReturnString='No error'
3459       Status=WRF_NO_ERR
3460       return
3461   CASE (-1)
3462       ReturnString= 'File not found (or file is incomplete)'
3463       Status=WRF_NO_ERR
3464       return
3465   CASE (-2)
3466       ReturnString='Metadata not found'
3467       Status=WRF_NO_ERR
3468       return
3469   CASE (-3)
3470       ReturnString= 'Timestamp not found'
3471       Status=WRF_NO_ERR
3472       return
3473   CASE (-4)
3474       ReturnString= 'No more timestamps'
3475       Status=WRF_NO_ERR
3476       return
3477   CASE (-5)
3478       ReturnString= 'Variable not found'
3479       Status=WRF_NO_ERR
3480       return
3481   CASE (-6)
3482       ReturnString= 'No more variables for the current time'
3483       Status=WRF_NO_ERR
3484       return
3485   CASE (-7)
3486       ReturnString= 'Too many open files'
3487       Status=WRF_NO_ERR
3488       return
3489   CASE (-8)
3490       ReturnString= 'Data type mismatch'
3491       Status=WRF_NO_ERR
3492       return
3493   CASE (-9)
3494       ReturnString= 'Attempt to write read-only file'
3495       Status=WRF_NO_ERR
3496       return
3497   CASE (-10)
3498       ReturnString= 'Attempt to read write-only file'
3499       Status=WRF_NO_ERR
3500       return
3501   CASE (-11)
3502       ReturnString= 'Attempt to access unopened file'
3503       Status=WRF_NO_ERR
3504       return
3505   CASE (-12)
3506       ReturnString= 'Attempt to do 2 trainings for 1 variable'
3507       Status=WRF_NO_ERR
3508       return
3509   CASE (-13)
3510       ReturnString= 'Attempt to read past EOF'
3511       Status=WRF_NO_ERR
3512       return
3513   CASE (-14)
3514       ReturnString= 'Bad data handle'
3515       Status=WRF_NO_ERR
3516       return
3517   CASE (-15)
3518       ReturnString= 'Write length not equal to training length'
3519       Status=WRF_NO_ERR
3520       return
3521   CASE (-16)
3522       ReturnString= 'More dimensions requested than training'
3523       Status=WRF_NO_ERR
3524       return
3525   CASE (-17)
3526       ReturnString= 'Attempt to read more data than exists'
3527       Status=WRF_NO_ERR
3528       return
3529   CASE (-18)
3530       ReturnString= 'Input dimensions inconsistent'
3531       Status=WRF_NO_ERR
3532       return
3533   CASE (-19)
3534       ReturnString= 'Input MemoryOrder not recognized'
3535       Status=WRF_NO_ERR
3536       return
3537   CASE (-20)
3538       ReturnString= 'A dimension name with 2 different lengths'
3539       Status=WRF_NO_ERR
3540       return
3541   CASE (-21)
3542       ReturnString= 'String longer than provided storage'
3543       Status=WRF_NO_ERR
3544       return
3545   CASE (-22)
3546       ReturnString= 'Function not supportable'
3547       Status=WRF_NO_ERR
3548       return
3549   CASE (-23)
3550       ReturnString= 'Package implements this routine as NOOP'
3551       Status=WRF_NO_ERR
3552       return
3553
3554 !netcdf-specific warning messages
3555   CASE (-1007)
3556       ReturnString= 'Bad data type'
3557       Status=WRF_NO_ERR
3558       return
3559   CASE (-1008)
3560       ReturnString= 'File not committed'
3561       Status=WRF_NO_ERR
3562       return
3563   CASE (-1009)
3564       ReturnString= 'File is opened for reading'
3565       Status=WRF_NO_ERR
3566       return
3567   CASE (-1011)
3568       ReturnString= 'Attempt to write metadata after open commit'
3569       Status=WRF_NO_ERR
3570       return
3571   CASE (-1010)
3572       ReturnString= 'I/O not initialized'
3573       Status=WRF_NO_ERR
3574       return
3575   CASE (-1012)
3576      ReturnString=  'Too many variables requested'
3577       Status=WRF_NO_ERR
3578       return
3579   CASE (-1013)
3580      ReturnString=  'Attempt to close file during a dry run'
3581       Status=WRF_NO_ERR
3582       return
3583   CASE (-1014)
3584       ReturnString= 'Date string not 19 characters in length'
3585       Status=WRF_NO_ERR
3586       return
3587   CASE (-1015)
3588       ReturnString= 'Attempt to read zero length words'
3589       Status=WRF_NO_ERR
3590       return
3591   CASE (-1016)
3592       ReturnString= 'Data type not found'
3593       Status=WRF_NO_ERR
3594       return
3595   CASE (-1017)
3596       ReturnString= 'Badly formatted date string'
3597       Status=WRF_NO_ERR
3598       return
3599   CASE (-1018)
3600       ReturnString= 'Attempt at read during a dry run'
3601       Status=WRF_NO_ERR
3602       return
3603   CASE (-1019)
3604       ReturnString= 'Attempt to get zero words'
3605       Status=WRF_NO_ERR
3606       return
3607   CASE (-1020)
3608       ReturnString= 'Attempt to put zero length words'
3609       Status=WRF_NO_ERR
3610       return
3611   CASE (-1021)
3612       ReturnString= 'NetCDF error'
3613       Status=WRF_NO_ERR
3614       return
3615   CASE (-1022)
3616       ReturnString= 'Requested length <= 1'
3617       Status=WRF_NO_ERR
3618       return
3619   CASE (-1023)
3620       ReturnString= 'More data available than requested'
3621       Status=WRF_NO_ERR
3622       return
3623   CASE (-1024)
3624       ReturnString= 'New date less than previous date'
3625       Status=WRF_NO_ERR
3626       return
3627
3628   CASE DEFAULT
3629       ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. &
3630       & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need &
3631       & to be calling a package-specific routine to return a message for this warning code.'
3632       Status=WRF_NO_ERR
3633   END SELECT
3634
3635   return
3636 end subroutine ext_ncd_warning_str
3637
3638 !returns message string for all WRF and netCDF warning/error status codes
3639 !Other i/o packages must  provide their own routines to return their own status messages
3640 subroutine ext_ncd_error_str( Code, ReturnString, Status)
3641   use wrf_data
3642   use ext_ncd_support_routines
3643   implicit none
3644   include 'netcdf.inc'
3645   include 'wrf_status_codes.h'
3646
3647   integer  , intent(in)  ::Code
3648   character *(*), intent(out) :: ReturnString
3649   integer, intent(out) ::Status
3650
3651   SELECT CASE (Code)
3652   CASE (-100)
3653       ReturnString= 'Allocation Error'
3654       Status=WRF_NO_ERR
3655       return
3656   CASE (-101)
3657       ReturnString= 'Deallocation Error'
3658       Status=WRF_NO_ERR
3659       return
3660   CASE (-102)
3661       ReturnString= 'Bad File Status'
3662       Status=WRF_NO_ERR
3663       return
3664   CASE (-1004)
3665       ReturnString= 'Variable on disk is not 3D'
3666       Status=WRF_NO_ERR
3667       return
3668   CASE (-1005)
3669       ReturnString= 'Metadata on disk is not 1D'
3670       Status=WRF_NO_ERR
3671       return
3672   CASE (-1006)
3673       ReturnString= 'Time dimension too small'
3674       Status=WRF_NO_ERR
3675       return
3676   CASE DEFAULT
3677       ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. &
3678       & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need &
3679       & to be calling a package-specific routine to return a message for this error code.'
3680       Status=WRF_NO_ERR
3681   END SELECT
3682
3683   return
3684 end subroutine ext_ncd_error_str