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