| blob | 3722fab352c70260a0a0e9db6a1e4b6294df4140 |
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 TYPE_OUTCOUNT
47 integer ,intent(out) :: Status
48 type(wrf_data_handle) ,pointer :: DH
49 integer :: XType
50 integer(KIND=MPI_OFFSET_KIND) :: Len_okind
51 integer :: Len
52 integer :: stat
53 TYPE_BUFFER
55 call GetDH(DataHandle,DH,Status)
56 if(Status /= WRF_NO_ERR) then
57 write(msg,*) &
58 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
59 call wrf_debug ( WARN , msg)
60 return
61 endif
62 ! Do nothing unless it is time to read time-independent domain metadata.
63 IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN
64 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
65 Status = WRF_WARN_FILE_NOT_OPENED
66 write(msg,*) &
67 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
68 call wrf_debug ( WARN , msg)
69 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
70 Status = WRF_WARN_DRYRUN_READ
71 write(msg,*) &
72 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
73 call wrf_debug ( WARN , msg)
74 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
75 Status = WRF_WARN_READ_WONLY_FILE
76 write(msg,*) &
77 'Warning READ WRITE ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
78 call wrf_debug ( WARN , msg)
79 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
80 stat = NFMPI_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len_okind)
81 call netcdf_err(stat,Status)
82 if(Status /= WRF_NO_ERR) then
83 write(msg,*) &
84 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',trim(Element)
85 call wrf_debug ( WARN , msg)
86 return
87 endif
88 Len = Len_okind
89 if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
90 if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
91 Status = WRF_WARN_TYPE_MISMATCH
92 write(msg,*) &
93 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
94 call wrf_debug ( WARN , msg)
95 return
96 endif
97 else
98 if( XType/=NF_TYPE) then
99 Status = WRF_WARN_TYPE_MISMATCH
100 write(msg,*) &
101 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
102 call wrf_debug ( WARN , msg)
103 return
104 endif
105 endif
106 if(Len<=0) then
107 Status = WRF_WARN_LENGTH_LESS_THAN_1
108 write(msg,*) &
109 'Warning LENGTH < 1 in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ', trim(Element)
110 call wrf_debug ( WARN , msg)
111 return
112 endif
113 #ifndef CHAR_TYPE
114 allocate(Buffer(Len), STAT=stat)
115 if(stat/= 0) then
116 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
117 write(msg,*) &
118 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
119 call wrf_debug ( FATAL , msg)
120 return
121 endif
122 stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,Buffer)
123 #else
124 Data = ''
125 stat = NFMPI_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data)
126 #endif
127 call netcdf_err(stat,Status)
128 if(Status /= WRF_NO_ERR) then
129 write(msg,*) &
130 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
131 call wrf_debug ( WARN , msg)
132 return
133 endif
134 #ifndef CHAR_TYPE
135 COPY
136 deallocate(Buffer, STAT=stat)
137 if(stat/= WRF_NO_ERR) then
138 Status = WRF_ERR_FATAL_DEALLOCATION_ERR
139 write(msg,*) &
140 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
141 call wrf_debug ( FATAL , msg)
142 return
143 endif
144 if(Len > Count) then
145 OutCount = Count
146 Status = WRF_WARN_MORE_DATA_IN_FILE
147 else
148 OutCount = Len
149 Status = WRF_NO_ERR
150 endif
151 #endif
152 else
153 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
154 write(msg,*) &
155 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
156 call wrf_debug ( FATAL , msg)
157 endif
158 ENDIF
159 return