source: lmdz_wrf/trunk/WRFV3/external/RSL_LITE/gen_comms.c @ 1361

Last change on this file since 1361 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 108.9 KB
Line 
1#include <stdio.h>
2#include <stdlib.h>
3#include <string.h>
4
5#ifdef _WIN32
6#define index(X,Y) strchr(X,Y)
7#endif
8
9#include "protos.h"
10#include "registry.h"
11#include "data.h"
12
13/* For detecting variables that are members of a derived type */
14#define NULLCHARPTR   (char *) 0
15static int parent_type;
16
17/* print actual and dummy arguments and declarations for 4D and i1 arrays */
18int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */, int du /* 0=dummy,1=actual */)   
19{
20  node_t * q ;
21  node_t * dimd ;
22  char fname[NAMELEN] ;
23  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
24  char commuse[NAMELEN] ;
25  int maxstenwidth, stenwidth ;
26  char * t1, * t2 , *wordsize ;
27  char varref[NAMELEN], moredims[80] ;
28  char * pos1 , * pos2 ;
29  char * dimspec ;
30  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
31  int zdex, d ;
32
33    set_mark( 0, Domain.fields ) ;
34
35    strcpy( tmp, p->comm_define ) ;
36    strcpy( commuse, p->use ) ;
37    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
38    while ( t1 != NULL )
39    {
40      strcpy( tmp2 , t1 ) ;
41      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
42       { 
43         fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ;
44       }
45      t2 = strtok_rentr(NULL,",", &pos2) ;
46      while ( t2 != NULL )
47      {
48        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
49          { fprintf(stderr,"WARNING 1a : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
50        else
51        {
52          strcpy( varref, t2 ) ;
53          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
54             sprintf(varref,"grid%%%s",t2) ;
55          }
56
57          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
58          else if ( q->boundary_array ) { ; }
59          else
60          { 
61            if      ( ! strcmp( q->type->name, "real") )            { wordsize = "RWORDSIZE" ; }
62            else if ( ! strcmp( q->type->name, "integer") )         { wordsize = "IWORDSIZE" ; }
63            else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
64            if ( q->node_kind & FOURD )
65            {
66              node_t *member ;
67              zdex = get_index_for_coord( q , COORD_Z ) ;
68              if ( zdex >=1 && zdex <= 3 )
69              {
70                set_mem_order( q->members, memord , 3 ) ;
71                if ( ad == 0 ) 
72                /* actual or dummy argument */
73                {
74/* explicit dummy or actual arguments for 4D arrays */
75if ( q->mark == 0 ) {
76  fprintf(fp,"  num_%s, &\n",q->name) ;
77  for ( d = 3 ; d < q->ndims ; d++ ) {
78    char *colon, r[80],tx[80] ;
79    strcpy(r,"") ;
80    range_of_dimension(r,tx,d,q,du?"":"config_flags%") ;
81    colon = index(tx,':') ; *colon = '\0' ; 
82    if ( du ) { /* dummy args */
83      fprintf(fp,"%s_sdim%d,%s_edim%d, &\n",q->name,d-2,q->name,d-2) ;
84    } else {
85      fprintf(fp,"%s,%s,&\n",tx,colon+1) ;
86    }
87
88  }
89  q->mark = 1 ;
90}
91fprintf(fp,"  %s, &\n",varref) ;
92                }
93                else
94                {
95/* declaration of dummy arguments for 4D arrays */
96if ( q->mark == 0 ) {
97  fprintf(fp,"  INTEGER, INTENT(IN) :: num_%s\n",q->name) ;
98  for ( d = 3 ; d < q->ndims ; d++ ) {
99    fprintf(fp,"  INTEGER, INTENT(IN) :: %s_sdim%d,%s_edim%d\n",q->name,d-2,q->name,d-2) ;
100  }
101
102  q->mark = 1 ;
103}
104  strcpy(moredims,"") ;
105  for ( d = 3 ; d < q->ndims ; d++ ) {
106    char temp[80] ;
107    sprintf(temp,",%s_sdim%d:%s_edim%d",q->name,d-2,q->name,d-2) ;
108    strcat(moredims,temp) ;
109  }
110  strcat(moredims,",") ;
111
112fprintf(fp,"  %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
113                     q->type->name , varref , moredims, q->name ) ;
114                }
115              }
116              else
117              {
118                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
119              }
120            }
121            else if ( q->node_kind & I1 )
122            {
123              if ( ad == 0 ) 
124              {
125/* explicit dummy or actual arguments for i1 arrays */
126fprintf(fp,"  %s, &\n",varref) ;
127              }
128              else
129              {
130/* declaration of dummy arguments for i1 arrays */
131              strcpy(tmp3,"") ;
132              dimspec=dimension_with_ranges( "grid%","(",-1,tmp3,q,")","" ) ;
133fprintf(fp,"  %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
134              }
135            }
136          }
137        }
138        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
139      }
140      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
141    }
142}
143
144int print_call_or_def( FILE * fp , node_t *p, char * callorsub, 
145                       char * commname, char * communicator, 
146                       int need_config_flags )
147  {
148  fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ;
149  if (need_config_flags == 1)
150    fprintf(fp,"  config_flags, &\n") ;
151  print_4d_i1_decls( fp, p, 0, (!strcmp("CALL",callorsub))?0:1 );
152  fprintf(fp,"  %s, &\n",communicator) ;
153  fprintf(fp,"  mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
154  fprintf(fp,"  ids, ide, jds, jde, kds, kde,       &\n") ;
155  fprintf(fp,"  ims, ime, jms, jme, kms, kme,       &\n") ;
156  fprintf(fp,"  ips, ipe, jps, jpe, kps, kpe )\n") ;
157  return(0) ;
158  }
159
160int print_decl( FILE * fp , node_t *p, char * communicator, 
161                int need_config_flags )
162  {
163  fprintf(fp,"  USE module_domain, ONLY:domain\n") ;
164  fprintf(fp,"  USE module_configure, ONLY:grid_config_rec_type,in_use_for_config\n") ;
165  fprintf(fp,"  USE module_state_description, ONLY:PARAM_FIRST_SCALAR\n") ;
166  fprintf(fp,"  USE module_driver_constants\n") ;
167  fprintf(fp,"  TYPE(domain) ,               INTENT(IN) :: grid\n") ;
168  if (need_config_flags == 1) 
169    fprintf(fp,"  TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags\n") ;
170  print_4d_i1_decls( fp, p, 1, 0 );
171  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: %s\n",communicator) ;
172  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: mytask, ntasks, ntasks_x, ntasks_y\n") ;
173  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ids, ide, jds, jde, kds, kde\n") ;
174  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ims, ime, jms, jme, kms, kme\n") ;
175  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe\n") ;
176  fprintf(fp,"  INTEGER :: itrace\n") ;
177  fprintf(fp,"  INTEGER :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p\n") ;
178  fprintf(fp,"  INTEGER :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m\n") ;
179  fprintf(fp,"  LOGICAL, EXTERNAL :: rsl_comm_iter\n") ;
180  fprintf(fp,"  INTEGER :: idim1, idim2, idim3, idim4, idim5, idim6, idim7\n") ;
181  }
182
183int print_body( FILE * fp, char * commname )
184  {
185  fprintf(fp,\n") ;
186  fprintf(fp,"#ifdef DM_PARALLEL\n") ;
187  fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ;
188  fprintf(fp,"#endif\n") ;
189  fprintf(fp,\n") ;
190  fprintf(fp,"  END SUBROUTINE %s_sub\n",commname) ;
191  }
192
193int
194gen_halos ( char * dirname , char * incname , node_t * halos, int split )
195{
196  node_t * p, * q ;
197  node_t * dimd ;
198  char commname[NAMELEN], subs_fname[NAMELEN] ;
199  char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
200  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
201  char commuse[NAMELEN] ;
202#define MAX_VDIMS 100
203  char vdims[MAX_VDIMS][2][80] ;
204  char s[NAMELEN], e[NAMELEN] ;
205  int vdimcurs ;
206  int maxstenwidth_int, stenwidth ;
207  char maxstenwidth[NAMELEN] ;
208  FILE * fp ;
209  FILE * fpcall ;
210  FILE * fpsub ;
211  char * t1, * t2 ;
212  char * pos1 , * pos2 ;
213  char indices[NAMELEN], post[NAMELEN] ;
214  int zdex ;
215  int n2dR, n3dR ;
216  int n2dI, n3dI ;
217  int n2dD, n3dD ;
218  int n4d ;
219  int i, foundvdim ;
220  int subgrid ;
221  int need_config_flags;
222#define MAX_4DARRAYS 1000
223  char name_4d[MAX_4DARRAYS][NAMELEN] ;
224#define FRAC 4
225  int num_halos, fraction, ihalo, j ;
226
227  if ( dirname == NULL ) return(1) ;
228
229  if ( split ) {
230    for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) {  /* howmany deez guys? */
231      if ( incname == NULL ) {
232        strcpy( commname, p->name ) ;
233        make_upper_case(commname) ;
234      }
235      else {
236        strcpy( commname, incname ) ;
237      }
238      if ( !(   !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN"    )
239             || !strcmp(commname,"HALO_INTERP_UP"  ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) {
240        num_halos++ ;
241      }
242    } 
243  } 
244
245  ihalo = 0 ;
246  for ( p = halos ; p != NULL ; p = p->next )
247  {
248    need_config_flags = 0;  /* 0 = do not need, 1 = need */
249    if ( incname == NULL ) {
250      strcpy( commname, p->name ) ;
251      make_upper_case(commname) ;
252    } 
253    else {
254      strcpy( commname, incname ) ;
255    }
256    if ( incname == NULL ) {
257      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
258      else                       { sprintf(fname,"%s_inline.inc",commname) ; }
259      /* Generate call to custom routine that encapsulates inlined comm calls */
260      if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
261      else                       { sprintf(fnamecall,"%s.inc",commname) ; }
262      if ((fpcall = fopen( fnamecall , "w" )) == NULL ) 
263      {
264        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall ) ;
265        continue ; 
266      }
267      print_warning(fpcall,fnamecall) ;
268
269      if (   !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN") 
270          || !strcmp(commname,"HALO_INTERP_UP"  ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) {
271         sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ;
272      } else {
273         if ( split ) {
274           j = ihalo / ((num_halos+1)/FRAC+1) ;  /* the compiler you save may be your own */
275           sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ;
276           ihalo++ ;
277         } else {
278           sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ;
279         }
280      }
281
282      /* Generate definition of custom routine that encapsulates inlined comm calls */
283      if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; }
284      else                       { sprintf(fnamesub,"%s",subs_fname) ; }
285      if ((fpsub = fopen( fnamesub , "a" )) == NULL ) 
286      {
287        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
288        continue ; 
289      }
290      print_warning(fpsub,fnamesub) ;
291    }
292    else {
293      /* for now, retain original behavior when called from gen_shift */
294      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
295      else                       { sprintf(fname,"%s.inc",commname) ; }
296    }
297    /* Generate inlined comm calls */
298    if ((fp = fopen( fname , "w" )) == NULL ) 
299    {
300      fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
301      continue ; 
302    }
303    /* get maximum stencil width */
304    maxstenwidth_int = 0 ;
305    strcpy( tmp, p->comm_define ) ;
306    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
307    while ( t1 != NULL )
308    {
309      strcpy( tmp2 , t1 ) ;
310      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
311       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
312if ( !strcmp(t2,"SHW") ) {
313   stenwidth = -99 ;
314   maxstenwidth_int = -99 ;   /* use a run-time computed stencil width based on nest ratio */
315   break ;                /* note that SHW is set internally by gen_shift, it should never be used in a Registry file */
316} else {
317      stenwidth = atoi (t2) ;
318      if ( stenwidth == 0 )
319       { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
320      if      ( stenwidth == 4   || stenwidth == 8  ) stenwidth = 1 ;
321      else if ( stenwidth == 12  || stenwidth == 24 ) stenwidth = 2 ;
322      else if ( stenwidth == 48 ) stenwidth = 3 ;
323      else if ( stenwidth == 80 ) stenwidth = 4 ;
324      else if ( stenwidth == 120 ) stenwidth = 5 ;
325      else if ( stenwidth == 168 ) stenwidth = 6 ;
326      else
327       { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
328      if ( stenwidth > maxstenwidth_int ) maxstenwidth_int = stenwidth ;
329}
330      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
331    }
332
333    if ( maxstenwidth_int == -99 ) {
334      sprintf(maxstenwidth,"grid%%parent_grid_ratio") ;
335    } else {
336      sprintf(maxstenwidth,"%d",maxstenwidth_int) ;
337    }
338
339    print_warning(fp,fname) ;
340
341fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
342
343/* count up the number of 2d and 3d real arrays and their types */
344    n2dR = 0 ; n3dR = 0 ;
345    n2dI = 0 ; n3dI = 0 ;
346    n2dD = 0 ; n3dD = 0 ;
347    n4d = 0 ;
348    vdimcurs = 0 ;
349    subgrid = -1 ;      /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
350    strcpy( tmp, p->comm_define ) ;
351    strcpy( commuse, p->use ) ;
352    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
353    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
354    while ( t1 != NULL )
355    {
356      strcpy( tmp2 , t1 ) ;
357      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
358       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
359      t2 = strtok_rentr(NULL,",", &pos2) ;
360      while ( t2 != NULL )
361      {
362        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
363          { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
364        else
365        {
366          if ( subgrid == -1 ) {   /* first one */
367            subgrid = q->subgrid ;
368          } else if ( subgrid != q->subgrid ) {
369            fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
370          }
371          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
372            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of halo exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
373          else if ( q->boundary_array )
374            { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
375          else
376          {
377
378            /* 20061004 -- collect all the vertical dimensions so we can use a MAX
379               on them when calling RSL_LITE_INIT_EXCH */
380
381            if ( q->ndims == 3 || q->node_kind & FOURD ) {
382              if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
383                zdex = get_index_for_coord( q , COORD_Z ) ;
384                if      ( dimd->len_defined_how == DOMAIN_STANDARD ) { 
385                  strcpy(s,"kps") ;
386                  strcpy(e,"kpe") ;
387                }
388                else if ( dimd->len_defined_how == NAMELIST ) {
389                  need_config_flags = 1;
390                  if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
391                    strcpy(s,"1") ;
392                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
393                  } else {
394                    sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
395                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
396                  }
397                }
398                else if ( dimd->len_defined_how == CONSTANT ) {
399                  sprintf(s,"%d",dimd->coord_start) ;
400                  sprintf(e,"%d",dimd->coord_end) ; 
401                }
402                for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
403                  if ( !strcmp( vdims[i][1], e ) ) {
404                    foundvdim = 1 ; break ;
405                  }
406                }
407                if ( ! foundvdim ) {
408                  if (vdimcurs < 100 ) {
409                    strcpy( vdims[vdimcurs][0], s ) ;
410                    strcpy( vdims[vdimcurs][1], e ) ;
411                    vdimcurs++ ;
412                  } else {
413                    fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
414                    fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
415                    fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
416                    exit(5) ;
417                  }
418                }
419              }
420            }
421
422            if ( q->node_kind & FOURD ) {
423              if ( n4d < MAX_4DARRAYS ) {
424                int d ;
425                char temp[80], tx[80], r[10], *colon ;
426                strcpy( name_4d[n4d], q->name ) ;
427                for ( d = 3 ; d < q->ndims ; d++ ) {
428                  sprintf(temp,"*(%s_edim%d-%s_sdim%d+1)",q->name,d-2,q->name,d-2) ;
429                  strcat( name_4d[n4d],temp) ;
430                }
431              } else { 
432                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
433                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
434                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
435                exit(5) ;
436              }
437              n4d++ ;
438            }
439            else
440            {
441              if        ( ! strcmp( q->type->name, "real") ) {
442                if         ( q->ndims == 3 )      { n3dR++ ; }
443                else    if ( q->ndims == 2 )      { n2dR++ ; }
444              } else if ( ! strcmp( q->type->name, "integer") ) {
445                if         ( q->ndims == 3 )      { n3dI++ ; }
446                else    if ( q->ndims == 2 )      { n2dI++ ; }
447              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
448                if         ( q->ndims == 3 )      { n3dD++ ; }
449                else    if ( q->ndims == 2 )      { n2dD++ ; }
450              }
451            }
452          }
453        }
454        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
455      }
456      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
457    }
458
459/* generate the stencil init statement for Y transfer */
460#if 0
461fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxstenwidth,fname) ;
462#endif
463    if ( subgrid != 0 ) {
464      fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
465    }
466
467    fprintf(fp,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
468    fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ; 
469    fprintf(fp,"                         0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
470    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
471    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p    ))\n" ) ;
472    fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
473    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
474    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p,   & \n" ) ;
475    if ( n4d > 0 ) {
476      fprintf(fp,  "     %d  &\n", n3dR ) ;
477      for ( i = 0 ; i < n4d ; i++ ) {
478        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
479      }
480      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
481    } else {
482      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
483    }
484    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
485    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
486    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
487    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
488    if ( subgrid == 0 ) {
489      fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
490      for ( i = 0 ; i < vdimcurs ; i++ ) {
491        fprintf(fp,",%s &\n",vdims[i][1] ) ;
492      }
493      fprintf(fp,"))\n") ;
494    } else {
495      fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
496    }
497
498/* generate packs prior to stencil exchange in Y */
499    gen_packs_halo( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ;
500/* generate stencil exchange in Y */
501    fprintf(fp,"   CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
502    fprintf(fp,"                          rsl_sendw_m,  rsl_sendw_p, rsl_recvw_m,  rsl_recvw_p    )\n" ) ;
503/* generate unpacks after stencil exchange in Y */
504    gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
505    fprintf(fp,"ENDDO\n") ; 
506
507/* generate the stencil init statement for X transfer */
508    fprintf(fp,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
509    fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ; 
510    fprintf(fp,"                         1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
511    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
512    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p    ))\n" ) ;
513    fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
514    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
515    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p,   & \n" ) ;
516    if ( n4d > 0 ) {
517      fprintf(fp,  "     %d  &\n", n3dR ) ;
518      for ( i = 0 ; i < n4d ; i++ ) {
519        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
520      }
521      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
522    } else {
523      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
524    }
525    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
526    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
527    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
528    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
529    if ( subgrid == 0 ) {
530      fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
531      for ( i = 0 ; i < vdimcurs ; i++ ) {
532        fprintf(fp,",%s &\n",vdims[i][1] ) ;
533      }
534      fprintf(fp,"))\n") ;
535    } else {
536      fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
537    }
538/* generate packs prior to stencil exchange in X */
539    gen_packs_halo( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ;
540/* generate stencil exchange in X */
541    fprintf(fp,"   CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
542    fprintf(fp,"                          rsl_sendw_m,  rsl_sendw_p, rsl_recvw_m,  rsl_recvw_p    )\n" ) ;
543/* generate unpacks after stencil exchange in X */
544    gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
545    fprintf(fp,"    ENDDO\n") ; 
546    if ( subgrid != 0 ) {
547      fprintf(fp,"ENDIF\n") ;
548    }
549    close_the_file(fp) ;
550    if ( incname == NULL ) {
551      /* Finish call to custom routine that encapsulates inlined comm calls */
552      print_call_or_def(fpcall, p, "CALL", commname, "local_communicator", need_config_flags );
553      close_the_file(fpcall) ;
554      /* Generate definition of custom routine that encapsulates inlined comm calls */
555      print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator", need_config_flags );
556      print_decl(fpsub, p, "local_communicator", need_config_flags );
557      print_body(fpsub, commname);
558      close_the_file(fpsub) ;
559    }
560  }
561  return(0) ;
562}
563
564gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )   
565{
566  node_t * q ;
567  node_t * dimd ;
568  char fname[NAMELEN] ;
569  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
570  char commuse[NAMELEN] ;
571  int maxstenwidth, stenwidth ;
572  char * t1, * t2 , *wordsize ;
573  char varref[NAMELEN] ;
574  char varname[NAMELEN] ;
575  char * pos1 , * pos2 ;
576  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
577  int xdex,ydex,zdex ;
578
579    strcpy( tmp, p->comm_define ) ;
580    strcpy( commuse, p->use ) ;
581    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
582    while ( t1 != NULL )
583    {
584      strcpy( tmp2 , t1 ) ;
585      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
586       { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
587      t2 = strtok_rentr(NULL,",", &pos2) ;
588      while ( t2 != NULL )
589      {
590        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
591          { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
592        else
593        {
594
595          strcpy( varname, t2 ) ;
596          strcpy( varref, t2 ) ;
597          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
598             sprintf(varref,"grid%%%s",t2) ;
599          }
600
601          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
602          else if ( q->boundary_array ) { ; }
603          else
604          { 
605            if      ( ! strcmp( q->type->name, "real") )            { wordsize = "RWORDSIZE" ; }
606            else if ( ! strcmp( q->type->name, "integer") )         { wordsize = "IWORDSIZE" ; }
607            else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
608            if ( q->node_kind & FOURD )
609            {
610              node_t *member ;
611              zdex = get_index_for_coord( q , COORD_Z ) ;
612              if ( zdex >=1 && zdex <= 3 )
613              {
614                int d ;
615                char * colon ;
616                char moredims[80], tx[80], temp[10], r[80] ;
617                set_mem_order( q->members, memord , 3 ) ;
618fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
619                strcpy(moredims,"") ; 
620                for ( d = q->ndims-1 ; d >= 3  ; d-- ) {
621fprintf(fp,"  DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ;
622                }
623                for ( d = 3 ; d < q->ndims ; d++ ) {
624                  strcpy(r,"") ;
625                  range_of_dimension( r, tx, d, q, "config_flags%" ) ;
626                  colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ;
627                  sprintf(temp,"idim%d",d-2) ;
628                  strcat(moredims,",") ; strcat(moredims,temp) ;
629                }
630                strcat(moredims,",") ;
631                xdex = get_index_for_coord( q , COORD_X ) ;
632                ydex = get_index_for_coord( q , COORD_Y ) ;
633fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
634fprintf(fp,"  CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
635                       packname, commname, varref , moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
636fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
637if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
638     !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
639  fprintf(fp,"thisdomain_max_halo_width,                         &\n") ;
640}
641if ( q->subgrid == 0 ) {
642fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
643fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
644fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
645} else {
646fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
647fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
648fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
649}
650fprintf(fp," ENDIF\n") ;
651               for ( d = 3 ; d < q->ndims ; d++ ) {
652fprintf(fp,"  ENDDO ! idim%d \n",d-2 ) ;
653               }
654
655fprintf(fp,"ENDDO\n") ;
656              }
657              else
658              {
659                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
660              }
661            }
662            else
663            {
664              set_mem_order( q, memord , 3 ) ;
665              if       ( q->ndims == 3 ) {
666
667                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
668                xdex = get_index_for_coord( q , COORD_X ) ;
669                ydex = get_index_for_coord( q , COORD_Y ) ;
670                zdex = get_index_for_coord( q , COORD_Z ) ;
671                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
672                if ( dimd != NULL )
673                {
674                  char s[256], e[256] ;
675
676                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
677                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
678                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
679                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
680                    if ( q->subgrid == 0 ) {
681                      fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
682                      fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
683                      fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
684                    } else {
685fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
686fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
687fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
688                    }
689                  }
690                  else if ( dimd->len_defined_how == NAMELIST )
691                  {
692                    if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
693                      strcpy(s,"1") ;
694                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
695                    } else {
696                      sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
697                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
698                    }
699                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
700                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
701                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
702                    if ( q->subgrid == 0 ) {
703                      fprintf(fp,"ids, ide, jds, jde, %s, %s,             &\n",s,e) ;
704                      fprintf(fp,"ims, ime, jms, jme, %s, %s,             &\n",s,e) ;
705                      fprintf(fp,"ips, ipe, jps, jpe, %s, %s              )\n",s,e) ;
706                    } else {
707fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
708fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
709fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
710                    }
711                  }
712                  else if ( dimd->len_defined_how == CONSTANT )
713                  {
714                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
715                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
716                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
717                    if ( q->subgrid == 0 ) {
718                      fprintf(fp,"ids, ide, jds, jde, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
719                      fprintf(fp,"ims, ime, jms, jme, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
720                      fprintf(fp,"ips, ipe, jps, jpe, %d, %d              )\n",dimd->coord_start,dimd->coord_end) ;
721                    } else {
722fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
723fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
724fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
725                    }
726                  }
727                }
728                fprintf(fp,"ENDIF\n") ;
729              } else if ( q->ndims == 2 ) {
730                xdex = get_index_for_coord( q , COORD_X ) ;
731                ydex = get_index_for_coord( q , COORD_Y ) ;
732                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
733                fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
734                       packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
735                fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
736                if ( q->subgrid == 0 ) {
737                  fprintf(fp,"ids, ide, jds, jde, 1  , 1  ,             &\n") ;
738                  fprintf(fp,"ims, ime, jms, jme, 1  , 1  ,             &\n") ;
739                  fprintf(fp,"ips, ipe, jps, jpe, 1  , 1                )\n") ;
740                } else {
741fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
742fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
743fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
744                }
745                fprintf(fp,"ENDIF\n") ;
746              }
747            }
748          }
749         
750        }
751        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
752      }
753      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
754    }
755}
756
757gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )   
758{
759  node_t * q ;
760  node_t * dimd ;
761  char fname[NAMELEN] ;
762  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
763  char commuse[NAMELEN] ;
764  int maxstenwidth, stenwidth ;
765  char * t1, * t2 , *wordsize ;
766  char varref[NAMELEN] ;
767  char varname[NAMELEN] ;
768  char * pos1 , * pos2 ;
769  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
770  int xdex,ydex,zdex ;
771
772    strcpy( tmp, p->comm_define ) ;
773    strcpy( commuse, p->use ) ;
774    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
775    while ( t1 != NULL )
776    {
777      strcpy( tmp2 , t1 ) ;
778      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
779       { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
780      t2 = strtok_rentr(NULL,",", &pos2) ;
781      while ( t2 != NULL )
782      {
783        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
784          { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
785        else
786        {
787
788          strcpy( varname, t2 ) ;
789          strcpy( varref, t2 ) ;
790          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
791             sprintf(varref,"grid%%%s",t2) ;
792          }
793
794          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
795          else if ( q->boundary_array ) { ; }
796          else
797          { 
798            if      ( ! strcmp( q->type->name, "real") )            { wordsize = "RWORDSIZE" ; }
799            else if ( ! strcmp( q->type->name, "integer") )         { wordsize = "IWORDSIZE" ; }
800            else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
801            if ( q->node_kind & FOURD )
802            {
803              node_t *member ;
804              zdex = get_index_for_coord( q , COORD_Z ) ;
805              if ( zdex >=1 && zdex <= 3 )
806              {
807                set_mem_order( q->members, memord , 3 ) ;
808fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
809                xdex = get_index_for_coord( q , COORD_X ) ;
810                ydex = get_index_for_coord( q , COORD_Y ) ;
811fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
812fprintf(fp,"  CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n",
813                       packname, commname, varref , shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
814fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
815if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
816     !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
817  fprintf(fp,"thisdomain_max_halo_width,                         &\n") ;
818}
819if ( q->subgrid == 0 ) {
820fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
821fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
822fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
823} else {
824fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
825fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
826fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
827}
828fprintf(fp," ENDIF\n") ;
829fprintf(fp,"ENDDO\n") ;
830              }
831              else
832              {
833                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
834              }
835            }
836            else
837            {
838              set_mem_order( q, memord , 3 ) ;
839              if       ( q->ndims == 3 ) {
840
841                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
842                xdex = get_index_for_coord( q , COORD_X ) ;
843                ydex = get_index_for_coord( q , COORD_Y ) ;
844                zdex = get_index_for_coord( q , COORD_Z ) ;
845                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
846                if ( dimd != NULL )
847                {
848                  char s[256], e[256] ;
849
850                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
851                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
852                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
853                    if ( q->subgrid == 0 ) {
854                      fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
855                      fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
856                      fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
857                    } else {
858fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
859fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
860fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
861                    }
862                  }
863                  else if ( dimd->len_defined_how == NAMELIST )
864                  {
865                    if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
866                      strcpy(s,"1") ;
867                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
868                    } else {
869                      sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
870                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
871                    }
872                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
873                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
874                    if ( q->subgrid == 0 ) {
875                      fprintf(fp,"ids, ide, jds, jde, %s, %s,             &\n",s,e) ;
876                      fprintf(fp,"ims, ime, jms, jme, %s, %s,             &\n",s,e) ;
877                      fprintf(fp,"ips, ipe, jps, jpe, %s, %s              )\n",s,e) ;
878                    } else {
879fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
880fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
881fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
882                    }
883                  }
884                  else if ( dimd->len_defined_how == CONSTANT )
885                  {
886                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
887                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
888                    if ( q->subgrid == 0 ) {
889                      fprintf(fp,"ids, ide, jds, jde, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
890                      fprintf(fp,"ims, ime, jms, jme, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
891                      fprintf(fp,"ips, ipe, jps, jpe, %d, %d              )\n",dimd->coord_start,dimd->coord_end) ;
892                    } else {
893fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
894fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
895fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
896                    }
897                  }
898                }
899                fprintf(fp,"ENDIF\n") ;
900              } else if ( q->ndims == 2 ) {
901                xdex = get_index_for_coord( q , COORD_X ) ;
902                ydex = get_index_for_coord( q , COORD_Y ) ;
903                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
904                fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
905                fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
906                if ( q->subgrid == 0 ) {
907                  fprintf(fp,"ids, ide, jds, jde, 1  , 1  ,             &\n") ;
908                  fprintf(fp,"ims, ime, jms, jme, 1  , 1  ,             &\n") ;
909                  fprintf(fp,"ips, ipe, jps, jpe, 1  , 1                )\n") ;
910                } else {
911fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
912fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
913fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
914                }
915                fprintf(fp,"ENDIF\n") ;
916              }
917            }
918          }
919         
920        }
921        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
922      }
923      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
924    }
925}
926
927int
928gen_periods ( char * dirname , node_t * periods )
929{
930  node_t * p, * q ;
931  node_t * dimd ;
932  char commname[NAMELEN] ;
933  char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
934  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
935  char commuse[NAMELEN] ;
936  int maxperwidth, perwidth ;
937  FILE * fp ;
938  FILE * fpcall ;
939  FILE * fpsub ;
940  char * t1, * t2 ;
941  char varref[NAMELEN] ;
942  char * pos1 , * pos2 ;
943  char indices[NAMELEN], post[NAMELEN] ;
944  int zdex ;
945  int n2dR, n3dR ;
946  int n2dI, n3dI ;
947  int n2dD, n3dD ;
948  int n4d ;
949  int i ;
950#define MAX_4DARRAYS 1000
951  char name_4d[MAX_4DARRAYS][NAMELEN] ;
952
953  if ( dirname == NULL ) return(1) ;
954
955  /* Open and truncate REGISTRY_COMM_DM_PERIOD_subs.inc so file exists even if there are no periods. */
956  if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
957  else                       { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
958  if ((fpsub = fopen( fnamesub , "w" )) == NULL ) 
959  {
960    fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
961  }
962  if ( fpsub != NULL ) {
963    print_warning(fpsub,fnamesub) ;
964    fclose(fpsub) ;
965  }
966
967  for ( p = periods ; p != NULL ; p = p->next )
968  {
969    strcpy( commname, p->name ) ;
970    make_upper_case(commname) ;
971    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
972    else                       { sprintf(fname,"%s_inline.inc",commname) ; }
973    /* Generate call to custom routine that encapsulates inlined comm calls */
974    if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
975    else                       { sprintf(fnamecall,"%s.inc",commname) ; }
976    if ((fpcall = fopen( fnamecall , "w" )) == NULL ) 
977    {
978      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
979      continue ; 
980    }
981    print_warning(fpcall,fnamecall) ;
982    print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
983    close_the_file(fpcall) ;
984
985    /* Generate definition of custom routine that encapsulates inlined comm calls */
986    if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
987    else                       { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
988    if ((fpsub = fopen( fnamesub , "a" )) == NULL ) 
989    {
990      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
991      continue ; 
992    }
993    print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
994    print_decl(fpsub, p, "local_communicator_periodic", 1 );
995    print_body(fpsub, commname);
996    close_the_file(fpsub) ;
997
998    /* Generate inlined comm calls */
999    if ((fp = fopen( fname , "w" )) == NULL ) 
1000    {
1001      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
1002      continue ; 
1003    }
1004    /* get maximum period width */
1005    maxperwidth = 0 ;
1006    strcpy( tmp, p->comm_define ) ;
1007    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1008    while ( t1 != NULL )
1009    {
1010      strcpy( tmp2 , t1 ) ;
1011      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1012       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
1013      perwidth = atoi (t2) ;
1014      if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
1015      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1016    }
1017    print_warning(fp,fname) ;
1018
1019fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1020
1021/* count up the number of 2d and 3d real arrays and their types */
1022    n2dR = 0 ; n3dR = 0 ;
1023    n2dI = 0 ; n3dI = 0 ;
1024    n2dD = 0 ; n3dD = 0 ;
1025    n4d = 0 ;
1026    strcpy( tmp, p->comm_define ) ;
1027    strcpy( commuse, p->use ) ;
1028    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1029    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
1030    while ( t1 != NULL )
1031    {
1032      strcpy( tmp2 , t1 ) ;
1033      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1034       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1035      t2 = strtok_rentr(NULL,",", &pos2) ;
1036      while ( t2 != NULL )
1037      {
1038        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1039          { fprintf(stderr,"WARNING 1 : %s in period spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1040        else
1041        {
1042          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1043            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of period exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
1044          else if ( q->boundary_array )
1045            { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
1046          else
1047          {
1048            if ( q->node_kind & FOURD ) {
1049              if ( n4d < MAX_4DARRAYS ) {
1050                strcpy( name_4d[n4d], q->name ) ;
1051              } else { 
1052                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1053                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1054                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1055                exit(5) ;
1056              }
1057              n4d++ ;
1058            }
1059            else
1060            {
1061              if        ( ! strcmp( q->type->name, "real") ) {
1062                if         ( q->ndims == 3 )      { n3dR++ ; }
1063                else    if ( q->ndims == 2 )      { n2dR++ ; }
1064              } else if ( ! strcmp( q->type->name, "integer") ) {
1065                if         ( q->ndims == 3 )      { n3dI++ ; }
1066                else    if ( q->ndims == 2 )      { n2dI++ ; }
1067              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1068                if         ( q->ndims == 3 )      { n3dD++ ; }
1069                else    if ( q->ndims == 2 )      { n2dD++ ; }
1070              }
1071            }
1072          }
1073        }
1074        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1075      }
1076      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1077    }
1078
1079    fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
1080
1081/* generate the stencil init statement for X transfer */
1082    fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1083    if ( n4d > 0 ) {
1084      fprintf(fp,  "     %d  &\n", n3dR ) ;
1085      for ( i = 0 ; i < n4d ; i++ ) {
1086        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
1087      }
1088      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
1089    } else {
1090      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1091    }
1092    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1093    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1094    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
1095    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
1096    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
1097/* generate packs prior to exchange in X */
1098    gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1099/* generate exchange in X */
1100    fprintf(fp,"   CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1101/* generate unpacks after exchange in X */
1102    gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1103    fprintf(fp,"END IF\n") ;
1104
1105
1106    fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
1107/* generate the init statement for Y transfer */
1108    fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1109    if ( n4d > 0 ) {
1110      fprintf(fp,  "     %d  &\n", n3dR ) ;
1111      for ( i = 0 ; i < n4d ; i++ ) {
1112        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
1113      }
1114      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
1115    } else {
1116      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1117    }
1118    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1119    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1120    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
1121    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
1122    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
1123/* generate packs prior to exchange in Y */
1124    gen_packs( fp, p, maxperwidth, 0, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ; 
1125/* generate exchange in Y */
1126    fprintf(fp,"   CALL RSL_LITE_EXCH_PERIOD_Y ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1127/* generate unpacks after exchange in Y */
1128    gen_packs( fp, p, maxperwidth, 0, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ; 
1129    fprintf(fp,"END IF\n") ;
1130
1131    close_the_file(fp) ;
1132  }
1133  return(0) ;
1134}
1135
1136int
1137gen_swaps ( char * dirname , node_t * swaps )
1138{
1139  node_t * p, * q ;
1140  node_t * dimd ;
1141  char commname[NAMELEN] ;
1142  char fname[NAMELEN] ;
1143  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1144  char commuse[NAMELEN] ;
1145  FILE * fp ;
1146  char * t1, * t2 ;
1147  char * pos1 , * pos2 ;
1148  char indices[NAMELEN], post[NAMELEN] ;
1149  int zdex ;
1150  int n2dR, n3dR ;
1151  int n2dI, n3dI ;
1152  int n2dD, n3dD ;
1153  int n4d ;
1154  int i, xy ;
1155#define MAX_4DARRAYS 1000
1156  char name_4d[MAX_4DARRAYS][NAMELEN] ;
1157
1158  if ( dirname == NULL ) return(1) ;
1159
1160  for ( p = swaps ; p != NULL ; p = p->next )
1161  {
1162    strcpy( commname, p->name ) ;
1163    make_upper_case(commname) ;
1164    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
1165    else                       { sprintf(fname,"%s.inc",commname) ; }
1166    if ((fp = fopen( fname , "w" )) == NULL ) 
1167    {
1168      fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
1169      continue ; 
1170    }
1171    print_warning(fp,fname) ;
1172
1173  for ( xy = 0 ; xy < 2 ; xy++ ) {
1174
1175fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1176
1177/* count up the number of 2d and 3d real arrays and their types */
1178    n2dR = 0 ; n3dR = 0 ;
1179    n2dI = 0 ; n3dI = 0 ;
1180    n2dD = 0 ; n3dD = 0 ;
1181    n4d = 0 ;
1182    strcpy( tmp, p->comm_define ) ;
1183    strcpy( commuse, p->use ) ;
1184    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1185    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
1186    while ( t1 != NULL )
1187    {
1188      strcpy( tmp2 , t1 ) ;
1189      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1190       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1191      t2 = strtok_rentr(NULL,",", &pos2) ;
1192      while ( t2 != NULL )
1193      {
1194        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1195          { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1196        else
1197        {
1198          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1199            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of swaps exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
1200          else if ( q->boundary_array )
1201            { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
1202          else
1203          {
1204            if ( q->node_kind & FOURD ) {
1205              if ( n4d < MAX_4DARRAYS ) {
1206                strcpy( name_4d[n4d], q->name ) ;
1207              } else { 
1208                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1209                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1210                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1211                exit(5) ;
1212              }
1213              n4d++ ;
1214            }
1215            else
1216            {
1217              if        ( ! strcmp( q->type->name, "real") ) {
1218                if         ( q->ndims == 3 )      { n3dR++ ; }
1219                else    if ( q->ndims == 2 )      { n2dR++ ; }
1220              } else if ( ! strcmp( q->type->name, "integer") ) {
1221                if         ( q->ndims == 3 )      { n3dI++ ; }
1222                else    if ( q->ndims == 2 )      { n2dI++ ; }
1223              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1224                if         ( q->ndims == 3 )      { n3dD++ ; }
1225                else    if ( q->ndims == 2 )      { n2dD++ ; }
1226              }
1227            }
1228          }
1229        }
1230        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1231      }
1232      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1233    }
1234
1235    fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
1236
1237/* generate the init statement for X swap */
1238    fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
1239    if ( n4d > 0 ) {
1240      fprintf(fp,  "     %d  &\n", n3dR ) ;
1241      for ( i = 0 ; i < n4d ; i++ ) {
1242        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
1243      }
1244      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
1245    } else {
1246      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1247    }
1248    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1249    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1250    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
1251    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
1252    fprintf(fp,"      thisdomain_max_halo_width, &\n" ) ;
1253    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
1254    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
1255/* generate packs prior to stencil exchange  */
1256    gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1257/* generate stencil exchange in X */
1258    fprintf(fp,"   CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1259/* generate unpacks after stencil exchange  */
1260    gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1261
1262    fprintf(fp,"END IF\n") ;
1263
1264  }
1265    close_the_file(fp) ;
1266  }
1267  return(0) ;
1268}
1269
1270int
1271gen_cycles ( char * dirname , node_t * cycles )
1272{
1273  node_t * p, * q ;
1274  node_t * dimd ;
1275  char commname[NAMELEN] ;
1276  char fname[NAMELEN] ;
1277  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1278  char commuse[NAMELEN] ;
1279  FILE * fp ;
1280  char * t1, * t2 ;
1281  char * pos1 , * pos2 ;
1282  char indices[NAMELEN], post[NAMELEN] ;
1283  int zdex ;
1284  int n2dR, n3dR ;
1285  int n2dI, n3dI ;
1286  int n2dD, n3dD ;
1287  int n4d ;
1288  int i, xy, inout ;
1289#define MAX_4DARRAYS 1000
1290  char name_4d[MAX_4DARRAYS][NAMELEN] ;
1291
1292  if ( dirname == NULL ) return(1) ;
1293
1294  for ( p = cycles ; p != NULL ; p = p->next )
1295  {
1296    strcpy( commname, p->name ) ;
1297    make_upper_case(commname) ;
1298    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
1299    else                       { sprintf(fname,"%s.inc",commname) ; }
1300    if ((fp = fopen( fname , "w" )) == NULL ) 
1301    {
1302      fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
1303      continue ; 
1304    }
1305
1306    /* get inout */
1307    inout = 0 ;
1308    strcpy( tmp, p->comm_define ) ;
1309    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1310    strcpy( tmp2 , t1 ) ;
1311    if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1312       { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
1313    inout = atoi (t2) ;
1314
1315    print_warning(fp,fname) ;
1316
1317  for ( xy = 0 ; xy < 2 ; xy++ ) {
1318
1319fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1320
1321/* count up the number of 2d and 3d real arrays and their types */
1322    n2dR = 0 ; n3dR = 0 ;
1323    n2dI = 0 ; n3dI = 0 ;
1324    n2dD = 0 ; n3dD = 0 ;
1325    n4d = 0 ;
1326    strcpy( tmp, p->comm_define ) ;
1327    strcpy( commuse, p->use ) ;
1328    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1329    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
1330    while ( t1 != NULL )
1331    {
1332      strcpy( tmp2 , t1 ) ;
1333      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1334       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1335      t2 = strtok_rentr(NULL,",", &pos2) ;
1336      while ( t2 != NULL )
1337      {
1338        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1339          { fprintf(stderr,"WARNING 1 : %s in cycle spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1340        else
1341        {
1342          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1343            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of cycles exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
1344          else if ( q->boundary_array )
1345            { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
1346          else
1347          {
1348            if ( q->node_kind & FOURD ) {
1349              if ( n4d < MAX_4DARRAYS ) {
1350                strcpy( name_4d[n4d], q->name ) ;
1351              } else { 
1352                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1353                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1354                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1355                exit(5) ;
1356              }
1357              n4d++ ;
1358            }
1359            else
1360            {
1361              if        ( ! strcmp( q->type->name, "real") ) {
1362                if         ( q->ndims == 3 )      { n3dR++ ; }
1363                else    if ( q->ndims == 2 )      { n2dR++ ; }
1364              } else if ( ! strcmp( q->type->name, "integer") ) {
1365                if         ( q->ndims == 3 )      { n3dI++ ; }
1366                else    if ( q->ndims == 2 )      { n2dI++ ; }
1367              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1368                if         ( q->ndims == 3 )      { n3dD++ ; }
1369                else    if ( q->ndims == 2 )      { n2dD++ ; }
1370              }
1371            }
1372          }
1373        }
1374        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1375      }
1376      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1377    }
1378
1379    fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
1380
1381/* generate the init statement for X swap */
1382    fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
1383    if ( n4d > 0 ) {
1384      fprintf(fp,  "     %d  &\n", n3dR ) ;
1385      for ( i = 0 ; i < n4d ; i++ ) {
1386        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
1387      }
1388      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
1389    } else {
1390      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1391    }
1392    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1393    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1394    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
1395    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
1396    fprintf(fp,"      thisdomain_max_halo_width,               &\n") ;
1397    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
1398    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
1399/* generate packs prior to stencil exchange  */
1400    gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
1401/* generate stencil exchange in X */
1402    fprintf(fp,"   CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1403/* generate unpacks after stencil exchange  */
1404    gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
1405
1406    fprintf(fp,"END IF\n") ;
1407
1408  }
1409    close_the_file(fp) ;
1410  }
1411  return(0) ;
1412}
1413
1414int
1415gen_xposes ( char * dirname )
1416{
1417  node_t * p, * q ;
1418  char commname[NAMELEN] ;
1419  char fname[NAMELEN] ;
1420  char tmp[4096], tmp2[4096], tmp3[4096] ;
1421  char commuse[4096] ;
1422  FILE * fp ;
1423  char * t1, * t2 ;
1424  char * pos1 , * pos2 ;
1425  char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
1426  char ** x ;
1427  char post[NAMELEN], varname[NAMELEN], memord[10] ;
1428  char indices_z[NAMELEN], varref_z[NAMELEN] ;
1429  char indices_x[NAMELEN], varref_x[NAMELEN] ;
1430  char indices_y[NAMELEN], varref_y[NAMELEN] ;
1431
1432  if ( dirname == NULL ) return(1) ;
1433
1434  for ( p = Xposes ; p != NULL ; p = p->next )
1435  {
1436    for ( x = xposedir ; *x ; x++ )
1437    {
1438      strcpy( commname, p->name ) ;
1439      make_upper_case(commname) ;
1440      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
1441      else                       { sprintf(fname,"%s_%s.inc",commname,*x) ; }
1442      if ((fp = fopen( fname , "w" )) == NULL ) 
1443      {
1444        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
1445        continue ; 
1446      }
1447
1448      print_warning(fp,fname) ;
1449
1450      strcpy( tmp, p->comm_define ) ;
1451      strcpy( commuse, p->use ) ;
1452      t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1453      while ( t1 != NULL )
1454      {
1455        strcpy( tmp2 , t1 ) ;
1456
1457/* Z array */
1458        t2 = strtok_rentr(tmp2,",", &pos2) ;
1459        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
1460         { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1461        strcpy( varref_z, t2 ) ;
1462        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
1463           sprintf(varref_z,"grid%%%s",t2) ;
1464        }
1465        if ( q->proc_orient != ALL_Z_ON_PROC ) 
1466         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1467        if ( q->ndims != 3 )
1468         { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1469        if ( q->boundary_array )
1470         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1471        strcpy (indices_z,"");
1472        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
1473        {
1474          sprintf(post,")") ;
1475          sprintf(indices_z, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1476        }
1477        if ( q->node_kind & FOURD ) {
1478           strcat( varref_z, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
1479        }
1480
1481/* X array */
1482        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1483        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
1484         { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1485        strcpy( varref_x, t2 ) ;
1486        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
1487           sprintf(varref_x,"grid%%%s",t2) ;
1488        }
1489        if ( q->proc_orient != ALL_X_ON_PROC ) 
1490         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1491        if ( q->ndims != 3 )
1492         { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1493        if ( q->boundary_array )
1494         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1495        strcpy (indices_x,"");
1496        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
1497        {
1498          sprintf(post,")") ;
1499          sprintf(indices_x, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1500        }
1501        if ( q->node_kind & FOURD ) {
1502           strcat( varref_x, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
1503        }
1504
1505/* Y array */
1506        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1507        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
1508         { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1509        strcpy( varref_y, t2 ) ;
1510        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
1511           sprintf(varref_y,"grid%%%s",t2) ;
1512        }
1513        if ( q->proc_orient != ALL_Y_ON_PROC ) 
1514         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1515        if ( q->ndims != 3 )
1516         { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1517        if ( q->boundary_array )
1518         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1519        strcpy (indices_y,"");
1520        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
1521        {
1522          sprintf(post,")") ;
1523          sprintf(indices_y, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1524        }
1525        if ( q->node_kind & FOURD ) {
1526           strcat( varref_y, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
1527        }
1528
1529        t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1530      }
1531      set_mem_order( q, memord , 3 ) ;
1532      if        ( !strcmp( *x , "z2x" ) ) {
1533        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1534        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
1535        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1536        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
1537        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
1538        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1539        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1540        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n"   ) ;
1541      } else if ( !strcmp( *x , "x2z" ) ) {
1542        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1543        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
1544        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1545        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
1546        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
1547        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1548        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1549        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n"   ) ;
1550      } else if ( !strcmp( *x , "x2y" ) ) {
1551        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1552        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1553        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1554        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1555        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
1556        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
1557        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
1558        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
1559      } else if ( !strcmp( *x , "y2x" ) ) {
1560        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1561        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1562        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1563        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1564        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
1565        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
1566        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
1567        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
1568      } else if ( !strcmp( *x , "y2z" ) ) {
1569        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1570        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1571        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1572        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1573        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
1574        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
1575        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
1576        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
1577        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1578        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
1579        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1580        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
1581        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
1582        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1583        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1584        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x)\n"   ) ;
1585      } else if ( !strcmp( *x , "z2y" ) ) {
1586        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1587        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
1588        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1589        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
1590        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
1591        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1592        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1593        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x )\n"   ) ;
1594        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1595        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
1596        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
1597        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
1598        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
1599        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
1600        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
1601        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
1602      }
1603
1604      close_the_file(fp) ;
1605    }
1606skiperific:
1607    ;
1608  }
1609  return(0) ;
1610}
1611
1612int
1613gen_comm_descrips ( char * dirname )
1614{
1615  node_t * p ;
1616  char * fn = "dm_comm_cpp_flags" ;
1617  char commname[NAMELEN] ;
1618  char fname[NAMELEN] ;
1619  FILE * fp ;
1620  int ncomm ;
1621
1622  if ( dirname == NULL ) return(1) ;
1623
1624  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
1625  else                       { sprintf(fname,"%s",fn) ; }
1626
1627  if ((fp = fopen( fname , "w" )) == NULL )
1628  {
1629    fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
1630  }
1631
1632  return(0) ;
1633}
1634
1635
1636
1637int
1638gen_shift (  char * dirname )
1639{
1640  int i ;
1641  FILE * fp ;
1642  node_t *p, *q, *dimd ;
1643  char **direction ;
1644  char *directions[] = { "x", "y", 0L } ;
1645  char fname[NAMELEN], vname[NAMELEN] ;
1646  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
1647  char memord[NAMELEN] ;
1648  int xdex,ydex,zdex ;
1649  node_t Shift ;
1650int said_it = 0 ;
1651int said_it2 = 0 ;
1652
1653  for ( direction = directions ; *direction != NULL ; direction++ )
1654  {
1655    if ( dirname == NULL ) return(1) ;
1656    if ( sw_unidir_shift_halo ) {
1657       sprintf(fname,"shift_halo",*direction) ;
1658    } else {
1659       sprintf(fname,"shift_halo_%s_halo",*direction) ;
1660    }
1661
1662    Shift.next = NULL ;
1663    sprintf( Shift.use, "" ) ;
1664    strcpy( Shift.comm_define, "SHW:" ) ;
1665    strcpy( Shift.name , fname ) ;
1666    if ( sw_move ) {
1667    for ( p = Domain.fields ; p != NULL ; p = p->next ) {
1668      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
1669      {
1670
1671/* special cases in WRF */
1672if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
1673     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
1674     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
1675  if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
1676                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
1677                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
1678  said_it = 1 ; }
1679  continue ;
1680}
1681
1682/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
1683/* also make sure we don't shift or halo any transpose variables (ALL_X_ON_PROC or ALL_Y_ON_PROC) */
1684        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) && 
1685             !(p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC) ) {
1686         
1687if ( p->subgrid != 0 ) {  /* moving nests not implemented for subgrid variables */
1688  if ( sw_move && ! said_it2 ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for subgrid variables \n") ;
1689  said_it2 = 1 ; }
1690  continue ;
1691}
1692          if ( p->type->type_type == SIMPLE )
1693          {
1694            for ( i = 1 ; i <= p->ntl ; i++ )
1695            {
1696              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
1697              else              sprintf(vname,"%s",p->name ) ;
1698              strcat( Shift.comm_define, vname ) ;
1699              strcat( Shift.comm_define, "," ) ;
1700            }
1701          }
1702        }
1703      }
1704    }
1705    if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
1706    }
1707
1708/* if unidir halo, then only generate on x pass */
1709    if ( ! ( sw_unidir_shift_halo && !strcmp(*direction,"y" ) ) ) {
1710      gen_halos( dirname , NULL, &Shift, 0 ) ;
1711    }
1712
1713    sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ;
1714    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1715
1716/* now generate the shifts themselves */
1717    if ( sw_move ) {
1718    for ( p = Domain.fields ; p != NULL ; p = p->next )
1719    {
1720
1721/* special cases in WRF */
1722if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
1723     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
1724     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
1725  continue ;
1726}
1727/* do not shift transpose variables */
1728if ( p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC ) continue ;
1729
1730      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
1731      {
1732
1733        if ( p->type->type_type == SIMPLE )
1734        {
1735          for ( i = 1 ; i <= p->ntl ; i++ )
1736          {
1737           
1738            if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
1739            else              sprintf(vname,"%s",p->name ) ;
1740
1741            if ( p->node_kind & FOURD )
1742            {
1743              node_t *member ;
1744
1745              xdex = get_index_for_coord( p , COORD_X ) ;
1746              ydex = get_index_for_coord( p , COORD_Y ) ;
1747              zdex = get_index_for_coord( p , COORD_Z ) ;
1748              if ( zdex >=1 && zdex <= 3 )
1749              {
1750                int d ; 
1751                char r[10], tx[80], temp[80], moredims[80], *colon ;
1752                set_mem_order( p->members, memord , 3 ) ;
1753fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
1754                for ( d = p->ndims-1; d >= 3 ; d-- ) {
1755                  strcpy(r,"") ;
1756                  range_of_dimension( r, tx, d, p, "config_flags%") ;
1757                  colon = index(tx,':') ; *colon = ',' ;
1758fprintf(fp, "  DO idim%d = %s\n", d-2, tx ) ;
1759                }
1760                strcpy(moredims,"") ;
1761                for ( d = 3 ; d < p->ndims ; d++ ) {
1762                  sprintf(temp,"idim%d",d-2) ;
1763                  strcat(moredims,",") ; strcat(moredims,temp) ;
1764                }
1765                strcat(moredims,",") ;
1766                if ( !strcmp( *direction, "x" ) )
1767                {
1768                  char * stag = "" ;
1769                  stag = p->members->stag_x?"":"-1" ;
1770                  if        ( !strncmp( memord , "XYZ", 3 ) ) {
1771                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1772                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1773                    fprintf(fp,"ENDIF\n") ;
1774                  } else if ( !strncmp( memord , "YXZ", 3 ) ) {
1775                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1776                    fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1777                    fprintf(fp,"ENDIF\n") ;
1778                  } else if ( !strncmp( memord , "XZY", 3 ) ) {
1779                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1780                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1781                    fprintf(fp,"ENDIF\n") ;
1782                  } else if ( !strncmp( memord , "YZX", 3 ) ) {
1783                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1784                    fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1785                    fprintf(fp,"ENDIF\n") ;
1786                  } else if ( !strncmp( memord , "ZXY", 3 ) ) {
1787                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1788                    fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1789                    fprintf(fp,"ENDIF\n") ;
1790                  } else if ( !strncmp( memord , "ZYX", 3 ) ) {
1791                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1792                    fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1793                    fprintf(fp,"ENDIF\n") ;
1794                  } else if ( !strncmp( memord , "XY", 2 ) ) {
1795                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1796                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1797                    fprintf(fp,"ENDIF\n") ;
1798                  } else if ( !strncmp( memord , "YX", 2 ) ) {
1799                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1800                    fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1801                    fprintf(fp,"ENDIF\n") ;
1802                  }
1803                }
1804                else
1805                {
1806                  char * stag = "" ;
1807                  stag = p->members->stag_y?"":"-1" ;
1808                  if        ( !strncmp( memord , "XYZ", 3 ) ) {
1809                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1810                    fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1811                    fprintf(fp,"ENDIF\n") ;
1812                  } else if ( !strncmp( memord , "YXZ", 3 ) ) {
1813                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1814                    fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1815                    fprintf(fp,"ENDIF\n") ;
1816                  } else if ( !strncmp( memord , "XZY", 3 ) ) {
1817                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1818                    fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1819                    fprintf(fp,"ENDIF\n") ;
1820                  } else if ( !strncmp( memord , "YZX", 3 ) ) {
1821                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1822                    fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1823                    fprintf(fp,"ENDIF\n") ;
1824                  } else if ( !strncmp( memord , "ZXY", 3 ) ) {
1825                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1826                    fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1827                    fprintf(fp,"ENDIF\n") ;
1828                  } else if ( !strncmp( memord , "ZYX", 3 ) ) {
1829                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1830                    fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1831                    fprintf(fp,"ENDIF\n") ;
1832                  } else if ( !strncmp( memord , "XY", 2 ) ) {
1833                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1834                    fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1835                    fprintf(fp,"ENDIF\n") ;
1836                  } else if ( !strncmp( memord , "YX", 2 ) ) {
1837                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1838                    fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
1839                    fprintf(fp,"ENDIF\n") ;
1840                  }
1841                }
1842                for ( d = p->ndims-1; d >= 3 ; d-- ) {
1843fprintf(fp, "  ENDDO\n" ) ;
1844                }
1845fprintf(fp, "  ENDDO\n" ) ;
1846              }
1847              else
1848              {
1849                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1850              }
1851            }
1852            else
1853            {
1854              xdex = get_index_for_coord( p , COORD_X ) ;
1855              ydex = get_index_for_coord( p , COORD_Y ) ;
1856              set_mem_order( p, memord , 3 ) ;
1857              if ( !strcmp( *direction, "x" ) ) {
1858                if        ( !strcmp( memord , "XYZ" ) ) {
1859                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1860                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1861                  fprintf(fp,"ENDIF\n") ;
1862                } else if ( !strcmp( memord , "YXZ" ) ) {
1863                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1864                  fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1865                  fprintf(fp,"ENDIF\n") ;
1866                } else if ( !strcmp( memord , "XZY" ) ) {
1867                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1868                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1869                  fprintf(fp,"ENDIF\n") ;
1870                } else if ( !strcmp( memord , "YZX" ) ) {
1871                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1872                  fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1873                  fprintf(fp,"ENDIF\n") ;
1874                } else if ( !strcmp( memord , "ZXY" ) ) {
1875                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1876                  fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1877                  fprintf(fp,"ENDIF\n") ;
1878                } else if ( !strcmp( memord , "ZYX" ) ) {
1879                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1880                  fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1881                  fprintf(fp,"ENDIF\n") ;
1882                } else if ( !strcmp( memord , "XY" ) ) {
1883                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1884                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1885                  fprintf(fp,"ENDIF\n") ;
1886                } else if ( !strcmp( memord , "YX" ) ) {
1887                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1888                  fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1889                  fprintf(fp,"ENDIF\n") ;
1890                }
1891              } else {
1892                if        ( !strcmp( memord , "XYZ" ) ) {
1893                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1894                  fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1895                  fprintf(fp,"ENDIF\n") ;
1896                } else if ( !strcmp( memord , "YXZ" ) ) {
1897                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1898                  fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1899                  fprintf(fp,"ENDIF\n") ;
1900                } else if ( !strcmp( memord , "XZY" ) ) {
1901                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1902                  fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1903                  fprintf(fp,"ENDIF\n") ;
1904                } else if ( !strcmp( memord , "YZX" ) ) {
1905                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1906                  fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1907                  fprintf(fp,"ENDIF\n") ;
1908                } else if ( !strcmp( memord , "ZXY" ) ) {
1909                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1910                  fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1911                  fprintf(fp,"ENDIF\n") ;
1912                } else if ( !strcmp( memord , "ZYX" ) ) {
1913                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1914                  fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1915                  fprintf(fp,"ENDIF\n") ;
1916                } else if ( !strcmp( memord , "XY" ) ) {
1917                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1918                  fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1919                  fprintf(fp,"ENDIF\n") ;
1920                } else if ( !strcmp( memord , "YX" ) ) {
1921                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
1922                  fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1923                  fprintf(fp,"ENDIF\n") ;
1924                }
1925              }
1926            }
1927          }
1928        }
1929      }
1930    }
1931    } /* if sw_move */
1932    close_the_file(fp) ;
1933  }
1934}
1935
1936int
1937gen_datacalls ( char * dirname )
1938{
1939  FILE * fp ;
1940  char * fn = "data_calls.inc" ;
1941  char fname[NAMELEN] ;
1942
1943  if ( dirname == NULL ) return(1) ;
1944  if ( strlen(dirname) > 0 )
1945   { sprintf(fname,"%s/%s",dirname,fn) ; }
1946  else
1947   { sprintf(fname,"%s",fn) ; }
1948  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1949  print_warning(fp,fname) ;
1950  close_the_file(fp) ;
1951  return(0) ;
1952}
1953
1954/*****************/
1955/*****************/
1956
1957gen_nest_packing ( char * dirname )
1958{
1959  gen_nest_pack( dirname ) ;
1960  gen_nest_unpack( dirname ) ;
1961}
1962
1963#define PACKIT 1
1964#define UNPACKIT 2
1965
1966int
1967gen_nest_pack ( char * dirname )
1968{
1969  int i ;
1970  FILE * fp ;
1971  char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
1972  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
1973  int ipath ;
1974  char ** fnp ; char * fn ;
1975  char * shw_str ;
1976  char fname[NAMELEN] ;
1977  node_t *node, *p, *dim ;
1978  int xdex, ydex, zdex ;
1979  char ddim[3][2][NAMELEN] ;
1980  char mdim[3][2][NAMELEN] ;
1981  char pdim[3][2][NAMELEN] ;
1982  char vname[NAMELEN] ; char tag[NAMELEN], fourd_names[NAMELEN_LONG] ;
1983  int d2, d3, sw ;
1984  char *info_name ;
1985
1986  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
1987  {
1988    fn = *fnp ;
1989      if ( dirname == NULL ) return(1) ;
1990      if ( strlen(dirname) > 0 ) {
1991        sprintf(fname,"%s/%s",dirname,fn) ;
1992      } else { 
1993        sprintf(fname,"%s",fn) ;
1994      }
1995      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1996      print_warning(fp,fname) ;
1997
1998      d2 = 0 ;
1999      d3 = 0 ;
2000      node = Domain.fields ;
2001
2002      count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ) ;
2003
2004      if ( d2 + d3 > 0 ) {
2005        if ( down_path[ipath] == INTERP_UP )
2006        {
2007          info_name = "rsl_lite_to_parent_info" ;
2008          sw = 0 ;
2009        }
2010        else
2011        {
2012          info_name = "rsl_lite_to_child_info" ;
2013          sw = 1 ;
2014        }
2015
2016        fprintf(fp,"msize = (%d + %s )* nlev + %d\n", d3, fourd_names, d2 ) ;
2017
2018        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
2019        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
2020if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
2021        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
2022if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
2023        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
2024        fprintf(fp,"                        ,thisdomain_max_halo_width                                  &\n") ;
2025        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
2026        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
2027        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
2028
2029        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2030 
2031        gen_nest_packunpack ( fp , Domain.fields, PACKIT, down_path[ipath] ) ;
2032
2033        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
2034        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
2035if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
2036        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
2037if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
2038        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
2039        fprintf(fp,"                        ,thisdomain_max_halo_width                                  &\n") ;
2040        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
2041        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
2042        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
2043
2044        fprintf(fp,"ENDDO\n") ;
2045      }
2046      close_the_file(fp) ;
2047  }
2048  return(0) ;
2049}
2050
2051int
2052gen_nest_unpack ( char * dirname )
2053{
2054  int i ;
2055  FILE * fp ;
2056  char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
2057  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
2058  int ipath ;
2059  char ** fnp ; char * fn ;
2060  char fname[NAMELEN] ;
2061  node_t *node, *p, *dim ;
2062  int xdex, ydex, zdex ;
2063  char ddim[3][2][NAMELEN] ;
2064  char mdim[3][2][NAMELEN] ;
2065  char pdim[3][2][NAMELEN] ;
2066  char *info_name ;
2067  char vname[NAMELEN] ; char tag[NAMELEN] ; char fourd_names[NAMELEN_LONG] ;
2068  int d2, d3 ;
2069
2070  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
2071  {
2072    fn = *fnp ;
2073      d2 = 0 ;
2074      d3 = 0 ;
2075      node = Domain.fields ;
2076
2077      if ( dirname == NULL ) return(1) ;
2078      if ( strlen(dirname) > 0 )
2079       { sprintf(fname,"%s/%s",dirname,fn) ; }
2080      else
2081       { sprintf(fname,"%s",fn) ; }
2082      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2083      print_warning(fp,fname) ;
2084
2085      count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ) ;
2086
2087      if ( d2 + d3 > 0 && strlen(fourd_names) > 0 ) {
2088        if ( down_path[ipath] == INTERP_UP )
2089        {
2090          info_name = "rsl_lite_from_child_info" ;
2091        }
2092        else
2093        {
2094          info_name = "rsl_lite_from_parent_info" ;
2095        }
2096
2097        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2098        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2099        gen_nest_packunpack ( fp , Domain.fields, UNPACKIT, down_path[ipath] ) ;
2100        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2101        fprintf(fp,"ENDDO\n") ;
2102      }
2103      close_the_file(fp) ;
2104  }
2105  return(0) ;
2106}
2107
2108int
2109gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path )
2110{
2111  int i, d1 ;
2112  node_t *p, *p1, *dim ;
2113  int d2, d3, xdex, ydex, zdex ;
2114  int nest_mask ;
2115  char * grid ; 
2116  char ddim[3][2][NAMELEN] ;
2117  char mdim[3][2][NAMELEN] ;
2118  char pdim[3][2][NAMELEN] ;
2119  char vname[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; 
2120  char tx[80], moredims[80], temp[80], r[10], *colon ;
2121  char c, d ;
2122
2123  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
2124  {
2125
2126    if ( p1->node_kind & FOURD )
2127    {
2128      if ( p1->members->next )
2129        nest_mask = p1->members->next->nest_mask ;
2130      else
2131        continue ;
2132    }
2133    else
2134    {
2135      nest_mask = p1->nest_mask ;
2136    }
2137    p = p1 ;
2138
2139    if ( nest_mask & down_path )
2140    {
2141        if ( p->node_kind & FOURD ) {
2142          if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
2143          else                             sprintf(tag,"") ;
2144          set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
2145          zdex = get_index_for_coord( p->members , COORD_Z ) ;
2146          xdex = get_index_for_coord( p->members , COORD_X ) ;
2147          ydex = get_index_for_coord( p->members , COORD_Y ) ;
2148        } else {
2149          if ( p->ntl > 1 ) sprintf(tag,"_2") ;
2150          else              sprintf(tag,"") ;
2151          set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
2152          zdex = get_index_for_coord( p , COORD_Z ) ;
2153          xdex = get_index_for_coord( p , COORD_X ) ;
2154          ydex = get_index_for_coord( p , COORD_Y ) ;
2155        }
2156
2157        if ( down_path == INTERP_UP )
2158        {
2159          c = ( dir == PACKIT )?'n':'p' ;
2160          d = ( dir == PACKIT )?'2':'1' ;
2161        } else {
2162          c = ( dir == UNPACKIT )?'n':'p' ;
2163          d = ( dir == UNPACKIT )?'2':'1' ;
2164        }
2165
2166        if ( zdex >= 0 ) {
2167          if      ( xdex == 0 && zdex == 1 && ydex == 2 )  sprintf(dexes,"pig,k,pjg") ;
2168          else if ( zdex == 0 && xdex == 1 && ydex == 2 )  sprintf(dexes,"k,pig,pjg") ;
2169          else if ( xdex == 0 && ydex == 1 && zdex == 2 )  sprintf(dexes,"pig,pjg,k") ;
2170        } else {
2171          if ( xdex == 0 && ydex == 1 )  sprintf(dexes,"pig,pjg") ;
2172          if ( ydex == 0 && xdex == 1 )  sprintf(dexes,"pjg,pig") ;
2173        }
2174
2175        /* construct variable name */
2176        if ( p->node_kind & FOURD )
2177        {
2178          strcpy(moredims,"") ;
2179          for ( d1 = 3 ; d1 < p->ndims ; d1++ ) {
2180             sprintf(temp,"idim%d",d1-2) ;
2181             strcat(moredims,",") ; strcat(moredims,temp) ;
2182          }
2183          strcat(moredims,",") ;
2184          sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
2185        }
2186        else
2187        {
2188          sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
2189        }
2190
2191        grid = "grid%" ;
2192        if ( p->node_kind & FOURD )
2193        {
2194           grid = "" ;
2195fprintf(fp,"DO itrace =  PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
2196           for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
2197             strcpy(r,"") ;
2198             range_of_dimension(r, tx, d1, p, "config_flags%" ) ;
2199             colon = index( tx, ':' ) ; *colon = ',' ; 
2200fprintf(fp,"DO idim%d = %s \n", d1-2, tx) ;
2201           }
2202        } else {
2203/* note that in the case if dir != UNPACKIT and down_path == INTERP_UP the data
2204   structure being used is intermediate_grid, not grid. However, intermediate_grid
2205   and grid share the same id (see module_dm.F) so it will not make a difference. */
2206#if 0
2207fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s%s') ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",p->name,tag) ;
2208#else
2209fprintf(fp,"IF ( SIZE(%s%s%s) .GT. 1 ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",grid,p->name,tag) ; 
2210#endif
2211        }
2212
2213        if ( dir == UNPACKIT ) 
2214        {
2215          if ( down_path == INTERP_UP )
2216          {
2217            char *sjl = "" ;
2218            if ( !strcmp( p->interpu_fcn_name ,"nmm_vfeedback") ) sjl = "_v" ; /* KLUDGE FOR NCEP NESTING 20071217 */
2219            if ( zdex >= 0 ) {
2220fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
2221            } else {
2222fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
2223            }
2224fprintf(fp,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
2225                 sjl ,
2226                 p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
2227            if ( zdex >= 0 ) {
2228fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], grid, vname ) ;
2229            } else {
2230fprintf(fp,"NEST_INFLUENCE(%s%s,xv(1))\n", grid, vname ) ;
2231            }
2232fprintf(fp,"ENDIF\n") ;
2233          }
2234          else
2235          {
2236            if ( zdex >= 0 ) {
2237fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
2238                                    ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname) ;
2239            } else {
2240fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname) ;
2241            }
2242          }
2243        }
2244        else
2245        {
2246          if ( down_path == INTERP_UP )
2247          {
2248            if ( zdex >= 0 ) {
2249fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
2250                           ddim[zdex][0], ddim[zdex][1], vname, ddim[zdex][1], ddim[zdex][0] ) ;
2251            } else {
2252fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname) ;
2253            }
2254          }
2255          else
2256          {
2257            if ( zdex >= 0 ) {
2258fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
2259                           ddim[zdex][0], ddim[zdex][1], grid, vname, ddim[zdex][1], ddim[zdex][0] ) ;
2260            } else {
2261fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname) ;
2262            }
2263          }
2264        }
2265        if ( p->node_kind & FOURD )
2266        {
2267           for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
2268fprintf(fp,"ENDDO\n") ;
2269           }
2270fprintf(fp,"ENDDO\n") ;
2271        }
2272        else
2273        {
2274fprintf(fp,"ENDIF\n") ; /* in_use_for_config */
2275        }
2276    }
2277  }
2278
2279  return(0) ;
2280}
2281
2282/*****************/
2283
2284/* STOPPED HERE -- need to include the extra dimensions in the count */
2285
2286int
2287count_fields ( node_t * node , int * d2 , int * d3 ,  char * fourd_names, int down_path )
2288{
2289  node_t * p ;
2290  int zdex ;
2291  char temp[80], r[10], tx[80], *colon ;
2292  int d ;
2293
2294  strcpy(fourd_names,"") ;  /* only works if non-recursive, but that is ifdefd out below */
2295/* count up the total number of levels from all fields */
2296  for ( p = node ;  p != NULL ; p = p->next )
2297  {
2298    if ( p->node_kind == FOURD ) 
2299    {
2300#if 0
2301      count_fields( p->members , d2 , d3 , down_path ) ;  /* RECURSE */
2302#else
2303      if ( strlen(fourd_names) > 0 ) strcat(fourd_names," & \n + ") ;
2304      sprintf(temp,"((num_%s - PARAM_FIRST_SCALAR + 1)",p->name) ;
2305      strcat(fourd_names,temp) ;
2306      for ( d = 3 ; d < p->ndims ; d++ ) {
2307        strcpy(r,"") ;
2308        range_of_dimension(r,tx,d,p,"config_flags%") ;
2309        colon = index(tx,':') ; *colon = '\0' ;
2310        sprintf(temp," &\n  *((%s)-(%s)+1)",colon+1,tx) ;
2311        strcat(fourd_names,temp) ;
2312      }
2313      strcat(fourd_names,")") ;
2314#endif
2315    }
2316    else
2317    {
2318      if ( p->nest_mask & down_path )
2319      {
2320          if ( p->node_kind == FOURD )
2321            zdex = get_index_for_coord( p->members , COORD_Z ) ;
2322          else
2323            zdex = get_index_for_coord( p , COORD_Z ) ;
2324 
2325          if ( zdex < 0 ) {
2326            (*d2)++ ;   /* if no zdex then only 2 d */
2327          } else {
2328            (*d3)++ ;   /* if has a zdex then 3 d */
2329          }
2330      }
2331    }
2332  }
2333  return(0) ;
2334}
2335
2336/*****************/
2337/*****************/
2338
2339int
2340gen_debug (  char * dirname )
2341{
2342  int i ;
2343  FILE * fp ;
2344  node_t *p, *q, *dimd ;
2345  char **direction ;
2346  char *directions[] = { "x", "y", 0L } ;
2347  char fname[NAMELEN], vname[NAMELEN] ;
2348  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
2349  int zdex ;
2350  node_t Shift ;
2351int said_it = 0 ;
2352int said_it2 = 0 ;
2353
2354    if ( dirname == NULL ) return(1) ;
2355
2356    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/debuggal.inc",dirname) ; }
2357    else                       { sprintf(fname,"debuggal.inc") ; }
2358    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2359
2360/* now generate the shifts themselves */
2361    for ( p = Domain.fields ; p != NULL ; p = p->next )
2362    {
2363
2364/* special cases in WRF */
2365if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
2366     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
2367     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
2368  continue ;
2369}
2370
2371      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
2372      {
2373
2374        if ( p->type->type_type == SIMPLE )
2375        {
2376          for ( i = 1 ; i <= p->ntl ; i++ )
2377          {
2378           
2379            if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2380            else              sprintf(vname,"%s",p->name ) ;
2381
2382            if ( p->node_kind & FOURD  )
2383            {
2384#if 0
2385              node_t *member ;
2386              zdex = get_index_for_coord( p , COORD_Z ) ;
2387              if ( zdex >=1 && zdex <= 3 && strncmp(vname,"fdda",4)  )
2388              {
2389fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
2390fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', itrace , %s ( IDEBUG,KDEBUG,JDEBUG,itrace)\n", vname, vname ) ;
2391fprintf(fp, "  ENDDO\n" ) ;
2392              }
2393              else
2394              {
2395                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
2396              }
2397#endif
2398            }
2399            else
2400            {
2401              if ( p->ndims == 3 ) {
2402fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,KDEBUG,JDEBUG)\n", vname, vname ) ;
2403              } else if ( p->ndims == 2 ) {
2404fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,JDEBUG)\n", vname, vname ) ;
2405              }
2406            }
2407          }
2408        }
2409      }
2410    }
2411
2412    close_the_file(fp) ;
2413}
2414
2415/*****************/
2416/*****************/
2417
2418int
2419gen_comms ( char * dirname )
2420{
2421  FILE *fpsub ; 
2422  if ( sw_dm_parallel )
2423    fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
2424
2425  /* truncate this file if it exists */
2426  if ((fpsub = fopen( "inc/REGISTRY_COMM_NESTING_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2427  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2428  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_0_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2429  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_1_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2430  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_2_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2431  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_3_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2432
2433  gen_halos( "inc" , NULL, Halos, 1 ) ;
2434  gen_shift( "inc" ) ;
2435  gen_periods( "inc", Periods ) ;
2436  gen_swaps( "inc", Swaps ) ;
2437  gen_cycles( "inc", Cycles ) ;
2438  gen_xposes( "inc" ) ;
2439  gen_comm_descrips( "inc" ) ;
2440  gen_datacalls( "inc" ) ;
2441  gen_nest_packing( "inc" ) ;
2442#if 0
2443  gen_debug( "inc" ) ;
2444#endif
2445
2446  return(0) ;
2447}
2448
Note: See TracBrowser for help on using the repository browser.