| blob | 4f82eb2902f3f5f16211443365abd39dc23b54a6 |
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 character*(*) ,intent(in) :: Var
45 TYPE_DATA
46 TYPE_COUNT
47 TYPE_OUTCOUNT
48 integer ,intent(out) :: Status
49 type(wrf_data_handle) ,pointer :: DH
50 integer :: XLen
51 integer(KIND=MPI_OFFSET_KIND) :: XLen_offset
52 TYPE_BUFFER
53 character (VarNameLen) :: VarName
54 integer :: stat
55 integer :: NVar
56 integer :: XType
58 if(Count <= 0) then
59 Status = WRF_WARN_ZERO_LENGTH_GET
60 write(msg,*) &
61 'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
62 call wrf_debug ( WARN , msg)
63 return
64 endif
65 VarName = Var
66 call GetDH(DataHandle,DH,Status)
67 if(Status /= WRF_NO_ERR) then
68 write(msg,*) &
69 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
70 call wrf_debug ( WARN , msg)
71 return
72 endif
73 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
74 Status = WRF_WARN_FILE_NOT_OPENED
75 write(msg,*) &
76 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
77 call wrf_debug ( WARN , msg)
78 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
79 Status = WRF_WARN_DRYRUN_READ
80 write(msg,*) &
81 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
82 call wrf_debug ( WARN , msg)
83 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
84 Status = WRF_WARN_READ_WONLY_FILE
85 write(msg,*) &
86 'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
87 call wrf_debug ( WARN , msg)
88 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
89 do NVar=1,DH%NumVars
90 if(DH%VarNames(NVar) == VarName) then
91 exit
92 elseif(NVar == DH%NumVars) then
93 Status = WRF_WARN_VAR_NF
94 write(msg,*) &
95 'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
96 call wrf_debug ( WARN , msg)
97 return
98 endif
99 enddo
100 XLen_offset = i2offset(XLen)
101 stat = NFMPI_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen_offset)
102 XLen = XLen_offset
103 call netcdf_err(stat,Status)
104 if(Status /= WRF_NO_ERR) then
105 write(msg,*) &
106 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
107 call wrf_debug ( WARN , msg)
108 endif
109 if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
110 if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
111 Status = WRF_WARN_TYPE_MISMATCH
112 write(msg,*) &
113 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
114 call wrf_debug ( WARN , msg)
115 return
116 endif
117 else
118 if(XType /= NF_TYPE) then
119 Status = WRF_WARN_TYPE_MISMATCH
120 write(msg,*) &
121 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
122 call wrf_debug ( WARN , msg)
123 return
124 endif
125 endif
126 #ifndef CHAR_TYPE
127 allocate(Buffer(XLen), STAT=stat)
128 if(stat/= 0) then
129 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
130 write(msg,*) &
131 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
132 call wrf_debug ( FATAL , msg)
133 return
134 endif
135 stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer )
136 #else
137 if(XLen > len(Data)) then
138 Status = WRF_WARN_CHARSTR_GT_LENDATA
139 write(msg,*) &
140 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
141 call wrf_debug ( WARN , msg)
142 return
143 endif
144 stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data )
145 #endif
146 call netcdf_err(stat,Status)
147 if(Status /= WRF_NO_ERR) then
148 write(msg,*) &
149 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
150 call wrf_debug ( WARN , msg)
151 endif
152 COPY
153 #ifndef CHAR_TYPE
154 deallocate(Buffer, STAT=stat)
155 if(stat/= 0) then
156 Status = WRF_ERR_FATAL_DEALLOCATION_ERR
157 write(msg,*) &
158 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
159 call wrf_debug ( FATAL , msg)
160 return
161 endif
162 if(XLen > Count) then
163 OutCount = Count
164 Status = WRF_WARN_MORE_DATA_IN_FILE
165 else
166 OutCount = XLen
167 Status = WRF_NO_ERR
168 endif
169 #endif
170 else
171 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
172 write(msg,*) &
173 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
174 call wrf_debug ( FATAL , msg)
175 return
176 endif
177 return