external/io_pnetcdf/ext_pnc_put_var_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   character*(*)         ,intent(in)     :: Var
  45   TYPE_DATA
  46   TYPE_COUNT
  47   integer               ,intent(out)    :: Status
  48   type(wrf_data_handle) ,pointer        :: DH
  49   character (VarNameLen)                :: VarName
  50   integer                               :: stat
  51   integer               ,allocatable    :: Buffer(:)
  52   integer                               :: i
  53   integer                               :: NVar
  54   character*1                           :: null
  55
  56   null=char(0)
  57   VarName = Var
  58   call GetDH(DataHandle,DH,Status)
  59   if(Status /= WRF_NO_ERR) then
  60     write(msg,*) &
  61 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  62     call wrf_debug ( WARN , msg)
  63     return
  64   endif
  65   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
  66     Status = WRF_WARN_FILE_NOT_OPENED
  67     write(msg,*) &
  68 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  69     call wrf_debug ( WARN , msg)
  70   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
  71     Status = WRF_WARN_WRITE_RONLY_FILE
  72     write(msg,*) &
  73 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  74     call wrf_debug ( WARN , msg)
  75   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
  76     Status = WRF_WARN_MD_AFTER_OPEN
  77     write(msg,*) &
  78 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  79     call wrf_debug ( WARN , msg)
  80     return
  81   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
  82     do NVar=1,MaxVars
  83       if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then
  84         exit
  85       elseif(NVar == MaxVars) then
  86         Status = WRF_WARN_VAR_NF
  87         write(msg,*) &
  88 'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ &
  89                         ,NVar,VarName
  90         call wrf_debug ( WARN , msg)
  91         return
  92       endif
  93     enddo
  94 #ifdef LOG
  95     allocate(Buffer(Count), STAT=stat)
  96     if(stat/= 0) then
  97       Status = WRF_ERR_FATAL_ALLOCATION_ERROR
  98       write(msg,*) &
  99 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 100       call wrf_debug ( FATAL , msg)
 101       return
 102     endif
 103     do i=1,Count
 104       if(data(i)) then
 105          Buffer(i)=1
 106       else
 107          Buffer(i)=0
 108       endif
 109     enddo
 110 #endif
 111 #ifdef CHAR_TYPE
 112     if(len_trim(Data).le.0) then
 113       stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element),i2offset(len_trim(null)),null)
 114     else
 115       stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS )
 116     endif
 117 #else
 118     stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS )
 119 #endif
 120     call netcdf_err(stat,Status)
 121     if(Status /= WRF_NO_ERR) then
 122       write(msg,*) &
 123 'NetCDF error for Var ',TRIM(Var),&
 124         ' Element ',trim(Element),' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 125       call wrf_debug ( WARN , msg)
 126     endif
 127 #ifdef LOG
 128     deallocate(Buffer, STAT=stat)
 129     if(stat/= 0) then
 130       Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 131       write(msg,*) &
 132 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 133       call wrf_debug ( FATAL , msg)
 134       return
 135     endif
 136 #endif
 137   else
 138     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 139     write(msg,*) &
 140 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 141     call wrf_debug ( FATAL , msg)
 142     return
 143   endif
 144   return