gen_wrf_io.c
References to this file elsewhere.
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4 #include <strings.h>
5
6 #include "protos.h"
7 #include "registry.h"
8 #include "data.h"
9 #include "sym.h"
10
11 static FILE * fp ;
12
13 #define GEN_INPUT 1
14 #define GEN_OUTPUT 2
15
16 #define OP_F(A,B) \
17 fn = B ; \
18 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } \
19 else { sprintf(fname,"%s",fn) ; } \
20 if ((A = fopen( fname , "w" )) == NULL ) return(1) ; \
21 print_warning(A,fname) ; \
22 sym_forget() ;
23
24 int
25 gen_wrf_io ( char * dirname )
26 {
27 char fname[NAMELEN], *fn ;
28
29 if ( dirname == NULL ) return(1) ;
30
31 #if 1
32
33 OP_F(fp,"wrf_metaput_input.inc") ;
34 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
35 METADATA | INPUT , GEN_OUTPUT ) ;
36
37 OP_F(fp,"wrf_metaput_restart.inc") ;
38 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
39 METADATA | RESTART , GEN_OUTPUT ) ;
40
41 OP_F(fp,"wrf_metaput_history.inc") ;
42 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
43 METADATA | HISTORY , GEN_OUTPUT ) ;
44
45 OP_F(fp,"wrf_metaput_boundary.inc") ;
46 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
47 METADATA | BOUNDARY , GEN_OUTPUT ) ;
48
49 OP_F(fp,"wrf_histout.inc") ;
50 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_OUTPUT ) ;
51 close_the_file(fp) ;
52 OP_F(fp,"wrf_auxhist1out.inc") ;
53 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_OUTPUT ) ;
54 close_the_file(fp) ;
55 OP_F(fp,"wrf_auxhist2out.inc") ;
56 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_OUTPUT ) ;
57 close_the_file(fp) ;
58 OP_F(fp,"wrf_auxhist3out.inc") ;
59 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_OUTPUT ) ;
60 close_the_file(fp) ;
61 OP_F(fp,"wrf_auxhist4out.inc") ;
62 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_OUTPUT ) ;
63 close_the_file(fp) ;
64 OP_F(fp,"wrf_auxhist5out.inc") ;
65 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_OUTPUT ) ;
66 close_the_file(fp) ;
67 OP_F(fp,"wrf_auxhist6out.inc") ;
68 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_OUTPUT ) ;
69 close_the_file(fp) ;
70 OP_F(fp,"wrf_auxhist7out.inc") ;
71 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_OUTPUT ) ;
72 close_the_file(fp) ;
73 OP_F(fp,"wrf_auxhist8out.inc") ;
74 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_OUTPUT ) ;
75 close_the_file(fp) ;
76 OP_F(fp,"wrf_auxhist9out.inc") ;
77 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_OUTPUT ) ;
78 close_the_file(fp) ;
79 OP_F(fp,"wrf_auxhist10out.inc") ;
80 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_OUTPUT ) ;
81 close_the_file(fp) ;
82 OP_F(fp,"wrf_auxhist11out.inc") ;
83 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_OUTPUT ) ;
84 close_the_file(fp) ;
85
86 OP_F(fp,"wrf_inputout.inc") ;
87 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_OUTPUT ) ;
88 close_the_file(fp) ;
89 OP_F(fp,"wrf_auxinput1out.inc") ;
90 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_OUTPUT ) ;
91 close_the_file(fp) ;
92 OP_F(fp,"wrf_auxinput2out.inc") ;
93 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_OUTPUT ) ;
94 close_the_file(fp) ;
95 OP_F(fp,"wrf_auxinput3out.inc") ;
96 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_OUTPUT ) ;
97 close_the_file(fp) ;
98 OP_F(fp,"wrf_auxinput4out.inc") ;
99 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_OUTPUT ) ;
100 close_the_file(fp) ;
101 OP_F(fp,"wrf_auxinput5out.inc") ;
102 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_OUTPUT ) ;
103 close_the_file(fp) ;
104 OP_F(fp,"wrf_auxinput6out.inc") ;
105 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_OUTPUT ) ;
106 close_the_file(fp) ;
107 OP_F(fp,"wrf_auxinput7out.inc") ;
108 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_OUTPUT ) ;
109 close_the_file(fp) ;
110 OP_F(fp,"wrf_auxinput8out.inc") ;
111 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_OUTPUT ) ;
112 close_the_file(fp) ;
113 OP_F(fp,"wrf_auxinput9out.inc") ;
114 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_OUTPUT ) ;
115 close_the_file(fp) ;
116 OP_F(fp,"wrf_auxinput10out.inc") ;
117 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_OUTPUT ) ;
118 close_the_file(fp) ;
119 OP_F(fp,"wrf_auxinput11out.inc") ;
120 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_OUTPUT ) ;
121 close_the_file(fp) ;
122 OP_F(fp,"wrf_restartout.inc") ;
123 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_OUTPUT ) ;
124 close_the_file(fp) ;
125 OP_F(fp,"wrf_bdyout.inc") ;
126 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_OUTPUT ) ;
127 close_the_file(fp) ;
128 #endif
129
130 #if 1
131 OP_F(fp,"wrf_metaget_input.inc") ;
132 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
133 METADATA | INPUT , GEN_INPUT ) ;
134
135 OP_F(fp,"wrf_metaget_restart.inc") ;
136 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
137 METADATA | RESTART , GEN_INPUT ) ;
138
139 OP_F(fp,"wrf_metaget_history.inc") ;
140 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
141 METADATA | HISTORY , GEN_INPUT ) ;
142
143 OP_F(fp,"wrf_metaget_boundary.inc") ;
144 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
145 METADATA | BOUNDARY , GEN_INPUT ) ;
146
147 OP_F(fp,"wrf_histin.inc") ;
148 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_INPUT ) ;
149 close_the_file(fp) ;
150 OP_F(fp,"wrf_auxhist1in.inc") ;
151 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_INPUT ) ;
152 close_the_file(fp) ;
153 OP_F(fp,"wrf_auxhist2in.inc") ;
154 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_INPUT ) ;
155 close_the_file(fp) ;
156 OP_F(fp,"wrf_auxhist3in.inc") ;
157 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_INPUT ) ;
158 close_the_file(fp) ;
159 OP_F(fp,"wrf_auxhist4in.inc") ;
160 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_INPUT ) ;
161 close_the_file(fp) ;
162 OP_F(fp,"wrf_auxhist5in.inc") ;
163 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_INPUT ) ;
164 close_the_file(fp) ;
165 OP_F(fp,"wrf_auxhist6in.inc") ;
166 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_INPUT ) ;
167 close_the_file(fp) ;
168 OP_F(fp,"wrf_auxhist7in.inc") ;
169 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_INPUT ) ;
170 close_the_file(fp) ;
171 OP_F(fp,"wrf_auxhist8in.inc") ;
172 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_INPUT ) ;
173 close_the_file(fp) ;
174 OP_F(fp,"wrf_auxhist9in.inc") ;
175 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_INPUT ) ;
176 close_the_file(fp) ;
177 OP_F(fp,"wrf_auxhist10in.inc") ;
178 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_INPUT ) ;
179 close_the_file(fp) ;
180 OP_F(fp,"wrf_auxhist11in.inc") ;
181 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_INPUT ) ;
182 close_the_file(fp) ;
183 OP_F(fp,"wrf_inputin.inc") ;
184 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_INPUT ) ;
185 close_the_file(fp) ;
186 OP_F(fp,"wrf_auxinput1in.inc") ;
187 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_INPUT ) ;
188 close_the_file(fp) ;
189 OP_F(fp,"wrf_auxinput2in.inc") ;
190 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_INPUT ) ;
191 close_the_file(fp) ;
192 OP_F(fp,"wrf_auxinput3in.inc") ;
193 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_INPUT ) ;
194 close_the_file(fp) ;
195 OP_F(fp,"wrf_auxinput4in.inc") ;
196 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_INPUT ) ;
197 close_the_file(fp) ;
198 OP_F(fp,"wrf_auxinput5in.inc") ;
199 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_INPUT ) ;
200 close_the_file(fp) ;
201 OP_F(fp,"wrf_auxinput6in.inc") ;
202 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_INPUT ) ;
203 close_the_file(fp) ;
204 OP_F(fp,"wrf_auxinput7in.inc") ;
205 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_INPUT ) ;
206 close_the_file(fp) ;
207 OP_F(fp,"wrf_auxinput8in.inc") ;
208 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_INPUT ) ;
209 close_the_file(fp) ;
210 OP_F(fp,"wrf_auxinput9in.inc") ;
211 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_INPUT ) ;
212 close_the_file(fp) ;
213 OP_F(fp,"wrf_auxinput10in.inc") ;
214 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_INPUT ) ;
215 close_the_file(fp) ;
216 OP_F(fp,"wrf_auxinput11in.inc") ;
217 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_INPUT ) ;
218 close_the_file(fp) ;
219 OP_F(fp,"wrf_restartin.inc") ;
220 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_INPUT ) ;
221 close_the_file(fp) ;
222 OP_F(fp,"wrf_bdyin.inc") ;
223 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_INPUT ) ;
224 close_the_file(fp) ;
225 #endif
226
227 return(0) ;
228 }
229
230 static int
231 set_dim_strs_x ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag, int sw_reorder )
232 {
233 int i, j, ii ;
234 node_t *p ;
235 char d, d1 ;
236 char * stag ;
237 char r1[NAMELEN] ;
238
239 strcpy(r1,"grid%") ;
240 if ( node == NULL ) return(1) ;
241 for ( i = 0 ; i < 3 ; i++ )
242 for ( j = 0 ; j < 2 ; j++ )
243 {
244 strcpy(ddim[i][j],"1") ;
245 strcpy(mdim[i][j],"1") ;
246 strcpy(pdim[i][j],"1") ;
247 }
248
249 for ( ii = 0 ; ii < node->ndims ; ii++ )
250 {
251 p = node->dims[ii] ;
252 if ( sw_reorder ) {
253 i = ii ;
254 } else {
255 switch( p->coord_axis )
256 {
257 case(COORD_X) : i = 0 ; break ;
258 case(COORD_Y) : i = 2 ; break ;
259 case(COORD_Z) : i = 1 ; break ;
260 default : break ;
261 }
262 }
263 if ( p->len_defined_how == DOMAIN_STANDARD )
264 {
265 if ( p->subgrid ) {
266 switch( p->coord_axis )
267 {
268 case(COORD_X) : d = 'i' ; d1 = 'x' ; break ;
269 case(COORD_Y) : d = 'j' ; d1 = 'y' ; break ;
270 case(COORD_Z) : d = 'k' ; d1 = 'z' ; break ;
271 default : break ;
272 }
273
274 sprintf(ddim[i][0],"%s%cds",prepend,d) ;
275 sprintf(ddim[i][1],"%s%cde * %ssr_%c ",prepend,d,r1,d1) ;
276 sprintf(mdim[i][0],"(%s%cms-1)*%ssr_%c+1",prepend,d,r1,d1) ;
277 sprintf(mdim[i][1],"%s%cme*%ssr_%c",prepend,d,r1,d1) ;
278 sprintf(pdim[i][0],"(%s%cps-1)*%ssr_%c+1",prepend,d,r1,d1) ;
279 sprintf(pdim[i][1],"%s%cpe*%ssr_%c",prepend,d,r1,d1) ;
280
281 } else {
282 if ( sw_3dvar_iry_kludge ) {
283 switch( p->coord_axis )
284 {
285 /* vvv */
286 case(COORD_X) : d = 'i' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
287 case(COORD_Y) : d = 'j' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
288 /* ^^^ */
289 case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
290 default : stag = "1" ; break ;
291 }
292 } else {
293 switch( p->coord_axis )
294 {
295 case(COORD_X) : d = 'i' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
296 case(COORD_Y) : d = 'j' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
297 case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
298 default : stag = "1" ; break ;
299 }
300 }
301
302 sprintf(ddim[i][0],"%s%cds",prepend,d) ;
303 sprintf(ddim[i][1],stag,prepend,d) ; /* note that stag has printf format info in it */
304 sprintf(mdim[i][0],"%s%cms",prepend,d) ;
305 sprintf(mdim[i][1],"%s%cme",prepend,d) ;
306 sprintf(pdim[i][0],"%s%cps",prepend,d) ;
307 if ( ! sw_disregard_stag )
308 sprintf(pdim[i][1],"MIN( %s, %s%cpe )",ddim[i][1],prepend,d) ;
309 else
310 sprintf(pdim[i][1],"%s%cpe",prepend,d) ;
311 }
312 }
313 else if ( p->len_defined_how == NAMELIST )
314 {
315 if ( !strcmp( p->assoc_nl_var_s, "1" ) )
316 {
317 sprintf(ddim[i][0],"1") ;
318 sprintf(mdim[i][0],"1") ;
319 sprintf(pdim[i][0],"1") ;
320 }
321 else
322 {
323 sprintf(ddim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
324 sprintf(mdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
325 sprintf(pdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
326 }
327 sprintf(ddim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
328 sprintf(mdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
329 sprintf(pdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
330 }
331 else if ( p->len_defined_how == CONSTANT )
332 {
333 sprintf(ddim[i][0],"%d",p->coord_start ) ;
334 sprintf(ddim[i][1],"%d",p->coord_end ) ;
335 sprintf(mdim[i][0],"%d",p->coord_start ) ;
336 sprintf(mdim[i][1],"%d",p->coord_end ) ;
337 sprintf(pdim[i][0],"%d",p->coord_start ) ;
338 sprintf(pdim[i][1],"%d",p->coord_end ) ;
339 }
340 }
341 return(0) ;
342 }
343
344
345 int
346 set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag )
347 {
348 set_dim_strs_x ( node , ddim, mdim, pdim, prepend , sw_disregard_stag, 1 ) ; /* 1 = reorder according to strg order */
349 }
350
351 /* version that doesn't permute according to index order -- always i, k, then j
352 useful for standard argument lists -- e.g. calls to interp in nesting */
353 int
354 set_dim_strs2 ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag )
355 {
356 set_dim_strs_x ( node , ddim, mdim, pdim, prepend , sw_disregard_stag, 0 ) ; /* 0 = reorder according to strg order */
357 }
358
359 int
360 gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int io_mask , int sw_io )
361 {
362 node_t * p ;
363 int i , ii ;
364 char x[NAMELEN], tag[NAMELEN], dexes[NAMELEN] ;
365 char dname[NAMELEN], dname_tmp[NAMELEN] ;
366 char vname[NAMELEN], vname_x[NAMELEN],vname_1[NAMELEN], vname_2[NAMELEN], memord[NAMELEN] ;
367 char ddim[3][2][NAMELEN] ;
368 char mdim[3][2][NAMELEN] ;
369 char pdim[3][2][NAMELEN] ;
370 char ddim_no[3][2][NAMELEN] ;
371 char mdim_no[3][2][NAMELEN] ;
372 char pdim_no[3][2][NAMELEN] ;
373 char dimname[3][NAMELEN] ;
374 char core[NAMELEN] ;
375 char stagstr[NAMELEN] ;
376 char * tend_tag ;
377
378 char post[NAMELEN] ;
379 char indices[NAMELEN] ;
380
381 int pass, passes, stagx, stagy, stagz ;
382 int xi, yi, zi ;
383 node_t * dimnode ;
384 int ok_to_collect_distribute ;
385
386 /* set a flag according to what the stream is, if we're running on dm processors, if the
387 io layer cannot handle distributed data, and if we're selectively turning off the
388 collect/distribute message passing so that history and restart I/O is to separate files
389 but input and boundary I/O is unaffected */
390
391 ok_to_collect_distribute = !sw_distrib_io_layer &&
392 sw_dm_parallel &&
393 !(sw_dm_serial_in_only && ((io_mask&HISTORY) ||
394 (io_mask&AUXHIST1) ||
395 (io_mask&AUXHIST2) ||
396 (io_mask&AUXHIST3) ||
397 (io_mask&AUXHIST4) ||
398 (io_mask&AUXHIST5) ||
399 (io_mask&AUXHIST6) ||
400 (io_mask&AUXHIST7) ||
401 (io_mask&AUXHIST8) ||
402 (io_mask&AUXHIST9) ||
403 (io_mask&AUXHIST10) ||
404 (io_mask&AUXHIST11) ||
405 (io_mask&RESTART))) ;
406
407 if ( node == NULL ) return(1) ;
408 if ( structname == NULL ) return(1) ;
409 if ( fp == NULL ) return(1) ;
410
411 for ( p = node ; p != NULL ; p = p->next )
412 {
413
414 if ( p->ndims > 3 ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */
415
416 if ( p->node_kind & I1 ) continue ; /* short circuit anything that's not a state var */
417
418 set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */
419 set_dim_strs( p, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */
420
421 strcpy(stagstr, "") ;
422 if ( p->stag_x ) strcat(stagstr, "X") ;
423 if ( p->stag_y ) strcat(stagstr, "Y") ;
424 if ( p->stag_z ) strcat(stagstr, "Z") ;
425
426 if ( !strcmp(p->name,"-") ) continue ;
427
428 if ( p->node_kind & FOURD )
429 {
430 node_t * nd , *pp ;
431 char p1[NAMELEN], sv[NAMELEN], tl[25] ;
432
433 set_dim_strs( p->members, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */
434 set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */
435
436 if ( ! ( io_mask & BOUNDARY ) )
437 {
438 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
439 fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
440 #if DA_CORE==1
441 fprintf(fp," IF (.not. ((%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM_TL) .or. &\n",p->name);
442 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM) .or. &\n",p->name);
443 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'G_' .and. grid%%dyn_opt == DYN_EM))) THEN\n" ,p->name);
444 #endif
445 fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
446 fprintf(fp," fid , & ! DataHandle\n") ;
447 fprintf(fp," current_date(1:19) , & ! DateStr\n") ;
448 fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ;
449 strcpy( tl, "" ) ;
450 if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ;
451 if ( ok_to_collect_distribute ) {
452 fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ;
453 } else {
454 #if DA_CORE==1
455 fprintf(fp," grid%%%s%s(ims,jms,kms,itrace) , & ! Field\n",p->name,tl) ;
456 #else
457 fprintf(fp," grid%%%s%s(ims,kms,jms,itrace) , & ! Field\n",p->name,tl) ;
458 #endif
459 }
460 if (!strncmp(p->members->type->name,"real",4)) {
461 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
462 } else {
463 fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ;
464 }
465 fprintf(fp," grid%%communicator , & ! Comm\n") ;
466 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
467 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
468 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
469 if ( sw_io == GEN_OUTPUT ) {
470 fprintf(fp," dryrun , & ! flag\n") ;
471 }
472 set_mem_order( p->members, memord , NAMELEN) ;
473 #if DA_CORE==1
474 fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ;
475 #else
476 fprintf(fp," 'XZY' , & ! MemoryOrder\n") ;
477 #endif
478 strcpy(stagstr, "") ;
479 if ( p->members->stag_x ) strcat(stagstr, "X") ;
480 if ( p->members->stag_y ) strcat(stagstr, "Y") ;
481 if ( p->members->stag_z ) strcat(stagstr, "Z") ;
482 fprintf(fp," '%s' , & ! Stagger\n",stagstr) ;
483 if ( sw_io == GEN_OUTPUT ) {
484 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
485 for ( i = 0 ; i < 3 ; i++ )
486 {
487 if (( dimnode = p->members->dims[i]) != NULL )
488 {
489 switch ( dimnode->coord_axis )
490 {
491 case (COORD_X) :
492 if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) )
493 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
494 else
495 { strcpy( dimname[i], dimnode->dim_data_name) ; }
496 break ;
497 case (COORD_Y) :
498 if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) )
499 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
500 else
501 { strcpy( dimname[i], dimnode->dim_data_name) ; }
502 break ;
503 case (COORD_Z) :
504 if ( p->members->stag_z )
505 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
506 else
507 { strcpy( dimname[i], dimnode->dim_data_name) ; }
508 break ;
509 }
510 }
511 }
512 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
513 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
514 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
515 fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ;
516 fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ;
517 }
518 #if DA_CORE==1
519 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name, memord ) ;
520 #else
521 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ;
522 #endif
523 /* global dimensions */
524 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
525 fprintf(fp," & \n") ;
526 /* mem dimensions */
527 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
528 fprintf(fp," & \n") ;
529 /* patch dimensions */
530 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
531 fprintf(fp," & \n") ;
532 fprintf(fp," ierr )\n" ) ;
533 #if DA_CORE==1
534 fprintf(fp, " ENDIF\n" ) ;
535 #endif
536 fprintf(fp, " ENDIF\n" ) ;
537 fprintf(fp, "ENDDO\n") ;
538 }
539 /* BOUNDARY FOR 4-D TRACER */
540 else if ( io_mask & BOUNDARY )
541 {
542 int ibdy ;
543 int idx ;
544 node_t *fourd_bound_array ;
545 char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ;
546 char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
547
548 /* check for the existence of a fourd boundary array */
549 sprintf(fourd_bnd,"%s_b",p->name) ;
550 if (( fourd_bound_array = get_entry( fourd_bnd ,Domain.fields)) != NULL ) {
551
552 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
553 strcpy( dimname[2] , "bdy_width" ) ;
554 ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
555 ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
556 ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
557 if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
558 { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
559 else { strcpy( dimname[1], dimnode->dim_data_name) ; }
560 if ( p->stag_z ) { zdomainend = "kde" ; }
561 else { zdomainend = "(kde-1)" ; }
562 ds2 = "kds" ; de2 = zdomainend ;
563 ms2 = "kds" ; me2 = "kde" ; /* 20020924 */
564 ps2 = "kds" ; pe2 = zdomainend ;
565 }
566 else
567 {
568 fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ;
569 }
570 for ( pass = 0 ; pass < 2 ; pass++ ) {
571 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
572 fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
573 #if DA_CORE==1
574 fprintf(fp," IF (.not. ((%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM_TL) .or. &\n",p->name);
575 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM) .or. &\n",p->name);
576 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'G_' .and. grid%%dyn_opt == DYN_EM))) THEN\n" ,p->name);
577 #endif
578 for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
579 {
580 if ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ; /* west bdy */
581 } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ; /* east bdy */
582 } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ; /* south bdy */
583 } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ; /* north bdy */
584 } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ; /* west bdy */
585 } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ; /* east bdy */
586 } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ; /* south bdy */
587 } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ; /* north bdy */
588 }
589 if ( ibdy == 1 || ibdy == 2 ) {
590 if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
591 {
592 idx = get_index_for_coord( p , COORD_Y ) ;
593 if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
594 ds1 = "1" ; de1 = ydomainend ;
595 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
596 if ( sw_new_bdys ) { /* 20070207 */
597 if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
598 if ( sw_io == GEN_INPUT ) {
599 ps1 = "MAX(jms,jds)" ;
600 sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
601 } else if ( sw_io == GEN_OUTPUT ) {
602 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
603 }
604 } else {
605 if ( sw_io == GEN_INPUT ) {
606 ps1 = "1" ; pe1 = ydomainend ;
607 } else if ( sw_io == GEN_OUTPUT ) {
608 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
609 }
610 }
611 if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
612 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
613 }
614 }
615 if ( ibdy == 3 || ibdy == 4 ) {
616 if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
617 {
618 idx = get_index_for_coord( p , COORD_X ) ;
619 if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
620 ds1 = "1" ; de1 = xdomainend ;
621 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
622 if ( sw_new_bdys ) { /* 20070207 */
623 if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
624 if ( sw_io == GEN_INPUT ) {
625 ps1 = "MAX(ims,ids)" ;
626 sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
627 } else if ( sw_io == GEN_OUTPUT ) {
628 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
629 }
630 } else {
631 if ( sw_io == GEN_INPUT ) {
632 ps1 = "1" ; pe1 = xdomainend ;
633 } else if ( sw_io == GEN_OUTPUT ) {
634 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
635 }
636 }
637 if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
638 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
639 }
640 }
641 if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ;
642 else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ;
643 else sprintf(memord,"0") ;
644 fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
645 fprintf(fp," fid , & ! DataHandle\n") ;
646 fprintf(fp," current_date(1:19) , & ! DateStr\n") ;
647 fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ;
648 if ( ok_to_collect_distribute ) {
649 fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ;
650 } else {
651 strcpy(bdytag2,"") ;
652 strncat(bdytag2,bdytag, pass+2) ;
653 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
654 fprintf(fp," grid%%%s%s(%s,kds,1,itrace) , & ! Field\n",p->name,bdytag, ms1) ;
655 } else {
656 fprintf(fp," grid%%%s%s(1,kds,1,%d,itrace) , & ! Field\n",p->name,bdytag2, ibdy) ;
657 }
658 }
659 if (!strncmp(p->members->type->name,"real",4)) {
660 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
661 } else {
662 fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ;
663 }
664 fprintf(fp," grid%%communicator , & ! Comm\n") ;
665 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
666 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
667 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
668 if ( sw_io == GEN_OUTPUT ) {
669 fprintf(fp," dryrun , & ! flag\n") ;
670 }
671 fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ;
672 strcpy(stagstr, "") ;
673 if ( p->members->stag_x ) strcat(stagstr, "X") ;
674 if ( p->members->stag_y ) strcat(stagstr, "Y") ;
675 if ( p->members->stag_z ) strcat(stagstr, "Z") ;
676 fprintf(fp," '%s' , & ! Stagger\n",stagstr) ;
677 if ( sw_io == GEN_OUTPUT ) {
678 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
679 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
680 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
681 fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ;
682 fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ;
683 }
684 #if DA_CORE==1
685 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name, memord ) ;
686 #else
687 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ;
688 #endif
689 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
690 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
691 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
692 fprintf(fp," ierr )\n" ) ;
693 }
694 #if DA_CORE==1
695 fprintf(fp, " ENDIF\n" ) ;
696 #endif
697 fprintf(fp, " ENDIF\n" ) ;
698 fprintf(fp, "ENDDO\n") ;
699 }
700 }
701 } /* if fourd bound array associated with this tracer */
702 }
703 else if ( p->type != NULL )
704 {
705
706 if ( p->type->type == SIMPLE )
707 {
708
709 /* //////// BOUNDARY ///////////////////// */
710
711 if ( p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA )
712 && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) )
713 {
714 int ibdy ;
715 int idx ;
716 char *bdytag, *xdomainend, *ydomainend, *zdomainend ;
717 char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
718 char t1[64], t2[64] ;
719
720 if (!strncmp( p->use, "dyn_", 4))
721 sprintf(core,"%s_",p->use+4) ;
722 else
723 strcpy(core,"") ;
724
725 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
726 strcpy( dimname[2] , "bdy_width" ) ;
727 ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
728 ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
729 ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
730
731 if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
732 { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
733 else { strcpy( dimname[1], dimnode->dim_data_name) ; }
734 if ( p->stag_z ) { zdomainend = "kde" ; }
735 else { zdomainend = "(kde-1)" ; }
736 ds2 = "kds" ; de2 = zdomainend ;
737 ms2 = "kds" ; me2 = "kde" ; /* 20020924 */
738 ps2 = "kds" ; pe2 = zdomainend ;
739 }
740 else
741 { strcpy(dimname[1],dimname[2]) ;
742 strcpy(dimname[2],"one_element") ;
743 ds2 = ds3 ; de2 = de3 ;
744 ms2 = ms3 ; me2 = me3 ;
745 ps2 = ps3 ; pe2 = pe3 ;
746 ds3 = "1" ; de3 = "1" ;
747 ms3 = "1" ; me3 = "1" ;
748 ps3 = "1" ; pe3 = "1" ;
749 }
750
751 if ( strlen(p->dname) < 1 ) {
752 fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ;
753 }
754
755 for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
756 {
757 if ( ibdy == 1 ) { bdytag = "XS" ; /* west bdy */
758 } else if ( ibdy == 2 ) { bdytag = "XE" ; /* east bdy */
759 } else if ( ibdy == 3 ) { bdytag = "YS" ; /* south bdy */
760 } else if ( ibdy == 4 ) { bdytag = "YE" ; /* north bdy */
761 }
762 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag) ; }
763 else { sprintf(dname,"%s%s",p->dname,bdytag) ; }
764
765 make_upper_case(dname) ;
766
767 if ( ibdy == 1 || ibdy == 2 ) {
768 if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
769 {
770 idx = get_index_for_coord( p , COORD_Y ) ;
771 if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
772 ds1 = "1" ; de1 = ydomainend ;
773 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
774 if ( sw_new_bdys ) { /* 20070207 */
775 if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
776 if ( sw_io == GEN_INPUT ) {
777 ps1 = "MAX(jms,jds)" ;
778 sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
779 } else if ( sw_io == GEN_OUTPUT ) {
780 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
781 }
782 } else {
783 if ( sw_io == GEN_INPUT ) {
784 ps1 = "1" ; pe1 = ydomainend ;
785 } else if ( sw_io == GEN_OUTPUT ) {
786 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
787 }
788 }
789 if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
790 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
791 }
792 }
793 if ( ibdy == 3 || ibdy == 4 ) {
794 if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
795 {
796 idx = get_index_for_coord( p , COORD_X ) ;
797 if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
798 ds1 = "1" ; de1 = xdomainend ;
799 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
800 if ( sw_new_bdys ) { /* 20070207 */
801 if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
802 if ( sw_io == GEN_INPUT ) {
803 ps1 = "MAX(ims,ids)" ;
804 sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
805 } else if ( sw_io == GEN_OUTPUT ) {
806 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
807 }
808 } else {
809 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
810 if ( sw_io == GEN_INPUT ) {
811 ps1 = "1" ; pe1 = xdomainend ;
812 } else if ( sw_io == GEN_OUTPUT ) {
813 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
814 }
815 }
816 if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
817 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
818 }
819 }
820 if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ;
821 else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ;
822 else sprintf(memord,"0") ;
823
824 passes = 1 ;
825 if ( fourdname != NULL ) passes = 2 ;
826 for ( pass = 0 ; pass < passes ; pass++ ) {
827 tend_tag = ( pass == 0 ) ? "_B" : "_BT" ;
828 if ( sw_io == GEN_INPUT )
829 {
830 if ( !strncmp( p->use, "dyn_", 4 ) )
831 #if DA_CORE==1
832 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
833 if ( !strncmp(dname, "A_", 2) ) {
834 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
835 }
836 else if ( !strncmp(dname, "G_", 2) ) {
837 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
838 }
839 #else
840 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
841 #endif
842 if ( ok_to_collect_distribute )
843 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
844 fprintf(fp,"CALL wrf_ext_read_field ( &\n") ;
845 fprintf(fp," fid , & ! DataHandle \n" ) ;
846 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
847 if ( fourdname == NULL ) {
848 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
849 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
850 fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ;
851 } else {
852 fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ;
853 }
854 } else {
855 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; }
856 else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
857 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
858 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
859 fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" ,
860 structname , core , fourdname, tend_tag, bdy_indicator(ibdy), ms1, p->name ) ;
861 } else {
862 fprintf(fp," %s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" ,
863 structname , core , fourdname, tend_tag, ibdy, p->name ) ;
864 }
865 }
866 if (!strncmp(p->type->name,"real",4)) {
867 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
868 } else {
869 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
870 }
871 fprintf(fp," grid%%communicator , & ! Comm\n") ;
872 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
873 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
874 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ;
875 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
876 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
877 fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
878 /* global dimensions */
879 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
880 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
881 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
882 fprintf(fp," ierr )\n") ;
883 if ( ok_to_collect_distribute )
884 {
885 fprintf(fp,"ENDIF\n") ;
886 fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , core , p->name, ibdy) ;
887 fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1) )\n",me1,ms1,me2,ms2,me3,ms3) ;
888 }
889 #if DA_CORE==1
890 if ( !strncmp(dname, "A_", 2) ) {
891 fprintf(fp,"END IF\n") ;
892 }
893 else if ( !strncmp(dname, "G_", 2) ) {
894 fprintf(fp,"END IF\n") ;
895 }
896 #endif
897 if ( !strncmp( p->use, "dyn_", 4 ) )
898 fprintf(fp,"END IF\n" ) ;
899 }
900 else if ( sw_io == GEN_OUTPUT )
901 {
902 if ( ok_to_collect_distribute )
903 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
904 if ( !strncmp( p->use, "dyn_", 4 ) )
905 #if DA_CORE==1
906 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
907 if ( !strncmp(dname, "A_", 2) ) {
908 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
909 }
910 else if ( !strncmp(dname, "G_", 2) ) {
911 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
912 }
913 #else
914 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
915 #endif
916 fprintf(fp,"CALL wrf_ext_write_field ( &\n") ;
917 fprintf(fp," fid , & ! DataHandle \n" ) ;
918 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
919 if ( fourdname == NULL ) {
920 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
921 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
922 fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ;
923 } else {
924 fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ;
925 }
926 } else {
927 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; }
928 else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
929 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
930 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
931 fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" ,
932 structname , core , fourdname, tend_tag, ms1, bdy_indicator(ibdy), p->name ) ;
933 } else {
934 fprintf(fp," %s%s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" ,
935 structname , core , fourdname, tend_tag, ibdy, bdy_indicator(ibdy), p->name ) ;
936 }
937 }
938 if (!strncmp(p->type->name,"real",4)) {
939 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
940 } else {
941 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
942 }
943 fprintf(fp," grid%%communicator , & ! Comm\n") ;
944 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
945 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
946 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ;
947 fprintf(fp," dryrun , & ! flag\n" ) ;
948 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
949 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
950 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
951 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
952 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
953 fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ;
954 fprintf(fp," '%s' , & ! Units \n",p->units ) ;
955 fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
956 /* global dimensions */
957 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
958 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
959 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
960 fprintf(fp," ierr )\n") ;
961 #if DA_CORE==1
962 if ( !strncmp(dname, "A_", 2) ) {
963 fprintf(fp,"END IF\n") ;
964 }
965 else if ( !strncmp(dname, "G_", 2) ) {
966 fprintf(fp,"END IF\n") ;
967 }
968 #endif
969 if ( !strncmp( p->use, "dyn_", 4 ) )
970 fprintf(fp,"END IF\n" ) ;
971 if ( ok_to_collect_distribute )
972 fprintf(fp,"ENDIF\n") ;
973 }
974 }
975 }
976 }
977
978 /* //////// NOT BOUNDARY ///////////////////// */
979 else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY))
980 {
981
982 /* Aug 2004
983
984 Namelist variables
985
986 The i r and h settings will be reenabled but it will work a little
987 differently than i/o of regular state variables:
988
989 1) rather than being read or written as records to the dataset, they
990 will be gotten or put as time invariant meta data; in other words, they
991 will only be written once when the dataset is created as the other
992 metadata is now. This has the benefit of reducing the amount of I/O
993 traffic on each write (I can't remember, but that may be why the
994 reading and writing of rconfig data was turned off in the first
995 place).
996
997 2) All the rconfig variables will be gotten/put as metadata to input,
998 restart, history, and boundary datasets, regardless of what the 'i',
999 'r', and 'h' settings are. Instead those settings will control the
1000 behavior with respect to the input-from-namelist vs input-from-dataset
1001 precedence issue that Bill raised.
1002
1003 In other words, if an rconfig entry has an 'i', 'r', or 'h' in the
1004 Registry, the dataset value takes precedence over the namelist value.
1005 Otherwise, say it is missing the 'i', the reconfig variable's value
1006 still appears as metadata in the dataset but the value of the variable
1007 in the program does not change as a result of inputting the dataset.
1008
1009 */
1010
1011 if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) )
1012 {
1013 char c ;
1014 char dname[NAMELEN] ;
1015
1016 strcpy( dname, p->dname ) ;
1017 make_upper_case( dname ) ;
1018 if ( !strcmp( p->type->name , "integer" ) ) { c = 'i' ; }
1019 else if ( !strcmp( p->type->name , "real" ) ) { c = 'r' ; }
1020 else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; }
1021 else if ( !strcmp( p->type->name , "logical" ) ) { c = 'l' ; }
1022 else {
1023 fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ;
1024 }
1025 if ( sw_io == GEN_OUTPUT ) {
1026 if ( io_mask & p->io_mask ) {
1027 fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
1028 fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
1029 }
1030 } else {
1031 if ( io_mask & p->io_mask ) {
1032 fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
1033 fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ;
1034 fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ;
1035 fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
1036 }
1037 }
1038 }
1039 /* end Aug 2004 */
1040 #if 0
1041 else if ( ! (io_mask & METADATA) ) /* state vars */
1042 #else
1043 else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) ) /* state vars */
1044 #endif
1045 {
1046 if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ;
1047 else passes = 1 ;
1048
1049 for ( pass = 0 ; pass < passes ; pass++ ) /* for multi timelevel vars */
1050 {
1051 if (!strncmp( p->use, "dyn_", 4))
1052 sprintf(core,"%s_",p->use+4) ;
1053 else
1054 strcpy(core,"") ;
1055
1056 /* for multi time level variables gen read for both levels
1057 for restart, only _2 for others */
1058 if ( p->ntl > 1 ) {
1059 if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ;
1060 else sprintf(tag,"_%d",p->ntl) ;
1061 }
1062 else sprintf(tag,"") ;
1063
1064 /* construct variable name */
1065 if ( p->scalar_array_member )
1066 {
1067 strcpy(dexes,"") ;
1068 for (ii = 0; ii < p->ndims; ii++ )
1069 {
1070 switch(p->dims[ii]->coord_axis)
1071 {
1072 case(COORD_X): strcat(dexes,"ims,") ; break ;
1073 case(COORD_Y): strcat(dexes,"jms,") ; break ;
1074 case(COORD_Z): strcat(dexes,"kms,") ; break ;
1075 default : break ;
1076 }
1077 }
1078 sprintf(vname,"%s%s%s(%sP_%s)",core,p->use,tag,dexes,p->name) ;
1079 sprintf(vname_2,"%s%s%s(%sP_%s)",core,p->use,"_2",":,:,:,",p->name) ;
1080 sprintf(vname_1,"%s%s%s(%sP_%s)",core,p->use,"_1",":,:,:,",p->name) ;
1081 sprintf(vname_x,"%s%s%s(%sP_%s)",core,p->use,tag,":,:,:,",p->name) ;
1082 }
1083 else
1084 {
1085 sprintf(vname,"%s%s%s",core,p->name,tag) ;
1086 sprintf(vname_x,"%s%s%s",core,p->name,tag) ;
1087 sprintf(vname_1,"%s%s%s",core,p->name,"_1") ;
1088 sprintf(vname_2,"%s%s%s",core,p->name,"_2") ;
1089 }
1090
1091
1092 /* construct data name -- maybe same as vname if dname not spec'd */
1093 if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; }
1094 else { strcpy(dname_tmp,p->dname) ; }
1095 make_upper_case(dname_tmp) ;
1096
1097 /*
1098 July 2004
1099
1100 New code to generate error if input or output for two state variables would be generated with the same dataname
1101
1102 example okay:
1103 dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB
1104 dyn_em soiltb "SOILTB" -> dyn_em_tg,SOILTB
1105 example wrong:
1106 dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB
1107 misc soiltb "SOILTB" -> gen_soiltb,SOILTB
1108 example wrong:
1109 misc tg "SOILTB" -> gen_tg,SOILTB
1110 misc soiltb "SOILTB" -> gen_soiltb,SOILTB
1111
1112 */
1113 if ( pass == 0 )
1114 {
1115 char dname_symbol[128] ;
1116 sym_nodeptr sym_node ;
1117
1118 sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
1119 /* check and see if it is in the symbol table already */
1120
1121 if ((sym_node = sym_get( dname_symbol )) == NULL ) {
1122 /* add it */
1123 sym_node = sym_add ( dname_symbol ) ;
1124 strcpy( sym_node->internal_name , p->name ) ;
1125 strcpy( sym_node->core_name , core ) ;
1126 } else {
1127 /* it's there already, check and make sure we don't have an error condition */
1128 if ( (strlen(core) > 0 && strlen( sym_node->core_name ) > 0 && !strcmp( core, sym_node->core_name ))
1129 || strlen(core) == 0
1130 || strlen( sym_node->core_name ) == 0 )
1131 {
1132 char this_core[64] , sym_core[64] ;
1133 strcpy(this_core,"(generic)") ;
1134 if ( strlen(core) > 0 ) sprintf(this_core,"(%s)",core) ;
1135 strcpy(sym_core,"(generic)") ;
1136 if ( strlen(sym_node->core_name) > 0 ) sprintf(this_core,"(%s)",sym_node->core_name) ;
1137 fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s %s and %s %s\n",
1138 dname_tmp,p->name,this_core,sym_node->internal_name,sym_core ) ;
1139 }
1140 }
1141 }
1142 /* end July 2004 */
1143
1144 if ( io_mask & RESTART && p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ;
1145 else strcpy(dname,dname_tmp) ;
1146
1147 set_mem_order( p, memord , NAMELEN) ;
1148
1149 /* kludge for WRF 3DVAR I/O with MM5 analysis kernel */
1150 if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ;
1151 if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ;
1152
1153 if ( strlen(dname) < 1 ) {
1154 fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ;
1155 }
1156 if ( p->io_mask & io_mask && sw_io == GEN_INPUT )
1157 {
1158 if ( !strncmp( p->use, "dyn_", 4 ) )
1159 #if DA_CORE==1
1160 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
1161 if ( !strncmp(dname, "A_", 2) ) {
1162 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1163 }
1164 else if ( !strncmp(dname, "G_", 2) ) {
1165 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1166 }
1167 #else
1168 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
1169 #endif
1170 if ( p->scalar_array_member )
1171 fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1172 if ( ok_to_collect_distribute )
1173 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1174
1175 strcpy(indices,"") ;
1176 sprintf(post,")") ;
1177 if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */
1178 {
1179 sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1180 }
1181
1182 fprintf(fp,"CALL wrf_ext_read_field ( &\n") ;
1183 fprintf(fp," fid , & ! DataHandle \n" ) ;
1184 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
1185 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
1186 if ( p->ndims >= 2 && ok_to_collect_distribute )
1187 fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ;
1188 else
1189 fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices) ;
1190
1191 if (!strncmp(p->type->name,"real",4)) {
1192 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
1193 } else {
1194 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
1195 }
1196
1197 fprintf(fp," grid%%communicator , & ! Comm\n") ;
1198 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
1199 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
1200 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
1201 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
1202 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
1203 fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1204 /* global dimensions */
1205 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1206 fprintf(fp," & \n") ;
1207
1208 /* the first two cases here have to do with if we're running on multiple distributed
1209 memory processors and the i/o api layer can't handle decomposed data. So code is
1210 generated to read the data on processor zero into a globally sized buffer. In this
1211 case, then the domain, memory, and patch dimensions for the globally sized buffer
1212 are all just the domain dimensions. Two D arrays are handled separately
1213 from three-d arrays because in threeD arrays the middle index is K. In the last
1214 case, where the code is either calling a version of the API that supports parallelism
1215 or we aren't running in DM-parallel, the field itself and not a global buffer are
1216 passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1217
1218 if ( p->ndims == 3 && ok_to_collect_distribute )
1219 {
1220 /* mem dimensions are actually domain dimensions */
1221 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1222 fprintf(fp," & \n") ;
1223 /* patch dimensions are actually domain dimensions */
1224 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim [i][0], ddim [i][1]) ; }
1225 fprintf(fp," & \n") ;
1226 }
1227 else if ( p->ndims == 2 && ok_to_collect_distribute )
1228 {
1229 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1230 {
1231 /* mem dimensions are actually domain dimensions */
1232 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1233 ddim_no[yi][0],ddim_no[yi][1] ) ;
1234 /* patch dimensions are actually domain dimensions */
1235 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim [xi][0],ddim [xi][1],
1236 ddim [yi][0],ddim [yi][1] ) ;
1237 }
1238 }
1239 else
1240 {
1241 /* mem dimensions */
1242 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1243 fprintf(fp," & \n") ;
1244 /* patch dimensions */
1245 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1246 fprintf(fp," & \n") ;
1247 }
1248 fprintf(fp," ierr )\n") ;
1249
1250 if ( ok_to_collect_distribute )
1251 fprintf(fp,"END IF\n" ) ;
1252
1253 /* In case we have read into a global buffer, generate code to distribute the data just read in */
1254 if ( p->ndims == 3 && ok_to_collect_distribute )
1255 {
1256 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0)
1257 {
1258 fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1259 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1260 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1261 ddim_no[yi][0],ddim_no[yi][1],
1262 ddim_no[zi][0],ddim_no[zi][1]) ;
1263 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1264 mdim_no[yi][0],mdim_no[yi][1],
1265 mdim_no[zi][0],mdim_no[zi][1]) ;
1266 fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1],
1267 pdim_no[yi][0],pdim_no[yi][1],
1268 pdim_no[zi][0],pdim_no[zi][1]) ;
1269 }
1270 }
1271 else if ( p->ndims == 2 && ok_to_collect_distribute )
1272 {
1273 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1274 {
1275 fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1276 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1277 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1278 ddim_no[yi][0],ddim_no[yi][1] ) ;
1279 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1280 mdim_no[yi][0],mdim_no[yi][1] ) ;
1281 fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1],
1282 pdim_no[yi][0],pdim_no[yi][1] ) ;
1283 }
1284 else
1285 {
1286 fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1287 }
1288 }
1289 else if ( !strcmp(memord,"Z") && ok_to_collect_distribute )
1290 {
1291 fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ;
1292 }
1293 else if ( !strcmp(memord,"0") && ok_to_collect_distribute )
1294 {
1295 fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ;
1296
1297 }
1298 else if ( ok_to_collect_distribute )
1299 {
1300 fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ;
1301 }
1302
1303 if ( io_mask & INPUT && p->ntl > 1 ) {
1304 /* copy time level two into time level one */
1305 if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ;
1306 if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ;
1307 }
1308
1309 if ( p->scalar_array_member )
1310 {
1311 fprintf(fp,"END IF\n" ) ;
1312 }
1313
1314 #if DA_CORE==1
1315 if ( !strncmp(dname, "A_", 2) ) {
1316 fprintf(fp,"END IF\n") ;
1317 }
1318 else if ( !strncmp(dname, "G_", 2) ) {
1319 fprintf(fp,"END IF\n") ;
1320 }
1321 #endif
1322 if ( !strncmp( p->use, "dyn_", 4 ) )
1323 fprintf(fp,"END IF\n" ) ;
1324 }
1325 else if ( sw_io == GEN_OUTPUT )
1326 {
1327 if ( !strncmp( p->use, "dyn_", 4 ) )
1328 #if DA_CORE==1
1329 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
1330 if ( !strncmp(dname, "A_", 2) ) {
1331 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1332 }
1333 else if ( !strncmp(dname, "G_", 2) ) {
1334 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1335 }
1336 #else
1337 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
1338 #endif
1339 if ( p->scalar_array_member )
1340 fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1341
1342 /* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data */
1343
1344 if ( p->ndims == 3 && ok_to_collect_distribute )
1345 {
1346 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0)
1347 {
1348 fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1349 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1350 /* fprintf(fp, "ids , ide , jds , jde , kds , kde , &\n") ; */
1351 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1352 ddim_no[yi][0],ddim_no[yi][1],
1353 ddim_no[zi][0],ddim_no[zi][1]) ;
1354 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1355 mdim_no[yi][0],mdim_no[yi][1],
1356 mdim_no[zi][0],mdim_no[zi][1]) ;
1357 fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1],
1358 pdim_no[yi][0],pdim_no[yi][1],
1359 pdim_no[zi][0],pdim_no[zi][1]) ;
1360 }
1361 }
1362 else if ( p->ndims == 2 && ok_to_collect_distribute )
1363 {
1364 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1365 {
1366 fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1367 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1368 /* fprintf(fp, "ids , ide , jds , jde , 1 , 1 , &\n") ; */
1369 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1370 ddim_no[yi][0],ddim_no[yi][1] ) ;
1371 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1372 mdim_no[yi][0],mdim_no[yi][1] ) ;
1373 fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1],
1374 pdim_no[yi][0],pdim_no[yi][1] ) ;
1375 }
1376 else
1377 {
1378 fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1379 }
1380 }
1381
1382 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
1383 for ( i = 0 ; i < 3 ; i++ )
1384 {
1385 if (( dimnode = p->dims[i]) != NULL )
1386 {
1387 switch ( dimnode->coord_axis )
1388 {
1389 case (COORD_X) :
1390 if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
1391 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1392 else if ( p->dims[i]->subgrid )
1393 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1394 else
1395 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1396 break ;
1397 case (COORD_Y) :
1398 if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
1399 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1400 else if ( p->dims[i]->subgrid )
1401 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1402 else
1403 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1404 break ;
1405 case (COORD_Z) :
1406 if ( p->stag_z )
1407 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1408 else if ( p->dims[i]->subgrid )
1409 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1410 else
1411 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1412 break ;
1413 }
1414 }
1415 }
1416
1417 if ( ok_to_collect_distribute )
1418 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1419
1420 strcpy(indices,"") ;
1421 sprintf(post,")") ;
1422 if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */
1423 {
1424 sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1425 }
1426
1427 if ( !(p->scalar_array_member) ) {
1428 fprintf(fp,"CALL wrf_ext_write_field ( &\n") ;
1429 fprintf(fp," fid , & ! DataHandle \n" ) ;
1430 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
1431 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
1432 if ( p->ndims >= 2 && ok_to_collect_distribute )
1433 fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ;
1434 else
1435 fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices ) ;
1436 if (!strncmp(p->type->name,"real",4)) {
1437 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
1438 } else {
1439 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
1440 }
1441 fprintf(fp," grid%%communicator , & ! Comm\n") ;
1442 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
1443 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
1444 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
1445 fprintf(fp," dryrun , & ! flag\n" ) ;
1446 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
1447 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
1448 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
1449 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
1450 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
1451 fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ;
1452 fprintf(fp," '%s' , & ! Units \n",p->units ) ;
1453 fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1454 /* global dimensions */
1455 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1456 fprintf(fp," & \n") ;
1457
1458 /* the first two cases here have to do with if we're running on multiple distributed
1459 memory processors and the i/o api layer can't handle decomposed data. So code is
1460 generated to read the data on processor zero into a globally sized buffer. In this
1461 case, then the domain, memory, and patch dimensions for the globally sized buffer
1462 are all just the domain domain dimensions. Two D arrays are handled separately
1463 from three-d arrays because in threeD arrays the middle index is K. In the last
1464 case, where the code is either calling a version of the API that supports parallelism
1465 or we aren't running in DM-parallel, the field itself and not a global buffer are
1466 passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1467
1468 if ( p->ndims == 3 && ok_to_collect_distribute )
1469 {
1470 /* mem dimensions are actually domain dimensions */
1471 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1472 fprintf(fp," & \n") ;
1473 /* patch dimensions are actually domain dimensions */
1474 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1475 fprintf(fp," & \n") ;
1476 }
1477 else if ( p->ndims == 2 && ok_to_collect_distribute )
1478 {
1479 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1480 {
1481 /* mem dimensions are actually domain dimensions */
1482 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1483 ddim_no[yi][0],ddim_no[yi][1] ) ;
1484 /* patch dimensions are actually domain dimensions */
1485 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1],
1486 ddim[yi][0],ddim[yi][1] ) ;
1487 }
1488 }
1489 else
1490 {
1491 /* mem dimensions */
1492 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1493 fprintf(fp," & \n") ;
1494 /* patch dimensions */
1495 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1496 fprintf(fp," & \n") ;
1497 }
1498 fprintf(fp," ierr )\n") ;
1499
1500 if ( ok_to_collect_distribute )
1501 fprintf(fp,"END IF\n" ) ;
1502
1503 /*
1504 if ( p->scalar_array_member )
1505 fprintf(fp,"END IF\n" ) ;
1506 */
1507 #if DA_CORE==1
1508 if ( !strncmp(dname, "A_", 2) ) {
1509 fprintf(fp,"END IF\n") ;
1510 }
1511 else if ( !strncmp(dname, "G_", 2) ) {
1512 fprintf(fp,"END IF\n") ;
1513 }
1514 #endif
1515 if ( !strncmp( p->use, "dyn_", 4 ) )
1516 fprintf(fp,"END IF\n" ) ;
1517
1518 }
1519 }
1520 }
1521 }
1522 }
1523 }
1524 if ( p->type->type_type == DERIVED )
1525 {
1526 sprintf(x,"%s%s%%",structname,p->name ) ;
1527 gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ;
1528 }
1529
1530 }
1531 }
1532 return(0) ;
1533 }
1534