| blob | a86f5c23dde724b9652ca708c99ed70ea119812d |
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 !*----------------------------------------------------------------------------
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 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
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) then
106 stat = NFMPI_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 = NFMPI_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