| blob | 3214900aade2a7240dd7f1e319051acf4cb99f12 |
1 !*----------------------------------------------------------------------------
2 !*
3 !* WRF ADIOS2 I/O
4 !* Author: Michael Laufer
5 !* Toga Networks, a Huawei Company
6 !* michael.laufer@toganetworks.com
7 !* Author: Erick Fredj
8 !* Computer Science Department, The Jerusalem College of Technology
9 !* fredj@jct.ac.il
10 !* Toga Networks, a Huawei Company
11 !* erick.fredj@toganetworks.com
12 !*
13 !* Date: November 3, 2021
14 !*
15 !*----------------------------------------------------------------------------
17 use wrf_data_adios2
18 use ext_adios2_support_routines
19 use adios2
20 implicit none
21 include 'wrf_status_codes.h'
22 integer ,intent(in) :: DataHandle
23 character*(*) ,intent(in) :: Element
24 character*(*) ,intent(in) :: DateStr
25 character*(*) ,intent(in) :: Var
26 TYPE_COUNT
27 TYPE_DATA
28 integer ,intent(out) :: Status
29 type(wrf_data_handle) ,pointer :: DH
30 character (31) :: VarName
31 character (40+len(Element)) :: Name
32 integer :: stat
33 integer :: stat2
34 integer ,allocatable :: Buffer(:)
35 integer :: i
36 integer :: VDims (1)
37 integer(kind=8) :: VStart(1)
38 integer(kind=8) :: VCount(1)
39 integer :: NVar
40 integer :: TimeIndex
41 integer(kind=8) ,dimension(1) :: zero
42 integer(kind=8) :: shape_dims(1)
43 character(80),dimension(2) :: DimNamesOut
44 type(adios2_attribute) :: AttributeID
46 VarName = Var
47 call DateCheck(DateStr,Status)
48 if(Status /= WRF_NO_ERR) then
49 write(msg,*) &
50 'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
51 call wrf_debug ( WARN , msg)
52 return
53 endif
54 call GetDH(DataHandle,DH,Status)
55 if(Status /= WRF_NO_ERR) then
56 write(msg,*) &
57 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
58 call wrf_debug ( WARN , msg)
59 return
60 endif
61 call GetName(Element, VarName, Name, Status)
62 if(Status /= WRF_NO_ERR) then
63 write(msg,*) &
64 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
65 call wrf_debug ( WARN , msg)
66 return
67 endif
68 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
69 Status = WRF_WARN_FILE_NOT_OPENED
70 write(msg,*) &
71 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
72 call wrf_debug ( WARN , msg)
73 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
74 Status = WRF_WARN_WRITE_RONLY_FILE
75 write(msg,*) &
76 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
77 call wrf_debug ( WARN , msg)
78 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
79 if(LENGTH < 1) then
80 Status = WRF_WARN_ZERO_LENGTH_PUT
81 return
82 endif
83 do NVar=1,MaxVars
84 if(DH%MDVarNames(NVar) == Name) then
85 Status = WRF_WARN_2DRYRUNS_1VARIABLE
86 return
87 elseif(DH%MDVarNames(NVar) == NO_NAME) then
88 DH%MDVarNames(NVar) = Name
89 exit
90 elseif(NVar == MaxVars) then
91 Status = WRF_WARN_TOO_MANY_VARIABLES
92 write(msg,*) &
93 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
94 call wrf_debug ( WARN , msg)
95 return
96 endif
97 enddo
98 do i=1,MaxDims
99 if(DH%DimLengths(i) == LENGTH) then
100 exit
101 elseif(DH%DimLengths(i) == NO_DIM) then
102 call adios2_define_attribute(DH%DimIDs(i), DH%adios2IO, '_DIM_'//DH%DimNames(i), &
103 LENGTH, stat)
104 call adios2_err(stat,Status)
105 if(Status /= WRF_NO_ERR) then
106 write(msg,*) 'adios2 error in ext_adios2_RealFieldIO ',__FILE__,', line', __LINE__
107 call wrf_debug ( WARN , TRIM(msg))
108 return
109 endif
110 DH%DimLengths(i) = LENGTH
111 exit
112 elseif(i == MaxDims) then
113 Status = WRF_WARN_TOO_MANY_DIMS
114 write(msg,*) &
115 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
116 call wrf_debug ( WARN , msg)
117 return
118 endif
119 enddo
120 DH%MDVarDimLens(NVar) = LENGTH
121 DimNamesOut(1) = DH%DimNames(i)
122 DimNamesOut(2) = DH%DimUnlimName
123 zero(1) = 0
124 shape_dims(1) = LENGTH
125 call adios2_define_variable(DH%MDVarIDs(NVar), DH%adios2IO, Name, ADIOS2TYPE, &
126 stat)
127 call adios2_err(stat,Status)
128 if(Status /= WRF_NO_ERR) then
129 write(msg,*) 'adios2 error in ext_adios2_put_var_td ',__FILE__,', line', __LINE__
130 call wrf_debug ( WARN , TRIM(msg))
131 return
132 endif
133 call adios2_define_attribute(AttributeID,DH%adios2IO, 'Dims', &
134 DimNamesOut, 2, DH%MDVarIDs(NVar)%name, '/', stat)
135 call adios2_err(stat,Status)
136 if(Status /= WRF_NO_ERR) then
137 write(msg,*) 'adios2 error in ext_adios2_put_var_td ',__FILE__,', line', __LINE__
138 call wrf_debug ( WARN , TRIM(msg))
139 return
140 endif
141 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
142 do NVar=1,MaxVars
143 if(DH%MDVarNames(NVar) == Name) then
144 exit
145 elseif(DH%MDVarNames(NVar) == NO_NAME) then
146 Status = WRF_WARN_MD_NF
147 write(msg,*) &
148 'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
149 call wrf_debug ( WARN , msg)
150 return
151 elseif(NVar == MaxVars) then
152 Status = WRF_WARN_TOO_MANY_VARIABLES
153 write(msg,*) &
154 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
155 call wrf_debug ( WARN , msg)
156 return
157 endif
158 enddo
159 if(LENGTH > DH%MDVarDimLens(NVar)) then
160 Status = WRF_WARN_COUNT_TOO_LONG
161 write(msg,*) &
162 'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
163 call wrf_debug ( WARN , msg)
164 return
165 elseif(LENGTH < 1) then
166 Status = WRF_WARN_ZERO_LENGTH_PUT
167 write(msg,*) &
168 'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
169 call wrf_debug ( WARN , msg)
170 return
171 endif
172 call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
173 if(Status /= WRF_NO_ERR) then
174 write(msg,*) &
175 'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
176 call wrf_debug ( WARN , msg)
177 return
178 endif
179 VStart(1) = 0 !was 1
180 VCount(1) = LENGTH
181 #ifdef LOG
182 allocate(Buffer(LENGTH), STAT=stat)
183 if(stat/= 0) then
184 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
185 write(msg,*) &
186 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
187 call wrf_debug ( FATAL , msg)
188 return
189 endif
190 do i=1,Count
191 if(data(i)) then
192 Buffer(i)=1
193 else
194 Buffer(i)=0
195 endif
196 enddo
197 call adios2_put(DH%adios2Engine, DH%MDVarIDs(NVar), Buffer, adios2_mode_sync, stat)
198 call adios2_err(stat,Status)
199 if(Status /= WRF_NO_ERR) then
200 write(msg,*) 'adios2 error in ext_adios2_put_var_td ',__FILE__,', line', __LINE__
201 call wrf_debug ( WARN , TRIM(msg))
202 return
203 endif
204 deallocate(Buffer, STAT=stat2)
205 if(stat2/= 0) then
206 Status = WRF_ERR_FATAL_DEALLOCATION_ERR
207 write(msg,*) &
208 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
209 call wrf_debug ( FATAL , msg)
210 return
211 endif
212 #else
213 call adios2_put(DH%adios2Engine, DH%MDVarIDs(NVar), Data, adios2_mode_sync, stat)
214 call adios2_err(stat,Status)
215 if(Status /= WRF_NO_ERR) then
216 write(msg,*) 'adios2 error in ext_adios2_put_var_td ',__FILE__,', line', __LINE__
217 call wrf_debug ( WARN , TRIM(msg))
218 return
219 endif
220 #endif
221 else
222 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
223 write(msg,*) &
224 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
225 call wrf_debug ( FATAL , msg)
226 return
227 endif
228 return