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