source: trunk/WRF.COMMON/WRFV3/external/io_netcdf/ext_ncd_put_var_td.code

Last change on this file was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 7.9 KB
Line 
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  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                               :: VStart(2)
58  integer                               :: 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 = NF_DEF_DIM(NCID,DH%DimNames(i),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 = NF_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
Note: See TracBrowser for help on using the repository browser.