external/io_netcdf/ext_ncd_put_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
  38   use ext_ncd_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   integer               ,intent(out)    :: Status
  47   type(wrf_data_handle) ,pointer        :: DH
  48   integer                               :: stat
  49   integer                               :: stat2
  50   integer               ,allocatable    :: Buffer(:)
  51   integer                               :: i
  52
  53   call GetDH(DataHandle,DH,Status)
  54   if(Status /= WRF_NO_ERR) then
  55     write(msg,*) &
  56 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  57     call wrf_debug ( WARN , msg)
  58     return
  59   endif
  60 ! Do nothing unless it is time to write time-independent domain metadata.
  61 IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN
  62   if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
  63     Status = WRF_WARN_FILE_NOT_OPENED
  64     write(msg,*) &
  65 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  66     call wrf_debug ( WARN , msg)
  67   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
  68     STATUS = WRF_WARN_WRITE_RONLY_FILE
  69     write(msg,*) &
  70 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  71     call wrf_debug ( WARN , msg)
  72   elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
  73 #ifdef LOG
  74       allocate(Buffer(Count), STAT=stat)
  75       if(stat/= 0) then
  76         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
  77         write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  78         call wrf_debug ( FATAL , msg)
  79         return
  80       endif
  81       do i=1,Count
  82         if(data(i)) then
  83            Buffer(i)=1
  84         else
  85            Buffer(i)=0
  86         endif
  87       enddo
  88       stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
  89       deallocate(Buffer, STAT=stat2)
  90       if(stat2/= 0) then
  91         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
  92         write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
  93         call wrf_debug ( FATAL , msg)
  94         return
  95       endif
  96 #else
  97       stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
  98 #endif
  99     call netcdf_err(stat,Status)
 100     if(Status /= WRF_NO_ERR) then
 101       write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 102       call wrf_debug ( WARN , msg)
 103       return
 104     endif
 105   elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
 106     stat = NF_REDEF(DH%NCID)
 107     call netcdf_err(stat,Status)
 108     if(Status /= WRF_NO_ERR) then
 109       write(msg,*) &
 110 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 111       call wrf_debug ( WARN , msg)
 112       return
 113     endif
 114 #ifdef LOG
 115       allocate(Buffer(Count), STAT=stat)
 116       if(stat/= 0) then
 117         Status = WRF_ERR_FATAL_ALLOCATION_ERROR
 118         write(msg,*) &
 119 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 120         call wrf_debug ( FATAL , msg)
 121         return
 122       endif
 123       do i=1,Count
 124         if(data(i)) then
 125            Buffer(i)=1
 126         else
 127            Buffer(i)=0
 128         endif
 129       enddo
 130       stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
 131       deallocate(Buffer, STAT=stat2)
 132       if(stat2/= 0) then
 133         Status = WRF_ERR_FATAL_DEALLOCATION_ERR
 134         write(msg,*) &
 135 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 136         call wrf_debug ( FATAL , msg)
 137         return
 138       endif
 139 #else
 140       stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
 141 #endif
 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     stat = NF_ENDDEF(DH%NCID)
 150     call netcdf_err(stat,Status)
 151     if(Status /= WRF_NO_ERR) then
 152       write(msg,*) &
 153 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
 154       call wrf_debug ( WARN , msg)
 155       return
 156     endif
 157   else
 158     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 159     write(msg,*) &
 160 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
 161     call wrf_debug ( FATAL , msg)
 162   endif
 163 ENDIF
 164   return