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