source: trunk/WRF.COMMON/WRFV2/tools/gen_wrf_io.c @ 3547

Last change on this file since 3547 was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 60.0 KB
Line 
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
11static 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
24int
25gen_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
231int
232set_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
313int
314gen_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      {
392fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
393fprintf(fp,"  IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
394fprintf(fp,"    CALL wrf_ext_%s_field (  &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
395fprintf(fp,"          fid                             , &  ! DataHandle\n") ;
396fprintf(fp,"          current_date(1:19)              , &  ! DateStr\n") ; 
397fprintf(fp,"          TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ;
398        strcpy( tl, "" ) ;
399        if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ;
400        if ( ok_to_collect_distribute ) {
401fprintf(fp,"                       globbuf_%s               , &  ! Field \n",p->members->type->name ) ;
402        } else {
403fprintf(fp,"          grid%%%s%s(ims,kms,jms,itrace)  , &  ! Field\n",p->name,tl) ;
404        }
405        if (!strncmp(p->members->type->name,"real",4)) {
406          fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
407        } else {
408          fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->members->type->name ) ;
409        }
410fprintf(fp,"          grid%%communicator  , &  ! Comm\n") ;
411fprintf(fp,"          grid%%iocommunicator  , &  ! Comm\n") ;
412fprintf(fp,"          grid%%domdesc       , &  ! Comm\n") ;
413fprintf(fp,"          grid%%bdy_mask       , &  ! bdy_mask\n") ;
414        if ( sw_io == GEN_OUTPUT ) {
415fprintf(fp,"          dryrun             , &  ! flag\n") ;
416        }
417        set_mem_order( p->members, memord , NAMELEN) ;
418fprintf(fp,"          'XZY'               , &  ! MemoryOrder\n") ;
419        strcpy(stagstr, "") ;
420        if ( p->members->stag_x ) strcat(stagstr, "X") ;
421        if ( p->members->stag_y ) strcat(stagstr, "Y") ;
422        if ( p->members->stag_z ) strcat(stagstr, "Z") ;
423fprintf(fp,"          '%s'                , &  ! Stagger\n",stagstr) ;
424        if ( sw_io == GEN_OUTPUT ) {
425          for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
426          for ( i = 0 ; i < 3 ; i++ )
427          {
428            if (( dimnode = p->members->dims[i]) != NULL )
429            {
430              switch ( dimnode->coord_axis )
431              {
432              case (COORD_X) :
433                if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) )
434                 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
435                else
436                 { strcpy( dimname[i], dimnode->dim_data_name) ; }
437                break ;
438              case (COORD_Y) :
439                if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) )
440                 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
441                else
442                 { strcpy( dimname[i], dimnode->dim_data_name) ; }
443                break ;
444              case (COORD_Z) :
445                if ( p->members->stag_z )
446                 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
447                else
448                 { strcpy( dimname[i], dimnode->dim_data_name) ; }
449                break ;
450              }
451            }
452          }
453fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
454fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
455fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
456fprintf(fp,"          %s_desc_table( grid%%id, itrace  ), & ! Desc\n",p->name) ;
457fprintf(fp,"          %s_units_table( grid%%id, itrace  ), & ! Units\n",p->name) ;
458        }
459fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ;
460        /* global dimensions */
461        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
462        fprintf(fp," & \n") ;
463        /* mem    dimensions */
464        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
465        fprintf(fp," & \n") ;
466        /* patch  dimensions */
467        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
468        fprintf(fp," & \n") ;
469fprintf(fp,"                         ierr )\n" ) ;
470fprintf(fp, "  ENDIF\n" ) ;
471fprintf(fp, "ENDDO\n") ;
472      } 
473/* BOUNDARY FOR 4-D TRACER */
474      else if ( io_mask & BOUNDARY )
475      {
476        int ibdy ;
477        int idx ;
478        node_t *fourd_bound_array ;
479        char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ;
480        char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
481
482/* check for the existence of a fourd boundary array */
483        sprintf(fourd_bnd,"%s_b",p->name) ;
484        if (( fourd_bound_array = get_entry( fourd_bnd  ,Domain.fields)) != NULL ) {
485
486          for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
487          strcpy( dimname[2] , "bdy_width" ) ;
488          ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
489          ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
490          ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
491          if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
492           { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
493             else             { strcpy(  dimname[1], dimnode->dim_data_name) ; }
494             if ( p->stag_z ) { zdomainend = "kde" ; }
495             else             { zdomainend = "(kde-1)" ; }
496             ds2 = "kds" ; de2 = zdomainend ;
497             ms2 = "kds" ; me2 = "kde" ;   /* 20020924 */
498             ps2 = "kds" ; pe2 = zdomainend ;
499           }
500          else
501           {
502             fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ;
503           }
504          for ( pass = 0 ; pass < 2 ; pass++ ) {
505fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
506fprintf(fp,"  IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
507          for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
508          {
509            if        ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ;      /* west bdy   */
510            } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ;      /* east bdy   */
511            } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ;      /* south bdy   */
512            } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ;      /* north bdy   */
513            } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ;      /* west bdy   */
514            } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ;      /* east bdy   */
515            } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ;      /* south bdy   */
516            } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ;      /* north bdy   */
517            }
518            if ( ibdy == 1 || ibdy == 2 ) {
519              if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
520              {
521                idx = get_index_for_coord( p , COORD_Y  ) ;
522                if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
523                ds1 = "1" ; de1 = ydomainend ;
524                ms1 = "1" ; me1 = "MAX( ide , jde )" ;
525                if        ( sw_io == GEN_INPUT ) {
526                  ps1 = "1" ; pe1 = ydomainend ;
527                } else if ( sw_io == GEN_OUTPUT ) {
528                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
529                }
530                if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
531                else                   { strcpy( dimname[0], dimnode->dim_data_name) ; }
532              }
533            }
534            if ( ibdy == 3 || ibdy == 4 ) {
535              if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
536              {
537                idx = get_index_for_coord( p , COORD_X  ) ;
538                if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
539                ds1 = "1" ; de1 = xdomainend ;
540                ms1 = "1" ; me1 = "MAX( ide , jde )" ;
541                if        ( sw_io == GEN_INPUT ) {
542                  ps1 = "1" ; pe1 = xdomainend ;
543                } else if ( sw_io == GEN_OUTPUT ) {
544                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
545                }
546                if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
547                else             { strcpy( dimname[0], dimnode->dim_data_name) ; }
548              }
549            }
550            if      ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ;
551            else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ;
552            else                      sprintf(memord,"0") ;
553fprintf(fp,"    CALL wrf_ext_%s_field (  &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
554fprintf(fp,"          fid                             , &  ! DataHandle\n") ;
555fprintf(fp,"          current_date(1:19)              , &  ! DateStr\n") ; 
556fprintf(fp,"          TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ;
557            if ( ok_to_collect_distribute ) {
558fprintf(fp,"                       globbuf_%s               , &  ! Field \n",p->members->type->name ) ;
559            } else {
560              strcpy(bdytag2,"") ;
561              strncat(bdytag2,bdytag, pass+2) ;
562fprintf(fp,"          grid%%%s%s(1,kds,1,%d,itrace)  , &  ! Field\n",p->name,bdytag2,ibdy) ;
563            }
564            if (!strncmp(p->members->type->name,"real",4)) {
565              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
566            } else {
567              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->members->type->name ) ;
568            }
569fprintf(fp,"          grid%%communicator  , &  ! Comm\n") ;
570fprintf(fp,"          grid%%iocommunicator  , &  ! Comm\n") ;
571fprintf(fp,"          grid%%domdesc       , &  ! Comm\n") ;
572fprintf(fp,"          grid%%bdy_mask       , &  ! bdy_mask\n") ;
573            if ( sw_io == GEN_OUTPUT ) {
574fprintf(fp,"          dryrun             , &  ! flag\n") ;
575            }
576fprintf(fp,"          '%s'               , &  ! MemoryOrder\n",memord) ;
577            strcpy(stagstr, "") ;
578            if ( p->members->stag_x ) strcat(stagstr, "X") ;
579            if ( p->members->stag_y ) strcat(stagstr, "Y") ;
580            if ( p->members->stag_z ) strcat(stagstr, "Z") ;
581fprintf(fp,"          '%s'                , &  ! Stagger\n",stagstr) ;
582            if ( sw_io == GEN_OUTPUT ) {
583fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
584fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
585fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
586fprintf(fp,"          %s_desc_table( grid%%id, itrace  ), & ! Desc\n",p->name) ;
587fprintf(fp,"          %s_units_table( grid%%id, itrace  ), & ! Units\n",p->name) ;
588            }
589fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ;
590fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
591fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
592fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
593fprintf(fp,"                         ierr )\n" ) ;
594          }
595fprintf(fp, "  ENDIF\n" ) ;
596fprintf(fp, "ENDDO\n") ;
597        }
598      }
599      } /* if fourd bound array associated with this tracer */
600    }
601    else if ( p->type != NULL )
602    {
603
604    if ( p->type->type == SIMPLE )
605    {
606
607/* ////////  BOUNDARY ///////////////////// */
608
609      if (  p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA ) 
610         && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) )
611      {
612        int ibdy ;
613        int idx ;
614        char *bdytag, *xdomainend, *ydomainend, *zdomainend ;
615        char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
616
617        if (!strncmp( p->use, "dyn_", 4))
618          sprintf(core,"%s_",p->use+4) ;
619        else
620          strcpy(core,"") ;
621
622        for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
623        strcpy( dimname[2] , "bdy_width" ) ;
624        ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
625        ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
626        ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
627
628        if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
629         { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } 
630           else             { strcpy(  dimname[1], dimnode->dim_data_name) ; }
631           if ( p->stag_z ) { zdomainend = "kde" ; } 
632           else             { zdomainend = "(kde-1)" ; }
633           ds2 = "kds" ; de2 = zdomainend ;
634           ms2 = "kds" ; me2 = "kde" ;   /* 20020924 */
635           ps2 = "kds" ; pe2 = zdomainend ;
636         }
637        else
638         { strcpy(dimname[1],dimname[2]) ;
639           strcpy(dimname[2],"one_element") ; 
640           ds2 = ds3 ; de2 = de3 ;
641           ms2 = ms3 ; me2 = me3 ;
642           ps2 = ps3 ; pe2 = pe3 ;
643           ds3 = "1" ; de3 = "1" ;
644           ms3 = "1" ; me3 = "1" ;
645           ps3 = "1" ; pe3 = "1" ;
646         }
647
648        if ( strlen(p->dname) < 1 ) {
649          fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ;
650        }
651
652        for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
653        {
654          if        ( ibdy == 1 ) { bdytag = "XS" ;      /* west bdy   */
655          } else if ( ibdy == 2 ) { bdytag = "XE" ;      /* east bdy   */
656          } else if ( ibdy == 3 ) { bdytag = "YS" ;      /* south bdy   */
657          } else if ( ibdy == 4 ) { bdytag = "YE" ;      /* north bdy   */
658          }
659          if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag)  ; }
660          else                                                { sprintf(dname,"%s%s",p->dname,bdytag) ; }
661
662          make_upper_case(dname) ;
663
664          if ( ibdy == 1 || ibdy == 2 ) { 
665            if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
666            {
667              idx = get_index_for_coord( p , COORD_Y  ) ;
668              if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
669              ds1 = "1" ; de1 = ydomainend ;
670              ms1 = "1" ; me1 = "MAX( ide , jde )" ;
671              if        ( sw_io == GEN_INPUT ) {
672                ps1 = "1" ; pe1 = ydomainend ;
673              } else if ( sw_io == GEN_OUTPUT ) {
674                ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
675              }
676              if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
677              else                   { strcpy( dimname[0], dimnode->dim_data_name) ; }
678            }
679          }
680          if ( ibdy == 3 || ibdy == 4 ) {
681            if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
682            {
683              idx = get_index_for_coord( p , COORD_X  ) ;
684              if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
685              ds1 = "1" ; de1 = xdomainend ;
686              ms1 = "1" ; me1 = "MAX( ide , jde )" ;
687              if        ( sw_io == GEN_INPUT ) {
688                ps1 = "1" ; pe1 = xdomainend ;
689              } else if ( sw_io == GEN_OUTPUT ) {
690                ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
691              }
692              if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
693              else             { strcpy( dimname[0], dimnode->dim_data_name) ; }
694            }
695          }
696          if      ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ;
697          else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ;
698          else                      sprintf(memord,"0") ;
699
700        passes = 1 ;
701        if ( fourdname != NULL ) passes = 2 ;
702        for ( pass = 0 ; pass < passes ; pass++ ) {
703          tend_tag = ( pass == 0 ) ? "_B" : "_BT" ;
704          if ( sw_io == GEN_INPUT )
705          {
706            if ( !strncmp( p->use, "dyn_", 4 ) ) 
707              fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
708            if ( ok_to_collect_distribute )
709              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
710            fprintf(fp,"CALL wrf_ext_read_field (  &\n") ;
711            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
712            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
713            if ( fourdname == NULL ) {
714              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
715              fprintf(fp,"                       %s%s%s(1,kds,1,%d)     , &  ! Field \n" , structname , core , p->name, ibdy ) ;
716            } else {
717              if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag)  ; }
718              else                                                { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
719              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
720              fprintf(fp,"                       %s%s%s%s(1,kds,1,%d,P_%s)     , &  ! Field \n" , structname , core , fourdname, tend_tag, ibdy, p->name ) ;
721            }
722            if (!strncmp(p->type->name,"real",4)) {
723              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
724            } else {
725              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
726            }
727            fprintf(fp,"                       grid%%communicator , &  ! Comm\n") ;
728            fprintf(fp,"                       grid%%iocommunicator , &  ! Comm\n") ;
729            fprintf(fp,"                       grid%%domdesc      , &  ! Comm\n") ;
730            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n" ) ;
731            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
732            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
733            fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
734            /* global dimensions */
735            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
736            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
737            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
738            fprintf(fp,"                       ierr )\n") ;
739            if ( ok_to_collect_distribute )
740            {
741              fprintf(fp,"ENDIF\n") ;
742              fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , core , p->name, ibdy) ;
743              fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1)  )\n",me1,ms1,me2,ms2,me3,ms3)  ;
744            }
745            if ( !strncmp( p->use, "dyn_", 4 ) ) 
746              fprintf(fp,"END IF\n" ) ;
747          }
748          else if ( sw_io == GEN_OUTPUT )
749          {
750            if ( ok_to_collect_distribute )
751              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
752            if ( !strncmp( p->use, "dyn_", 4 ) )
753              fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
754            fprintf(fp,"CALL wrf_ext_write_field (  &\n") ;
755            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
756            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
757            if ( fourdname == NULL ) {
758              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
759              fprintf(fp,"                       %s%s%s(1,kds,1,%d)     , &  ! Field \n" , structname , core , p->name, ibdy ) ;
760            } else {
761              if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag)  ; }
762              else                                                { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
763              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
764              fprintf(fp,"                       %s%s%s%s(1,kds,1,%d,P_%s)     , &  ! Field \n" , structname , core , fourdname, tend_tag, ibdy, p->name ) ;
765            }
766            if (!strncmp(p->type->name,"real",4)) {
767              fprintf(fp,"                       WRF_FLOAT          , &  ! FieldType \n") ;
768            } else {
769              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
770            }
771            fprintf(fp,"                       grid%%communicator , &  ! Comm\n") ;
772            fprintf(fp,"                       grid%%iocommunicator , &  ! Comm\n") ;
773            fprintf(fp,"                       grid%%domdesc      , &  ! Comm\n") ;
774            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n" ) ;
775            fprintf(fp,"                       dryrun             , &  ! flag\n" ) ;
776            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
777            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
778            fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
779            fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
780            fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
781            fprintf(fp,"                       '%s'               , &  ! Desc  \n",p->descrip ) ;
782            fprintf(fp,"                       '%s'               , &  ! Units \n",p->units ) ;
783            fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
784            /* global dimensions */
785            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
786            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
787            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
788            fprintf(fp,"                       ierr )\n") ;
789            if ( !strncmp( p->use, "dyn_", 4 ) )
790              fprintf(fp,"END IF\n" ) ;
791            if ( ok_to_collect_distribute )
792              fprintf(fp,"ENDIF\n") ;
793          }
794        }
795        }
796      }
797
798/* ////////  NOT BOUNDARY ///////////////////// */
799     else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY))
800     {
801
802/* Aug 2004
803
804Namelist variables
805
806The i r and h settings will be reenabled but it will work a little
807differently than i/o of regular state variables:
808
8091) rather than being read or written as records to the dataset, they
810will be gotten or put as time invariant meta data; in other words, they
811will only be written once when the dataset is created as the other
812metadata is now. This has the benefit of reducing the amount of I/O
813traffic on each write (I can't remember, but that may be why the
814reading and writing of rconfig data was turned off in the first
815place).
816
8172) All the rconfig variables will be gotten/put as metadata to input,
818restart, history, and boundary datasets, regardless of what the 'i',
819'r', and 'h' settings are.  Instead those settings will control the
820behavior with respect to the input-from-namelist vs input-from-dataset
821precedence issue that Bill raised.
822
823In other words, if an rconfig entry has an 'i', 'r', or 'h' in the
824Registry, the dataset value takes precedence over the namelist value.
825Otherwise, say it is missing the 'i', the reconfig variable's value
826still appears as metadata in the dataset but the value of the variable
827in the program does not change as a result of inputting the dataset.
828
829*/
830
831      if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) )
832      {
833        char c ;
834        char dname[NAMELEN] ;
835
836        strcpy( dname, p->dname ) ; 
837        make_upper_case( dname ) ;
838        if      ( !strcmp( p->type->name , "integer" )         ) { c = 'i' ; }
839        else if ( !strcmp( p->type->name , "real" )            ) { c = 'r' ; }
840        else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; }
841        else if ( !strcmp( p->type->name , "logical" )         ) { c = 'l' ; }
842        else {
843          fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ;
844        }
845        if ( sw_io == GEN_OUTPUT ) {
846          if ( io_mask & p->io_mask ) {
847            fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
848            fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
849          }
850        } else {
851          if ( io_mask & p->io_mask ) {
852            fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
853            fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ;
854            fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ;
855            fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
856          }
857        }
858      }
859/* end Aug 2004 */
860#if 0
861      else if ( ! (io_mask & METADATA) )   /* state vars */
862#else
863      else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) )   /* state vars */
864#endif
865      {
866        if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ;
867        else                                   passes = 1 ;
868
869        for ( pass = 0 ; pass < passes ; pass++ )   /* for multi timelevel vars */
870        {
871          if (!strncmp( p->use, "dyn_", 4))
872            sprintf(core,"%s_",p->use+4) ;
873          else
874            strcpy(core,"") ;
875
876                  /* for multi time level variables gen read for both levels
877                     for restart, only _2 for others */
878          if ( p->ntl > 1 ) {
879            if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ;
880            else                     sprintf(tag,"_%d",p->ntl) ;
881          }
882          else              sprintf(tag,"") ; 
883
884          /* construct variable name */
885          if ( p->scalar_array_member )
886          {
887            strcpy(dexes,"") ;
888            for (ii = 0; ii < p->ndims; ii++ )
889            {
890              switch(p->dims[ii]->coord_axis)
891              {
892              case(COORD_X): strcat(dexes,"ims,") ; break ;
893              case(COORD_Y): strcat(dexes,"jms,") ; break ;
894              case(COORD_Z): strcat(dexes,"kms,") ; break ;
895              default : break ;
896              }
897            }
898            sprintf(vname,"%s%s%s(%sP_%s)",core,p->use,tag,dexes,p->name) ;
899            sprintf(vname_2,"%s%s%s(%sP_%s)",core,p->use,"_2",":,:,:,",p->name) ;
900            sprintf(vname_1,"%s%s%s(%sP_%s)",core,p->use,"_1",":,:,:,",p->name) ;
901            sprintf(vname_x,"%s%s%s(%sP_%s)",core,p->use,tag,":,:,:,",p->name) ;
902          }
903          else
904          {
905            sprintf(vname,"%s%s%s",core,p->name,tag) ;
906            sprintf(vname_x,"%s%s%s",core,p->name,tag) ;
907            sprintf(vname_1,"%s%s%s",core,p->name,"_1") ;
908            sprintf(vname_2,"%s%s%s",core,p->name,"_2") ;
909          }
910
911
912          /* construct data name -- maybe same as vname if dname not spec'd  */
913          if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; }
914          else                                                  { strcpy(dname_tmp,p->dname) ; }
915          make_upper_case(dname_tmp) ;
916
917/*
918   July 2004
919
920   New code to generate error if input or output for two state variables would be generated with the same dataname
921
922   example okay:
923    dyn_nmm  tg      "SOILTB"   -> dyn_nmm_tg,SOILTB
924    dyn_em   soiltb  "SOILTB"   -> dyn_em_tg,SOILTB
925   example wrong:
926    dyn_nmm  tg      "SOILTB"   -> dyn_nmm_tg,SOILTB
927    misc     soiltb  "SOILTB"   -> gen_soiltb,SOILTB
928   example wrong:
929     misc    tg      "SOILTB"   -> gen_tg,SOILTB
930     misc    soiltb  "SOILTB"   -> gen_soiltb,SOILTB
931
932*/
933if ( pass == 0 )
934{
935          char dname_symbol[128] ;
936          sym_nodeptr sym_node ;
937
938          sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
939          /* check and see if it is in the symbol table already */
940
941          if ((sym_node = sym_get( dname_symbol )) == NULL ) {
942            /* add it */
943            sym_node = sym_add ( dname_symbol ) ;
944            strcpy( sym_node->internal_name , p->name ) ;
945            strcpy( sym_node->core_name , core ) ;
946          } else {
947            /* it's there already, check and make sure we don't have an error condition */
948            if ( (strlen(core) > 0 && strlen( sym_node->core_name ) > 0 && !strcmp( core, sym_node->core_name ))
949              || strlen(core) == 0
950              || strlen( sym_node->core_name ) == 0 )
951            {
952              char this_core[64] , sym_core[64] ;
953              strcpy(this_core,"(generic)") ;
954              if ( strlen(core) > 0 )                sprintf(this_core,"(%s)",core) ;
955              strcpy(sym_core,"(generic)") ;
956              if ( strlen(sym_node->core_name) > 0 ) sprintf(this_core,"(%s)",sym_node->core_name) ;
957              fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s %s and %s %s\n",
958                  dname_tmp,p->name,this_core,sym_node->internal_name,sym_core ) ;
959            }
960          }
961}
962/* end July 2004 */
963
964          if ( io_mask & RESTART &&  p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ;
965          else                                    strcpy(dname,dname_tmp) ;
966
967          set_mem_order( p, memord , NAMELEN) ;
968
969/* kludge for WRF 3DVAR I/O with MM5 analysis kernel */
970          if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ;
971          if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ;
972
973          if ( strlen(dname) < 1 ) {
974            fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ;
975          }
976          if ( p->io_mask & io_mask && sw_io == GEN_INPUT )
977          {
978            if ( !strncmp( p->use, "dyn_", 4 ) ) 
979              fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
980            if ( p->scalar_array_member )
981              fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
982            if ( ok_to_collect_distribute )
983              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
984
985            strcpy(indices,"") ;
986            sprintf(post,")") ;
987            if ( sw_io_deref_kludge && !(p->scalar_array_member) )   /* these aready have */
988            {
989              sprintf(indices, "%s",index_with_firstelem("(","grid%",t2,p,post)) ;
990            }
991
992            fprintf(fp,"CALL wrf_ext_read_field (  &\n") ;
993            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
994            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
995            fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
996            if ( p->ndims >= 2 && ok_to_collect_distribute )
997              fprintf(fp,"                       globbuf_%s               , &  ! Field \n" , p->type->name ) ;
998            else
999              fprintf(fp,"                       %s%s%s               , &  ! Field \n" , structname , vname , indices) ;
1000
1001            if (!strncmp(p->type->name,"real",4)) {
1002              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
1003            } else {
1004              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
1005            }
1006
1007            fprintf(fp,"                       grid%%communicator  , &  ! Comm\n") ;
1008            fprintf(fp,"                       grid%%iocommunicator  , &  ! Comm\n") ;
1009            fprintf(fp,"                       grid%%domdesc       , &  ! Comm\n") ;
1010            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n") ;
1011            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
1012            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
1013            fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1014            /* global dimensions */
1015            for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1016            fprintf(fp," & \n") ;
1017
1018/* the first two cases here have to do with if we're running on multiple distributed
1019   memory processors and the i/o api layer can't handle decomposed data. So code is
1020   generated to read the data on processor zero into a globally sized buffer. In this
1021   case, then the domain, memory, and patch dimensions for the globally sized buffer
1022   are all just the domain dimensions. Two D arrays are handled separately
1023   from three-d arrays because in threeD arrays the middle index is K.  In the last
1024   case, where the code is either calling a version of the API that supports parallelism
1025   or we aren't running in DM-parallel, the field itself and not a global buffer are
1026   passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1027
1028            if      ( p->ndims == 3 && ok_to_collect_distribute )
1029            {
1030              /* mem    dimensions are actually domain dimensions */
1031              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1032              fprintf(fp," & \n") ;
1033              /* patch  dimensions are actually domain dimensions */
1034              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim   [i][0], ddim   [i][1]) ; }
1035              fprintf(fp," & \n") ;
1036            }
1037            else if ( p->ndims == 2 && ok_to_collect_distribute )
1038            {
1039              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1040              {
1041                /* mem    dimensions are actually domain dimensions */
1042                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1043                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1044              /* patch  dimensions are actually domain dimensions */
1045                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim   [xi][0],ddim   [xi][1],
1046                                                          ddim   [yi][0],ddim   [yi][1] ) ;
1047              }
1048            }
1049            else
1050            {
1051              /* mem    dimensions */
1052              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1053              fprintf(fp," & \n") ;
1054              /* patch  dimensions */
1055              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1056              fprintf(fp," & \n") ;
1057            }
1058            fprintf(fp,"                       ierr )\n") ;
1059
1060            if ( ok_to_collect_distribute )
1061              fprintf(fp,"END IF\n" ) ;
1062
1063/* In case we have read into a global buffer, generate code to distribute the data just read in */
1064            if      ( p->ndims == 3 && ok_to_collect_distribute )
1065            {
1066              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)
1067              {
1068                fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1069                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1070                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1071                                                          ddim_no[yi][0],ddim_no[yi][1],
1072                                                          ddim_no[zi][0],ddim_no[zi][1]) ;
1073                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1074                                                          mdim_no[yi][0],mdim_no[yi][1],
1075                                                          mdim_no[zi][0],mdim_no[zi][1]) ;
1076                fprintf(fp, "%s, %s, %s, %s, %s, %s  )\n",pdim_no[xi][0],pdim_no[xi][1],
1077                                                          pdim_no[yi][0],pdim_no[yi][1],
1078                                                          pdim_no[zi][0],pdim_no[zi][1]) ;
1079              }
1080            }
1081            else if ( p->ndims == 2 && ok_to_collect_distribute )
1082            {
1083              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1084              {
1085                fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1086                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1087                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1088                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1089                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1090                                                          mdim_no[yi][0],mdim_no[yi][1] ) ;
1091                fprintf(fp, "%s, %s, %s, %s, 1 , 1   )\n",pdim_no[xi][0],pdim_no[xi][1],
1092                                                          pdim_no[yi][0],pdim_no[yi][1] ) ;
1093              }
1094              else
1095              {
1096                fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1097              }
1098            }
1099            else if ( !strcmp(memord,"Z") && ok_to_collect_distribute )
1100            {
1101              fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ;
1102            }
1103            else if ( !strcmp(memord,"0") && ok_to_collect_distribute )
1104            {
1105              fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ;
1106
1107            }
1108            else if ( ok_to_collect_distribute )
1109            {
1110              fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ;
1111            }
1112
1113            if ( io_mask & INPUT && p->ntl > 1 ) {
1114              /* copy time level two into time level one */
1115              if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ;
1116              if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ;
1117            }
1118
1119            if ( p->scalar_array_member )
1120            {
1121              fprintf(fp,"END IF\n" ) ;
1122            }
1123
1124            if ( !strncmp( p->use, "dyn_", 4 ) ) 
1125              fprintf(fp,"END IF\n" ) ;
1126          }
1127          else if ( sw_io == GEN_OUTPUT )
1128          {
1129            if ( !strncmp( p->use, "dyn_", 4 ) ) 
1130              fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
1131            if ( p->scalar_array_member )
1132              fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1133
1134/* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data  */
1135
1136            if      ( p->ndims == 3 && ok_to_collect_distribute )
1137            {
1138              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)
1139              {
1140                fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1141                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1142/*              fprintf(fp, "ids , ide , jds , jde , kds , kde ,                &\n")  ; */
1143                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1144                                                          ddim_no[yi][0],ddim_no[yi][1],
1145                                                          ddim_no[zi][0],ddim_no[zi][1]) ;
1146                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1147                                                          mdim_no[yi][0],mdim_no[yi][1],
1148                                                          mdim_no[zi][0],mdim_no[zi][1]) ;
1149                fprintf(fp, "%s, %s, %s, %s, %s, %s  )\n",pdim_no[xi][0],pdim_no[xi][1],
1150                                                          pdim_no[yi][0],pdim_no[yi][1],
1151                                                          pdim_no[zi][0],pdim_no[zi][1]) ;
1152              }
1153            }
1154            else if ( p->ndims == 2 && ok_to_collect_distribute )
1155            {
1156              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1157              {
1158                fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1159                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1160/*              fprintf(fp, "ids , ide , jds , jde , 1 , 1 ,                &\n")  ; */
1161                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1162                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1163                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1164                                                          mdim_no[yi][0],mdim_no[yi][1] ) ;
1165                fprintf(fp, "%s, %s, %s, %s, 1 , 1   )\n",pdim_no[xi][0],pdim_no[xi][1],
1166                                                          pdim_no[yi][0],pdim_no[yi][1] ) ;
1167              }
1168              else
1169              {
1170                fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1171              }
1172            }
1173         
1174            for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
1175            for ( i = 0 ; i < 3 ; i++ ) 
1176            {
1177              if (( dimnode = p->dims[i]) != NULL )
1178              {
1179                switch ( dimnode->coord_axis )
1180                {
1181                case (COORD_X) : 
1182                  if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
1183                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1184                  else 
1185                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1186                  break ;
1187                case (COORD_Y) : 
1188                  if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
1189                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1190                  else 
1191                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1192                  break ;
1193                case (COORD_Z) : 
1194                  if ( p->stag_z ) 
1195                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1196                  else 
1197                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1198                  break ;
1199                }
1200              }
1201            }
1202
1203            if ( ok_to_collect_distribute )
1204              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1205
1206            strcpy(indices,"") ;
1207            sprintf(post,")") ;
1208            if ( sw_io_deref_kludge && !(p->scalar_array_member) )   /* these aready have */
1209            {
1210              sprintf(indices, "%s",index_with_firstelem("(","grid%",t2,p,post)) ;
1211            }
1212
1213  if ( !(p->scalar_array_member) ) {
1214            fprintf(fp,"CALL wrf_ext_write_field (  &\n") ;
1215            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
1216            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
1217            fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
1218            if ( p->ndims >= 2 && ok_to_collect_distribute )
1219              fprintf(fp,"                       globbuf_%s               , &  ! Field \n" , p->type->name ) ;
1220            else
1221              fprintf(fp,"                       %s%s%s               , &  ! Field \n" , structname , vname , indices ) ;
1222            if (!strncmp(p->type->name,"real",4)) {
1223              fprintf(fp,"                       WRF_FLOAT          , &  ! FieldType \n") ;
1224            } else {
1225              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
1226            }
1227            fprintf(fp,"                       grid%%communicator  , &  ! Comm\n") ;
1228            fprintf(fp,"                       grid%%iocommunicator  , &  ! Comm\n") ;
1229            fprintf(fp,"                       grid%%domdesc       , &  ! Comm\n") ;
1230            fprintf(fp,"                       grid%%bdy_mask       , &  ! bdy_mask\n") ;
1231            fprintf(fp,"                       dryrun             , &  ! flag\n" ) ;
1232            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
1233            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
1234            fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
1235            fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
1236            fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
1237            fprintf(fp,"                       '%s'               , &  ! Desc  \n",p->descrip ) ;
1238            fprintf(fp,"                       '%s'               , &  ! Units \n",p->units ) ;
1239            fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1240            /* global dimensions */
1241            for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1242            fprintf(fp," & \n") ;
1243
1244/* the first two cases here have to do with if we're running on multiple distributed
1245   memory processors and the i/o api layer can't handle decomposed data. So code is
1246   generated to read the data on processor zero into a globally sized buffer. In this
1247   case, then the domain, memory, and patch dimensions for the globally sized buffer
1248   are all just the domain domain dimensions. Two D arrays are handled separately
1249   from three-d arrays because in threeD arrays the middle index is K.  In the last
1250   case, where the code is either calling a version of the API that supports parallelism
1251   or we aren't running in DM-parallel, the field itself and not a global buffer are
1252   passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1253
1254            if      ( p->ndims == 3 && ok_to_collect_distribute )
1255            {
1256              /* mem    dimensions are actually domain dimensions */
1257              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1258              fprintf(fp," & \n") ;
1259              /* patch  dimensions are actually domain dimensions */
1260              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1261              fprintf(fp," & \n") ;
1262            }
1263            else if ( p->ndims == 2 && ok_to_collect_distribute )
1264            {
1265              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1266              {
1267                /* mem    dimensions are actually domain dimensions */
1268                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1269                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1270              /* patch  dimensions are actually domain dimensions */
1271                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1],
1272                                                          ddim[yi][0],ddim[yi][1] ) ;
1273              }
1274            }
1275            else
1276            {
1277              /* mem    dimensions */
1278              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1279              fprintf(fp," & \n") ;
1280              /* patch  dimensions */
1281              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1282              fprintf(fp," & \n") ;
1283            }
1284            fprintf(fp,"                       ierr )\n") ;
1285
1286            if ( ok_to_collect_distribute )
1287              fprintf(fp,"END IF\n" ) ;
1288
1289/*
1290            if ( p->scalar_array_member )
1291              fprintf(fp,"END IF\n" ) ;
1292*/
1293            if ( !strncmp( p->use, "dyn_", 4 ) ) 
1294              fprintf(fp,"END IF\n" ) ;
1295
1296  }
1297          }
1298        }
1299      }
1300    }
1301    }
1302    if ( p->type->type_type == DERIVED )
1303    {
1304      sprintf(x,"%s%s%%",structname,p->name ) ;
1305      gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ;
1306    }
1307
1308    }
1309  }
1310  return(0) ;
1311}
1312
Note: See TracBrowser for help on using the repository browser.