-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathext_ncd_put_dom_ti.code
164 lines (162 loc) · 5.6 KB
/
ext_ncd_put_dom_ti.code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
!*------------------------------------------------------------------------------
!* Standard Disclaimer
!*
!* Forecast Systems Laboratory
!* NOAA/OAR/ERL/FSL
!* 325 Broadway
!* Boulder, CO 80303
!*
!* AVIATION DIVISION
!* ADVANCED COMPUTING BRANCH
!* SMS/NNT Version: 2.0.0
!*
!* This software and its documentation are in the public domain and
!* are furnished "as is". The United States government, its
!* instrumentalities, officers, employees, and agents make no
!* warranty, express or implied, as to the usefulness of the software
!* and documentation for any purpose. They assume no
!* responsibility (1) for the use of the software and documentation;
!* or (2) to provide technical support to users.
!*
!* Permission to use, copy, modify, and distribute this software is
!* hereby granted, provided that this disclaimer notice appears in
!* all copies. All modifications to this software must be clearly
!* documented, and are solely the responsibility of the agent making
!* the modification. If significant modifications or enhancements
!* are made to this software, the SMS Development team
!* (sms-info@fsl.noaa.gov) should be notified.
!*
!*----------------------------------------------------------------------------
!*
!* WRF NetCDF I/O
! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov
!* Date: October 6, 2000
!*
!*----------------------------------------------------------------------------
use wrf_data, module_message
use ext_ncd_support_routines
implicit none
include 'wrf_status_codes.h'
include 'netcdf.inc'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
TYPE_DATA
TYPE_COUNT
integer ,intent(out) :: Status
type(wrf_data_handle) ,pointer :: DH
integer :: stat
integer :: stat2
integer ,allocatable :: Buffer(:)
integer :: i
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) &
'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
return
endif
! Do nothing unless it is time to write time-independent domain metadata.
IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_WARN_FILE_NOT_OPENED
write(msg,*) &
'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
STATUS = WRF_WARN_WRITE_RONLY_FILE
write(msg,*) &
'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
#ifdef LOG
allocate(Buffer(Count), STAT=stat)
if(stat/= 0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
return
endif
do i=1,Count
if(data(i)) then
Buffer(i)=1
else
Buffer(i)=0
endif
enddo
stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
deallocate(Buffer, STAT=stat2)
if(stat2/= 0) then
Status = WRF_ERR_FATAL_DEALLOCATION_ERR
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
return
endif
#else
stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
#endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
call mdl_message ( msg)
return
endif
elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
stat = NF_REDEF(DH%NCID)
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) &
'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
call mdl_message ( msg)
return
endif
#ifdef LOG
allocate(Buffer(Count), STAT=stat)
if(stat/= 0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) &
'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
return
endif
do i=1,Count
if(data(i)) then
Buffer(i)=1
else
Buffer(i)=0
endif
enddo
stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
deallocate(Buffer, STAT=stat2)
if(stat2/= 0) then
Status = WRF_ERR_FATAL_DEALLOCATION_ERR
write(msg,*) &
'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
return
endif
#else
stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS)
#endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) &
'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
call mdl_message ( msg)
return
endif
stat = NF_ENDDEF(DH%NCID)
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) &
'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
call mdl_message ( msg)
return
endif
else
Status = WRF_ERR_FATAL_BAD_FILE_STATUS
write(msg,*) &
'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
call mdl_message ( msg)
endif
ENDIF
return