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