external/io_pnetcdf/ext_pnc_get_dom_ti.code

   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   use wrf_data_pnc
  38   use ext_pnc_support_routines
  39   implicit none
  40   include 'wrf_status_codes.h'
  41 #  include "pnetcdf.inc"
  42   integer               ,intent(in)     :: DataHandle
  43   character*(*)         ,intent(in)     :: Element
  44   TYPE_DATA
  45   TYPE_COUNT
  46   TYPE_OUTCOUNT
  47   integer               ,intent(out)    :: Status
  48   type(wrf_data_handle) ,pointer        :: DH
  49   integer                               :: XType
  50   integer(KIND=MPI_OFFSET_KIND)         :: Len_okind
  51   integer                               :: Len
  52   integer                               :: stat
  53   TYPE_BUFFER
  54
  55   call GetDH(DataHandle,DH,Status)
  56   if(Status /= WRF_NO_ERR) then
  57     write(msg,*) &
  58 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  59     call wrf_debug ( WARN , msg)
  60     return
  61   endif
  62 ! Do nothing unless it is time to read time-independent domain metadata.
  63 IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN
  64   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
  65     Status = WRF_WARN_FILE_NOT_OPENED
  66     write(msg,*) &
  67 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  68     call wrf_debug ( WARN , msg)
  69   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
  70     Status = WRF_WARN_DRYRUN_READ
  71     write(msg,*) &
  72 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  73     call wrf_debug ( WARN , msg)
  74   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
  75     Status = WRF_WARN_READ_WONLY_FILE
  76     write(msg,*) &
  77 'Warning READ WRITE ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  78     call wrf_debug ( WARN , msg)
  79   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
  80     stat = NFMPI_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len_okind)
  81     call netcdf_err(stat,Status)
  82     if(Status /= WRF_NO_ERR) then
  83       write(msg,*) &
  84 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',trim(Element)
  85       call wrf_debug ( WARN , msg)
  86       return
  87     endif
  88     Len = Len_okind
  89     if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
  90       if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
  91         Status = WRF_WARN_TYPE_MISMATCH
  92         write(msg,*) &
  93 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
  94         call wrf_debug ( WARN , msg)
  95         return
  96       endif
  97     else
  98       if( XType/=NF_TYPE) then
  99         Status = WRF_WARN_TYPE_MISMATCH
 100         write(msg,*) &
 101 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
 102         call wrf_debug ( WARN , msg)
 103         return
 104       endif
 105     endif
 106     if(Len<=0) then
 107       Status = WRF_WARN_LENGTH_LESS_THAN_1
 108       write(msg,*) &
 109 'Warning LENGTH < 1 in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
 110       call wrf_debug ( WARN , msg)
 111       return
 112     endif
 113 #ifndef CHAR_TYPE
 114     allocate(Buffer(Len), STAT=stat)
 115     if(stat/= 0) then
 116       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 117       write(msg,*) &
 118 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 119       call wrf_debug ( FATAL , msg)
 120       return
 121     endif
 122     stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,Buffer)
 123 #else
 124     Data = ''
 125     stat = NFMPI_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data)
 126 #endif
 127     call netcdf_err(stat,Status)
 128     if(Status /= WRF_NO_ERR) then
 129       write(msg,*) &
 130 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 131       call wrf_debug ( WARN , msg)
 132       return
 133     endif
 134 #ifndef CHAR_TYPE
 135     COPY
 136     deallocate(Buffer, STAT=stat)
 137     if(stat/= WRF_NO_ERR) then
 138       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 139       write(msg,*) &
 140 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 141       call wrf_debug ( FATAL , msg)
 142       return
 143     endif
 144     if(Len > Count) then
 145       OutCount = Count
 146       Status = WRF_WARN_MORE_DATA_IN_FILE
 147     else
 148       OutCount = Len
 149       Status = WRF_NO_ERR
 150     endif
 151 #endif
 152   else
 153     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 154     write(msg,*) &
 155 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 156     call wrf_debug ( FATAL , msg)
 157   endif
 158 ENDIF
 159   return