external/io_pnetcdf/ext_pnc_put_var_td.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)     :: DateStr
  45   character*(*)         ,intent(in)     :: Var
  46   TYPE_DATA
  47   TYPE_COUNT
  48   integer               ,intent(out)    :: Status
  49   type(wrf_data_handle) ,pointer        :: DH
  50   character (VarNameLen)                :: VarName
  51   character (40+len(Element))           :: Name
  52   integer                               :: stat
  53   integer                               :: stat2
  54   integer               ,allocatable    :: Buffer(:)
  55   integer                               :: i
  56   integer                               :: VDims (2)
  57   integer(KIND=MPI_OFFSET_KIND)         :: VStart(2)
  58   integer(KIND=MPI_OFFSET_KIND)         :: VCount(2)
  59   integer                               :: NVar
  60   integer                               :: TimeIndex
  61   integer                               :: NCID
  62
  63   VarName = Var
  64   call DateCheck(DateStr,Status)
  65   if(Status /= WRF_NO_ERR) then
  66     write(msg,*) &
  67 'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  68     call wrf_debug ( WARN , msg)
  69     return
  70   endif
  71   call GetDH(DataHandle,DH,Status)
  72   if(Status /= WRF_NO_ERR) then
  73     write(msg,*) &
  74 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  75     call wrf_debug ( WARN , msg)
  76     return
  77   endif
  78   NCID = DH%NCID
  79   call GetName(Element, VarName, Name, Status)
  80   if(Status /= WRF_NO_ERR) then
  81     write(msg,*) &
  82 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  83     call wrf_debug ( WARN , msg)
  84     return
  85   endif
  86   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
  87     Status = WRF_WARN_FILE_NOT_OPENED
  88     write(msg,*) &
  89 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  90     call wrf_debug ( WARN , msg)
  91   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
  92     Status = WRF_WARN_WRITE_RONLY_FILE
  93     write(msg,*) &
  94 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  95     call wrf_debug ( WARN , msg)
  96   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
  97     if(LENGTH < 1) then
  98       Status = WRF_WARN_ZERO_LENGTH_PUT
  99       return
 100     endif
 101     do NVar=1,MaxVars
 102       if(DH%MDVarNames(NVar) == Name) then
 103         Status = WRF_WARN_2DRYRUNS_1VARIABLE
 104         return
 105       elseif(DH%MDVarNames(NVar) == NO_NAME) then
 106         DH%MDVarNames(NVar) = Name
 107         exit
 108       elseif(NVar == MaxVars) then
 109         Status = WRF_WARN_TOO_MANY_VARIABLES
 110         write(msg,*) &
 111 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 112         call wrf_debug ( WARN , msg)
 113         return
 114       endif
 115     enddo
 116     do i=1,MaxDims
 117       if(DH%DimLengths(i) == LENGTH) then
 118         exit
 119       elseif(DH%DimLengths(i) == NO_DIM) then
 120         stat = NFMPI_DEF_DIM(NCID,DH%DimNames(i),i2offset(LENGTH),DH%DimIDs(i))
 121         call netcdf_err(stat,Status)
 122         if(Status /= WRF_NO_ERR) then
 123           write(msg,*) &
 124 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 125           call wrf_debug ( WARN , msg)
 126           return
 127         endif
 128         DH%DimLengths(i) = LENGTH
 129         exit
 130       elseif(i == MaxDims) then
 131         Status = WRF_WARN_TOO_MANY_DIMS
 132         write(msg,*) &
 133 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 134         call wrf_debug ( WARN , msg)
 135         return
 136       endif
 137     enddo
 138     DH%MDVarDimLens(NVar) = LENGTH
 139     VDims(1) = DH%DimIDs(i)
 140     VDims(2) = DH%DimUnlimID
 141     stat = NFMPI_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar))
 142     call netcdf_err(stat,Status)
 143     if(Status /= WRF_NO_ERR) then
 144       write(msg,*) &
 145 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 146       call wrf_debug ( WARN , msg)
 147       return
 148     endif
 149   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
 150     do NVar=1,MaxVars
 151       if(DH%MDVarNames(NVar) == Name) then
 152         exit
 153       elseif(DH%MDVarNames(NVar) == NO_NAME) then
 154         Status = WRF_WARN_MD_NF
 155         write(msg,*) &
 156 'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 157         call wrf_debug ( WARN , msg)
 158         return
 159       elseif(NVar == MaxVars) then
 160         Status = WRF_WARN_TOO_MANY_VARIABLES
 161         write(msg,*) &
 162 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 163         call wrf_debug ( WARN , msg)
 164         return
 165       endif
 166     enddo
 167     if(LENGTH > DH%MDVarDimLens(NVar)) then
 168       Status = WRF_WARN_COUNT_TOO_LONG
 169       write(msg,*) &
 170 'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 171       call wrf_debug ( WARN , msg)
 172       return
 173     elseif(LENGTH < 1) then
 174       Status = WRF_WARN_ZERO_LENGTH_PUT
 175       write(msg,*) &
 176 'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 177       call wrf_debug ( WARN , msg)
 178       return
 179     endif
 180     call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
 181     if(Status /= WRF_NO_ERR) then
 182       write(msg,*) &
 183 'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 184       call wrf_debug ( WARN , msg)
 185       return
 186     endif
 187     VStart(1) = 1
 188     VStart(2) = TimeIndex
 189     VCount(1) = LENGTH
 190     VCount(2) = 1
 191 #ifdef LOG
 192       allocate(Buffer(LENGTH), STAT=stat)
 193       if(stat/= 0) then
 194         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 195         write(msg,*) &
 196 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 197         call wrf_debug ( FATAL , msg)
 198         return
 199       endif
 200       do i=1,Count
 201         if(data(i)) then
 202            Buffer(i)=1
 203         else
 204            Buffer(i)=0
 205         endif
 206       enddo
 207       stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer)
 208       deallocate(Buffer, STAT=stat2)
 209       if(stat2/= 0) then
 210         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 211         write(msg,*) &
 212 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 213         call wrf_debug ( FATAL , msg)
 214         return
 215       endif
 216 #else
 217       stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data)
 218 #endif
 219     call netcdf_err(stat,Status)
 220     if(Status /= WRF_NO_ERR) then
 221       write(msg,*) &
 222 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 223       call wrf_debug ( WARN , msg)
 224       return
 225     endif
 226   else
 227     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 228     write(msg,*) &
 229 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 230     call wrf_debug ( FATAL , msg)
 231     return
 232   endif
 233   return