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