source: trunk/WRF.COMMON/WRFV2/external/RSL_LITE/gen_comms.c

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

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 53.8 KB
Line 
1#include <stdio.h>
2#include <stdlib.h>
3#include <string.h>
4
5#include "protos.h"
6#include "registry.h"
7#include "data.h"
8
9/* For detecting variables that are members of a derived type */
10#define NULLCHARPTR   (char *) 0
11static int parent_type;
12
13int
14gen_halos ( char * dirname , char * incname , node_t * halos )
15{
16  node_t * p, * q ;
17  node_t * dimd ;
18  char commname[NAMELEN] ;
19  char fname[NAMELEN] ;
20  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
21  char commuse[NAMELEN] ;
22#define MAX_VDIMS 100
23  char vdims[MAX_VDIMS][2][80] ;
24  char s[NAMELEN], e[NAMELEN] ;
25  int vdimcurs ;
26  int maxstenwidth, stenwidth ;
27  FILE * fp ;
28  char * t1, * t2 ;
29  char * pos1 , * pos2 ;
30  char indices[NAMELEN], post[NAMELEN] ;
31  int zdex ;
32  int n2dR, n3dR ;
33  int n2dI, n3dI ;
34  int n2dD, n3dD ;
35  int n4d ;
36  int i, foundvdim ;
37#define MAX_4DARRAYS 1000
38  char name_4d[MAX_4DARRAYS][NAMELEN] ;
39
40  if ( dirname == NULL ) return(1) ;
41
42  for ( p = halos ; p != NULL ; p = p->next )
43  {
44    if ( incname == NULL ) {
45      strcpy( commname, p->name ) ;
46      make_upper_case(commname) ;
47    } 
48    else {
49      strcpy( commname, incname ) ;
50    }
51    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
52    else                       { sprintf(fname,"%s.inc",commname) ; }
53    if ((fp = fopen( fname , "w" )) == NULL ) 
54    {
55      fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
56      continue ; 
57    }
58    /* get maximum stencil width */
59    maxstenwidth = 0 ;
60    strcpy( tmp, p->comm_define ) ;
61    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
62    while ( t1 != NULL )
63    {
64      strcpy( tmp2 , t1 ) ;
65      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
66       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
67      stenwidth = atoi (t2) ;
68      if ( stenwidth == 0 )
69       { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
70      if      ( stenwidth == 4   || stenwidth == 8  ) stenwidth = 1 ;
71      else if ( stenwidth == 12  || stenwidth == 24 ) stenwidth = 2 ;
72      else if ( stenwidth == 48 ) stenwidth = 3 ;
73      else if ( stenwidth == 80 ) stenwidth = 4 ;
74      else if ( stenwidth == 120 ) stenwidth = 5 ;
75      else if ( stenwidth == 168 ) stenwidth = 6 ;
76      else
77       { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
78      if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
79      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
80    }
81    print_warning(fp,fname) ;
82
83fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
84
85/* count up the number of 2d and 3d real arrays and their types */
86    n2dR = 0 ; n3dR = 0 ;
87    n2dI = 0 ; n3dI = 0 ;
88    n2dD = 0 ; n3dD = 0 ;
89    n4d = 0 ;
90    vdimcurs = 0 ;
91    strcpy( tmp, p->comm_define ) ;
92    strcpy( commuse, p->use ) ;
93    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
94    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
95    while ( t1 != NULL )
96    {
97      strcpy( tmp2 , t1 ) ;
98      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
99       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
100      t2 = strtok_rentr(NULL,",", &pos2) ;
101      while ( t2 != NULL )
102      {
103        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
104          { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
105        else
106        {
107          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
108            { 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) ; }
109          else if ( q->boundary_array )
110            { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
111          else
112          {
113
114            /* 20061004 -- collect all the vertical dimensions so we can use a MAX
115               on them when calling RSL_LITE_INIT_EXCH */
116
117            if ( q->ndims == 3 || q->node_kind & FOURD ) {
118              if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
119                zdex = get_index_for_coord( q , COORD_Z ) ;
120                if      ( dimd->len_defined_how == DOMAIN_STANDARD ) { 
121                  strcpy(s,"kps") ;
122                  strcpy(e,"kpe") ;
123                }
124                else if ( dimd->len_defined_how == NAMELIST ) {
125                  if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
126                    strcpy(s,"1") ;
127                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
128                  } else {
129                    sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
130                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
131                  }
132                }
133                else if ( dimd->len_defined_how == CONSTANT ) {
134                  sprintf(s,"%d",dimd->coord_start) ;
135                  sprintf(e,"%d",dimd->coord_end) ; 
136                }
137                for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
138                  if ( !strcmp( vdims[i][1], e ) ) {
139                    foundvdim = 1 ; break ;
140                  }
141                }
142                if ( ! foundvdim ) {
143                  if (vdimcurs < 100 ) {
144                    strcpy( vdims[vdimcurs][0], s ) ;
145                    strcpy( vdims[vdimcurs][1], e ) ;
146                    vdimcurs++ ;
147                  } else {
148                    fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
149                    fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
150                    fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
151                    exit(5) ;
152                  }
153                }
154              }
155            }
156
157            if ( q->node_kind & FOURD ) {
158              if ( n4d < MAX_4DARRAYS ) {
159                strcpy( name_4d[n4d], q->name ) ;
160              } else { 
161                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
162                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
163                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
164                exit(5) ;
165              }
166              n4d++ ;
167            }
168            else
169            {
170              if        ( ! strcmp( q->type->name, "real") ) {
171                if         ( q->ndims == 3 )      { n3dR++ ; }
172                else    if ( q->ndims == 2 )      { n2dR++ ; }
173              } else if ( ! strcmp( q->type->name, "integer") ) {
174                if         ( q->ndims == 3 )      { n3dI++ ; }
175                else    if ( q->ndims == 2 )      { n2dI++ ; }
176              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
177                if         ( q->ndims == 3 )      { n3dD++ ; }
178                else    if ( q->ndims == 2 )      { n2dD++ ; }
179              }
180            }
181          }
182        }
183        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
184      }
185      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
186    }
187
188/* generate the stencil init statement for Y transfer */
189#if 0
190fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %d for Y %s')\n",maxstenwidth,fname) ;
191#endif
192    fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d, &\n",maxstenwidth) ;
193    if ( n4d > 0 ) {
194      fprintf(fp,  "     %d  &\n", n3dR ) ;
195      for ( i = 0 ; i < n4d ; i++ ) {
196        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
197      }
198      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
199    } else {
200      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
201    }
202    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
203    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
204    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
205    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
206    fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
207    for ( i = 0 ; i < vdimcurs ; i++ ) {
208      fprintf(fp,",%s &\n",vdims[i][1] ) ;
209    }
210    fprintf(fp,"))\n") ;
211
212/* generate packs prior to stencil exchange in Y */
213    gen_packs( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ;
214/* generate stencil exchange in Y */
215    fprintf(fp,"   CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
216/* generate unpacks after stencil exchange in Y */
217    gen_packs( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
218
219/* generate the stencil init statement for X transfer */
220    fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d , &\n",maxstenwidth) ;
221    if ( n4d > 0 ) {
222      fprintf(fp,  "     %d  &\n", n3dR ) ;
223      for ( i = 0 ; i < n4d ; i++ ) {
224        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
225      }
226      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
227    } else {
228      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
229    }
230    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
231    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
232    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
233    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
234    fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
235    for ( i = 0 ; i < vdimcurs ; i++ ) {
236      fprintf(fp,",%s &\n",vdims[i][1] ) ;
237    }
238    fprintf(fp,"))\n") ;
239/* generate packs prior to stencil exchange in X */
240    gen_packs( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ;
241/* generate stencil exchange in X */
242    fprintf(fp,"   CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
243/* generate unpacks after stencil exchange in X */
244    gen_packs( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
245
246    close_the_file(fp) ;
247  }
248  return(0) ;
249}
250
251gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )   
252{
253  node_t * q ;
254  node_t * dimd ;
255  char fname[NAMELEN] ;
256  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
257  char commuse[NAMELEN] ;
258  int maxstenwidth, stenwidth ;
259  char * t1, * t2 , *wordsize ;
260  char varref[NAMELEN] ;
261  char * pos1 , * pos2 ;
262  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
263  int zdex ;
264
265    strcpy( tmp, p->comm_define ) ;
266    strcpy( commuse, p->use ) ;
267    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
268    while ( t1 != NULL )
269    {
270      strcpy( tmp2 , t1 ) ;
271      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
272       { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
273      t2 = strtok_rentr(NULL,",", &pos2) ;
274      while ( t2 != NULL )
275      {
276        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
277          { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
278        else
279        {
280
281          strcpy( varref, t2 ) ;
282          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
283             if ( !strncmp( q->use,  "dyn_", 4 )) {
284                  char * core ;
285                  core = q->use+4 ;
286                  sprintf(varref,"grid%%%s_%s",core,t2) ;
287             } else {
288                  sprintf(varref,"grid%%%s",t2) ;
289             }
290          }
291
292          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
293          else if ( q->boundary_array ) { ; }
294          else
295          { 
296            if      ( ! strcmp( q->type->name, "real") )            { wordsize = "RWORDSIZE" ; }
297            else if ( ! strcmp( q->type->name, "integer") )         { wordsize = "IWORDSIZE" ; }
298            else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
299            if ( q->node_kind & FOURD )
300            {
301              node_t *member ;
302              zdex = get_index_for_coord( q , COORD_Z ) ;
303              if ( zdex >=1 && zdex <= 3 )
304              {
305                set_mem_order( q->members, memord , NAMELEN) ;
306fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
307fprintf(fp," CALL %s ( %s,%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, '%s', %d, &\n",
308                       packname, commname, varref , shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
309fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
310fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
311fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
312fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
313fprintf(fp,"ENDDO\n") ;
314              }
315              else
316              {
317                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
318              }
319            }
320            else
321            {
322              set_mem_order( q, memord , NAMELEN) ;
323#if 0
324fprintf(fp,"CALL wrf_debug(3,'call %s %s shw=%d ws=%s xy=%d pu=%d m=%s')\n",packname,t2,shw,wordsize,xy,pu,memord) ;
325fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, kds, kde\n" ) ;
326fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
327fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, kms, kme\n" ) ;
328fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
329fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, kps, kpe\n" ) ;
330fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
331#endif
332              if       ( q->ndims == 3 ) {
333
334                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
335                zdex = get_index_for_coord( q , COORD_Z ) ;
336                if ( dimd != NULL )
337                {
338                  char s[256], e[256] ;
339
340                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
341#if 0
342fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, kds, kde\n" ) ;
343fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
344fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, kms, kme\n" ) ;
345fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
346fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, kps, kpe\n" ) ;
347fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
348#endif
349                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, '%s', %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
350                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
351                    fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
352                    fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
353                    fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
354                  }
355                  else if ( dimd->len_defined_how == NAMELIST )
356                  {
357                    if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
358                      strcpy(s,"1") ;
359                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
360                    } else {
361                      sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
362                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
363                    }
364#if 0
365fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, %s, %s\n",s,e ) ;
366fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
367fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, %s, %s\n",s,e ) ;
368fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
369fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, %s, %s\n",s,e ) ;
370fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
371#endif
372                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, '%s', %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
373                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
374                    fprintf(fp,"ids, ide, jds, jde, %s, %s,             &\n",s,e) ;
375                    fprintf(fp,"ims, ime, jms, jme, %s, %s,             &\n",s,e) ;
376                    fprintf(fp,"ips, ipe, jps, jpe, %s, %s              )\n",s,e) ;
377                  }
378                  else if ( dimd->len_defined_how == CONSTANT )
379                  {
380#if 0
381fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
382fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
383fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
384fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
385fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
386fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
387#endif
388                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, '%s', %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
389                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
390                    fprintf(fp,"ids, ide, jds, jde, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
391                    fprintf(fp,"ims, ime, jms, jme, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
392                    fprintf(fp,"ips, ipe, jps, jpe, %d, %d              )\n",dimd->coord_start,dimd->coord_end) ;
393                  }
394                }
395              } else if ( q->ndims == 2 ) {
396#if 0
397fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, 1, 1\n" ) ;
398fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
399fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, 1, 1\n" ) ;
400fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
401fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, 1, 1\n" ) ;
402fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
403#endif
404                fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, '%s', %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
405                fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
406                fprintf(fp,"ids, ide, jds, jde, 1  , 1  ,             &\n") ;
407                fprintf(fp,"ims, ime, jms, jme, 1  , 1  ,             &\n") ;
408                fprintf(fp,"ips, ipe, jps, jpe, 1  , 1                )\n") ;
409              } else {
410                fprintf(stderr,"Registry WARNING: %s is neither 2 nor 3 dimensional\n",t2) ;
411              }
412#if 0
413fprintf(fp,"CALL wrf_debug(3,'back from %s')\n", packname) ;
414#endif
415            }
416          }
417         
418        }
419        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
420      }
421      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
422    }
423}
424
425int
426gen_periods ( char * dirname , node_t * periods )
427{
428  node_t * p, * q ;
429  node_t * dimd ;
430  char commname[NAMELEN] ;
431  char fname[NAMELEN] ;
432  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
433  char commuse[NAMELEN] ;
434  int maxperwidth, perwidth ;
435  FILE * fp ;
436  char * t1, * t2 ;
437  char varref[NAMELEN] ;
438  char * pos1 , * pos2 ;
439  char indices[NAMELEN], post[NAMELEN] ;
440  int zdex ;
441  int n2dR, n3dR ;
442  int n2dI, n3dI ;
443  int n2dD, n3dD ;
444  int n4d ;
445  int i ;
446#define MAX_4DARRAYS 1000
447  char name_4d[MAX_4DARRAYS][NAMELEN] ;
448
449  if ( dirname == NULL ) return(1) ;
450
451  for ( p = periods ; p != NULL ; p = p->next )
452  {
453    strcpy( commname, p->name ) ;
454    make_upper_case(commname) ;
455    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
456    else                       { sprintf(fname,"%s.inc",commname) ; }
457    if ((fp = fopen( fname , "w" )) == NULL ) 
458    {
459      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
460      continue ; 
461    }
462    /* get maximum period width */
463    maxperwidth = 0 ;
464    strcpy( tmp, p->comm_define ) ;
465    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
466    while ( t1 != NULL )
467    {
468      strcpy( tmp2 , t1 ) ;
469      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
470       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
471      perwidth = atoi (t2) ;
472      if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
473      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
474    }
475    print_warning(fp,fname) ;
476
477fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
478
479/* count up the number of 2d and 3d real arrays and their types */
480    n2dR = 0 ; n3dR = 0 ;
481    n2dI = 0 ; n3dI = 0 ;
482    n2dD = 0 ; n3dD = 0 ;
483    n4d = 0 ;
484    strcpy( tmp, p->comm_define ) ;
485    strcpy( commuse, p->use ) ;
486    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
487    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
488    while ( t1 != NULL )
489    {
490      strcpy( tmp2 , t1 ) ;
491      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
492       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
493      t2 = strtok_rentr(NULL,",", &pos2) ;
494      while ( t2 != NULL )
495      {
496        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
497          { fprintf(stderr,"WARNING 1 : %s in peridod spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
498        else
499        {
500
501          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
502            { 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) ; }
503          else if ( q->boundary_array )
504            { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
505          else
506          {
507            if ( q->node_kind & FOURD ) {
508              if ( n4d < MAX_4DARRAYS ) {
509                strcpy( name_4d[n4d], q->name ) ;
510              } else { 
511                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
512                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
513                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
514                exit(5) ;
515              }
516              n4d++ ;
517            }
518            else
519            {
520              if        ( ! strcmp( q->type->name, "real") ) {
521                if         ( q->ndims == 3 )      { n3dR++ ; }
522                else    if ( q->ndims == 2 )      { n2dR++ ; }
523              } else if ( ! strcmp( q->type->name, "integer") ) {
524                if         ( q->ndims == 3 )      { n3dI++ ; }
525                else    if ( q->ndims == 2 )      { n2dI++ ; }
526              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
527                if         ( q->ndims == 3 )      { n3dD++ ; }
528                else    if ( q->ndims == 2 )      { n2dD++ ; }
529              }
530            }
531          }
532        }
533        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
534      }
535      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
536    }
537
538    fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
539
540/* generate the stencil init statement for X transfer */
541    fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
542
543    if ( n4d > 0 ) {
544      fprintf(fp,  "     %d  &\n", n3dR ) ;
545      for ( i = 0 ; i < n4d ; i++ ) {
546        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
547      }
548      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
549    } else {
550      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
551    }
552
553    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
554    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
555    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
556    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
557    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
558/* generate packs prior to stencil exchange in X */
559    gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD_X", "local_communicator_periodic" ) ;
560/* generate stencil exchange in X */
561    fprintf(fp,"   CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
562/* generate unpacks after stencil exchange in X */
563    gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD_X", "local_communicator_periodic" ) ;
564
565    fprintf(fp,"END IF\n") ;
566
567    close_the_file(fp) ;
568  }
569  return(0) ;
570}
571
572int
573gen_swaps ( char * dirname , node_t * swaps )
574{
575  node_t * p, * q ;
576  node_t * dimd ;
577  char commname[NAMELEN] ;
578  char fname[NAMELEN] ;
579  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
580  char commuse[NAMELEN] ;
581  FILE * fp ;
582  char * t1, * t2 ;
583  char * pos1 , * pos2 ;
584  char indices[NAMELEN], post[NAMELEN] ;
585  int zdex ;
586  int n2dR, n3dR ;
587  int n2dI, n3dI ;
588  int n2dD, n3dD ;
589  int n4d ;
590  int i, xy ;
591#define MAX_4DARRAYS 1000
592  char name_4d[MAX_4DARRAYS][NAMELEN] ;
593
594  if ( dirname == NULL ) return(1) ;
595
596  for ( p = swaps ; p != NULL ; p = p->next )
597  {
598    strcpy( commname, p->name ) ;
599    make_upper_case(commname) ;
600    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
601    else                       { sprintf(fname,"%s.inc",commname) ; }
602    if ((fp = fopen( fname , "w" )) == NULL ) 
603    {
604      fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
605      continue ; 
606    }
607    print_warning(fp,fname) ;
608
609  for ( xy = 0 ; xy < 2 ; xy++ ) {
610
611fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
612
613/* count up the number of 2d and 3d real arrays and their types */
614    n2dR = 0 ; n3dR = 0 ;
615    n2dI = 0 ; n3dI = 0 ;
616    n2dD = 0 ; n3dD = 0 ;
617    n4d = 0 ;
618    strcpy( tmp, p->comm_define ) ;
619    strcpy( commuse, p->use ) ;
620    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
621    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
622    while ( t1 != NULL )
623    {
624      strcpy( tmp2 , t1 ) ;
625      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
626       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
627      t2 = strtok_rentr(NULL,",", &pos2) ;
628      while ( t2 != NULL )
629      {
630        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
631          { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
632        else
633        {
634          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
635            { 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) ; }
636          else if ( q->boundary_array )
637            { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
638          else
639          {
640            if ( q->node_kind & FOURD ) {
641              if ( n4d < MAX_4DARRAYS ) {
642                strcpy( name_4d[n4d], q->name ) ;
643              } else { 
644                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
645                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
646                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
647                exit(5) ;
648              }
649              n4d++ ;
650            }
651            else
652            {
653              if        ( ! strcmp( q->type->name, "real") ) {
654                if         ( q->ndims == 3 )      { n3dR++ ; }
655                else    if ( q->ndims == 2 )      { n2dR++ ; }
656              } else if ( ! strcmp( q->type->name, "integer") ) {
657                if         ( q->ndims == 3 )      { n3dI++ ; }
658                else    if ( q->ndims == 2 )      { n2dI++ ; }
659              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
660                if         ( q->ndims == 3 )      { n3dD++ ; }
661                else    if ( q->ndims == 2 )      { n2dD++ ; }
662              }
663            }
664          }
665        }
666        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
667      }
668      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
669    }
670
671    fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
672
673/* generate the init statement for X swap */
674    fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
675    if ( n4d > 0 ) {
676      fprintf(fp,  "     %d  &\n", n3dR ) ;
677      for ( i = 0 ; i < n4d ; i++ ) {
678        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
679      }
680      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
681    } else {
682      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
683    }
684    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
685    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
686    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
687    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
688    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
689    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
690/* generate packs prior to stencil exchange  */
691    gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
692/* generate stencil exchange in X */
693    fprintf(fp,"   CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
694/* generate unpacks after stencil exchange  */
695    gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
696
697    fprintf(fp,"END IF\n") ;
698
699  }
700    close_the_file(fp) ;
701  }
702  return(0) ;
703}
704
705int
706gen_cycles ( char * dirname , node_t * cycles )
707{
708  node_t * p, * q ;
709  node_t * dimd ;
710  char commname[NAMELEN] ;
711  char fname[NAMELEN] ;
712  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
713  char commuse[NAMELEN] ;
714  FILE * fp ;
715  char * t1, * t2 ;
716  char * pos1 , * pos2 ;
717  char indices[NAMELEN], post[NAMELEN] ;
718  int zdex ;
719  int n2dR, n3dR ;
720  int n2dI, n3dI ;
721  int n2dD, n3dD ;
722  int n4d ;
723  int i, xy, inout ;
724#define MAX_4DARRAYS 1000
725  char name_4d[MAX_4DARRAYS][NAMELEN] ;
726
727  if ( dirname == NULL ) return(1) ;
728
729  for ( p = cycles ; p != NULL ; p = p->next )
730  {
731    strcpy( commname, p->name ) ;
732    make_upper_case(commname) ;
733    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
734    else                       { sprintf(fname,"%s.inc",commname) ; }
735    if ((fp = fopen( fname , "w" )) == NULL ) 
736    {
737      fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
738      continue ; 
739    }
740
741    /* get inout */
742    inout = 0 ;
743    strcpy( tmp, p->comm_define ) ;
744    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
745    strcpy( tmp2 , t1 ) ;
746    if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
747       { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
748    inout = atoi (t2) ;
749
750    print_warning(fp,fname) ;
751
752  for ( xy = 0 ; xy < 2 ; xy++ ) {
753
754fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
755
756/* count up the number of 2d and 3d real arrays and their types */
757    n2dR = 0 ; n3dR = 0 ;
758    n2dI = 0 ; n3dI = 0 ;
759    n2dD = 0 ; n3dD = 0 ;
760    n4d = 0 ;
761    strcpy( tmp, p->comm_define ) ;
762    strcpy( commuse, p->use ) ;
763    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
764    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
765    while ( t1 != NULL )
766    {
767      strcpy( tmp2 , t1 ) ;
768      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
769       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
770      t2 = strtok_rentr(NULL,",", &pos2) ;
771      while ( t2 != NULL )
772      {
773        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
774          { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
775        else
776        {
777          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
778            { 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) ; }
779          else if ( q->boundary_array )
780            { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
781          else
782          {
783            if ( q->node_kind & FOURD ) {
784              if ( n4d < MAX_4DARRAYS ) {
785                strcpy( name_4d[n4d], q->name ) ;
786              } else { 
787                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
788                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
789                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
790                exit(5) ;
791              }
792              n4d++ ;
793            }
794            else
795            {
796              if        ( ! strcmp( q->type->name, "real") ) {
797                if         ( q->ndims == 3 )      { n3dR++ ; }
798                else    if ( q->ndims == 2 )      { n2dR++ ; }
799              } else if ( ! strcmp( q->type->name, "integer") ) {
800                if         ( q->ndims == 3 )      { n3dI++ ; }
801                else    if ( q->ndims == 2 )      { n2dI++ ; }
802              } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
803                if         ( q->ndims == 3 )      { n3dD++ ; }
804                else    if ( q->ndims == 2 )      { n2dD++ ; }
805              }
806            }
807          }
808        }
809        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
810      }
811      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
812    }
813
814    fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
815
816/* generate the init statement for X swap */
817    fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
818    if ( n4d > 0 ) {
819      fprintf(fp,  "     %d  &\n", n3dR ) ;
820      for ( i = 0 ; i < n4d ; i++ ) {
821        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
822      }
823      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
824    } else {
825      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
826    }
827    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
828    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
829    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
830    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
831    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
832    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
833/* generate packs prior to stencil exchange  */
834    gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
835/* generate stencil exchange in X */
836    fprintf(fp,"   CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
837/* generate unpacks after stencil exchange  */
838    gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
839
840    fprintf(fp,"END IF\n") ;
841
842  }
843    close_the_file(fp) ;
844  }
845  return(0) ;
846}
847
848int
849gen_xposes ( char * dirname )
850{
851  node_t * p, * q ;
852  char commname[NAMELEN] ;
853  char fname[NAMELEN] ;
854  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
855  char commuse[NAMELEN] ;
856  FILE * fp ;
857  char * t1, * t2 ;
858  char * pos1 , * pos2 ;
859  char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
860  char ** x ;
861  char indices[NAMELEN], post[NAMELEN] ;
862
863  if ( dirname == NULL ) return(1) ;
864
865  for ( p = Xposes ; p != NULL ; p = p->next )
866  {
867    for ( x = xposedir ; *x ; x++ )
868    {
869      strcpy( commname, p->name ) ;
870      make_upper_case(commname) ;
871      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
872      else                       { sprintf(fname,"%s_%s.inc",commname,*x) ; }
873      if ((fp = fopen( fname , "w" )) == NULL ) 
874      {
875        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
876        continue ; 
877      }
878
879      print_warning(fp,fname) ;
880      close_the_file(fp) ;
881    }
882skiperific:
883    ;
884  }
885  return(0) ;
886}
887
888int
889gen_comm_descrips ( char * dirname )
890{
891  node_t * p ;
892  char * fn = "dm_comm_cpp_flags" ;
893  char commname[NAMELEN] ;
894  char fname[NAMELEN] ;
895  FILE * fp ;
896  int ncomm ;
897
898  if ( dirname == NULL ) return(1) ;
899
900  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
901  else                       { sprintf(fname,"%s",fn) ; }
902
903  if ((fp = fopen( fname , "w" )) == NULL )
904  {
905    fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
906  }
907
908  return(0) ;
909}
910
911/*
912
913
914
915*/
916
917/* for each core, generate the halo updates to allow shifting all state data */
918int
919gen_shift (  char * dirname )
920{
921  int i, ncore ;
922  FILE * fp ;
923  node_t *p, *q, *dimd ;
924  char * corename ;
925  char **direction ;
926  char *directions[] = { "x", "y", 0L } ;
927  char fname[NAMELEN], vname[NAMELEN], vname2[NAMELEN], core[NAMELEN] ;
928  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
929  int zdex ;
930  node_t Shift ;
931int said_it = 0 ;
932
933  for ( direction = directions ; *direction != NULL ; direction++ )
934  {
935  for ( ncore = 0 ; ncore < get_num_cores() ; ncore++ )
936  {
937    corename = get_corename_i(ncore) ;
938    if ( dirname == NULL || corename == NULL ) return(1) ;
939    sprintf(fname,"%s_shift_halo_%s",corename,*direction) ;
940
941    Shift.next = NULL ;
942    sprintf( Shift.use, "dyn_%s", corename ) ;
943    strcpy( Shift.comm_define, "48:" ) ;
944    for ( p = Domain.fields ; p != NULL ; p = p->next ) {
945      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
946          ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
947      {
948
949/* special cases in WRF */
950if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
951     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
952     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
953  if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
954                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
955                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
956  said_it = 1 ; }
957  continue ;
958}
959
960/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
961        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
962          if ( p->type->type_type == SIMPLE )
963          {
964            for ( i = 1 ; i <= p->ntl ; i++ )
965            {
966              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
967              else              sprintf(vname,"%s",p->name ) ;
968
969              strcat( Shift.comm_define, vname ) ;
970              strcat( Shift.comm_define, "," ) ;
971            }
972          }
973        }
974      }
975    }
976    if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
977
978    gen_halos( dirname , fname, &Shift ) ;
979
980    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_shift_halo_%s.inc",dirname,corename,*direction) ; }
981    else                       { sprintf(fname,"%s_shift_halo_%s.inc",corename,*direction) ; }
982    if ((fp = fopen( fname , "a" )) == NULL ) return(1) ;
983
984/* now generate the shifts themselves */
985    for ( p = Domain.fields ; p != NULL ; p = p->next )
986    {
987
988/* special cases in WRF */
989if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
990     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
991     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
992  continue ;
993}
994
995      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
996          ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
997      {
998
999        if ( p->node_kind & FOURD ) {
1000          sprintf(core,"") ;
1001        } else {
1002          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
1003          else                                sprintf(core,"") ;
1004        }
1005
1006        if ( p->type->type_type == SIMPLE )
1007        {
1008          for ( i = 1 ; i <= p->ntl ; i++ )
1009          {
1010           
1011            if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
1012            else              sprintf(vname,"%s",p->name ) ;
1013            if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
1014            else              sprintf(vname2,"%s%s",core,p->name ) ;
1015
1016            if ( p->node_kind & FOURD )
1017            {
1018              node_t *member ;
1019              zdex = get_index_for_coord( p , COORD_Z ) ;
1020              if ( zdex >=1 && zdex <= 3 )
1021              {
1022                    if ( !strcmp( *direction, "x" ) )
1023                    {
1024fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
1025fprintf(fp, "   %s ( ips:min(ide%s,ipe),:,jms:jme,itrace) = %s (ips+px:min(ide%s,ipe)+px,:,jms:jme,itrace)\n",
1026                       vname, p->members->stag_x?"":"-1", vname, p->members->stag_x?"":"-1" ) ;
1027fprintf(fp, "  ENDDO\n" ) ;
1028                    }
1029                    else
1030                    {
1031fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
1032fprintf(fp, "   %s ( ims:ime,:,jps:min(jde%s,jpe),itrace) = %s (ims:ime,:,jps+py:min(jde%s,jpe)+py,itrace)\n",
1033                       vname, p->members->stag_y?"":"-1", vname, p->members->stag_y?"":"-1" ) ;
1034fprintf(fp, "  ENDDO\n" ) ;
1035                    }
1036
1037              }
1038              else
1039              {
1040                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1041              }
1042            }
1043            else
1044            {
1045              char * vdim ;
1046              vdim = "" ;
1047              if ( p->ndims == 3 ) vdim = ":," ;
1048              if ( !strcmp( *direction, "x" ) )
1049              {
1050                fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),%sjms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,%sjms:jme)\n", vname2,  p->stag_x?"":"-1", vdim, vname2, p->stag_x?"":"-1", vdim ) ;
1051              }
1052              else
1053              {
1054                fprintf(fp,"grid%%%s (ims:ime,%sjps:min(jde%s,jpe)) = grid%%%s (ims:ime,%sjps+py:min(jde%s,jpe)+py)\n", vname2, vdim,  p->stag_y?"":"-1", vname2, vdim, p->stag_y?"":"-1" ) ;
1055              }
1056            }
1057          }
1058        }
1059      }
1060    }
1061
1062    close_the_file(fp) ;
1063  }
1064  }
1065}
1066
1067int
1068gen_datacalls ( char * dirname )
1069{
1070  int i ;
1071  FILE * fp ;
1072  char * corename ;
1073  char * fn = "data_calls.inc" ;
1074  char fname[NAMELEN] ;
1075
1076  for ( i = 0 ; i < get_num_cores() ; i++ )
1077  {
1078    corename = get_corename_i(i) ;
1079    if ( dirname == NULL || corename == NULL ) return(1) ;
1080    if ( strlen(dirname) > 0 )
1081     { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
1082    else
1083     { sprintf(fname,"%s_%s",corename,fn) ; }
1084    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1085    print_warning(fp,fname) ;
1086    close_the_file(fp) ;
1087  }
1088  return(0) ;
1089}
1090
1091/*****************/
1092/*****************/
1093
1094gen_nest_packing ( char * dirname )
1095{
1096  gen_nest_pack( dirname ) ;
1097  gen_nest_unpack( dirname ) ;
1098}
1099
1100#define PACKIT 1
1101#define UNPACKIT 2
1102
1103int
1104gen_nest_pack ( char * dirname )
1105{
1106  int i ;
1107  FILE * fp ;
1108  char * corename ;
1109  char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
1110  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
1111  int ipath ;
1112  char ** fnp ; char * fn ;
1113  char * shw_str ;
1114  char fname[NAMELEN] ;
1115  node_t *node, *p, *dim ;
1116  int xdex, ydex, zdex ;
1117  char ddim[3][2][NAMELEN] ;
1118  char mdim[3][2][NAMELEN] ;
1119  char pdim[3][2][NAMELEN] ;
1120  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
1121  int d2, d3, sw ;
1122  char *info_name ;
1123
1124  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
1125  {
1126    fn = *fnp ;
1127    for ( i = 0 ; i < get_num_cores() ; i++ )
1128    {
1129      corename = get_corename_i(i) ;
1130      if ( dirname == NULL || corename == NULL ) return(1) ;
1131      if ( strlen(dirname) > 0 ) {
1132       if ( strlen( corename ) > 0 )
1133         { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
1134       else
1135         { sprintf(fname,"%s/%s",dirname,fn) ; }
1136      } else { 
1137       if ( strlen( corename ) > 0 ) 
1138          { sprintf(fname,"%s_%s",corename,fn) ; }
1139       else
1140          { sprintf(fname,"%s",fn) ; }
1141      }
1142      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1143      print_warning(fp,fname) ;
1144
1145      d2 = 0 ;
1146      d3 = 0 ;
1147      node = Domain.fields ;
1148
1149      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
1150
1151      if ( d2 + d3 > 0 ) {
1152        if ( down_path[ipath] == INTERP_UP )
1153        {
1154          info_name = "rsl_lite_to_parent_info" ;
1155          sw = 0 ;
1156        }
1157        else
1158        {
1159          info_name = "rsl_lite_to_child_info" ;
1160          sw = 1 ;
1161        }
1162
1163        fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
1164
1165        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
1166        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
1167if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
1168        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
1169if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
1170        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
1171        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
1172        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
1173        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
1174
1175        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1176 
1177        gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
1178
1179        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
1180        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
1181if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
1182        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
1183if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
1184        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
1185        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
1186        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
1187        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
1188
1189        fprintf(fp,"ENDDO\n") ;
1190      }
1191      close_the_file(fp) ;
1192    }
1193  }
1194  return(0) ;
1195}
1196
1197int
1198gen_nest_unpack ( char * dirname )
1199{
1200  int i ;
1201  FILE * fp ;
1202  char * corename ;
1203  char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
1204  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
1205  int ipath ;
1206  char ** fnp ; char * fn ;
1207  char fname[NAMELEN] ;
1208  node_t *node, *p, *dim ;
1209  int xdex, ydex, zdex ;
1210  char ddim[3][2][NAMELEN] ;
1211  char mdim[3][2][NAMELEN] ;
1212  char pdim[3][2][NAMELEN] ;
1213  char *info_name ;
1214  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
1215  int d2, d3 ;
1216
1217  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
1218  {
1219    fn = *fnp ;
1220    for ( i = 0 ; i < get_num_cores() ; i++ )
1221    {
1222      d2 = 0 ;
1223      d3 = 0 ;
1224      node = Domain.fields ;
1225
1226      corename = get_corename_i(i) ;
1227      if ( dirname == NULL || corename == NULL ) return(1) ;
1228      if ( strlen(dirname) > 0 )
1229       { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
1230      else
1231       { sprintf(fname,"%s_%s",corename,fn) ; }
1232      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1233      print_warning(fp,fname) ;
1234
1235      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
1236
1237      if ( d2 + d3 > 0 ) {
1238        if ( down_path[ipath] == INTERP_UP )
1239        {
1240          info_name = "rsl_lite_from_child_info" ;
1241        }
1242        else
1243        {
1244          info_name = "rsl_lite_from_parent_info" ;
1245        }
1246
1247        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
1248        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1249        gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
1250        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
1251        fprintf(fp,"ENDDO\n") ;
1252      }
1253      close_the_file(fp) ;
1254    }
1255  }
1256  return(0) ;
1257}
1258
1259int
1260gen_nest_packunpack ( FILE *fp , node_t * node , char * corename, int dir, int down_path )
1261{
1262  int i ;
1263  node_t *p, *p1, *dim ;
1264  int d2, d3, xdex, ydex, zdex ;
1265  int io_mask ;
1266  char * grid ; 
1267  char ddim[3][2][NAMELEN] ;
1268  char mdim[3][2][NAMELEN] ;
1269  char pdim[3][2][NAMELEN] ;
1270  char vname[NAMELEN], vname2[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
1271  char c, d ;
1272
1273  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
1274  {
1275
1276    if ( p1->node_kind & FOURD )
1277    {
1278      if ( p1->members->next )
1279        io_mask = p1->members->next->io_mask ;
1280      else
1281        continue ;
1282    }
1283    else
1284    {
1285      io_mask = p1->io_mask ;
1286    }
1287    p = p1 ;
1288
1289    if ( io_mask & down_path )
1290    {
1291      if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1292      {
1293        if ( p->node_kind & FOURD ) {
1294          if (!strncmp( p->members->next->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
1295          else                                               sprintf(core,"") ;
1296          if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
1297          else                             sprintf(tag,"") ;
1298          set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
1299          zdex = get_index_for_coord( p->members , COORD_Z ) ;
1300          xdex = get_index_for_coord( p->members , COORD_X ) ;
1301          ydex = get_index_for_coord( p->members , COORD_Y ) ;
1302        } else {
1303          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
1304          else                                sprintf(core,"") ;
1305          if ( p->ntl > 1 ) sprintf(tag,"_2") ;
1306          else              sprintf(tag,"") ;
1307          set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
1308          zdex = get_index_for_coord( p , COORD_Z ) ;
1309          xdex = get_index_for_coord( p , COORD_X ) ;
1310          ydex = get_index_for_coord( p , COORD_Y ) ;
1311        }
1312
1313        if ( down_path == INTERP_UP )
1314        {
1315          c = ( dir == PACKIT )?'n':'p' ;
1316          d = ( dir == PACKIT )?'2':'1' ;
1317        } else {
1318          c = ( dir == UNPACKIT )?'n':'p' ;
1319          d = ( dir == UNPACKIT )?'2':'1' ;
1320        }
1321
1322        if ( zdex >= 0 ) {
1323          if      ( xdex == 0 && zdex == 1 && ydex == 2 )  sprintf(dexes,"pig,k,pjg") ;
1324          else if ( zdex == 0 && xdex == 1 && ydex == 2 )  sprintf(dexes,"k,pig,pjg") ;
1325          else if ( xdex == 0 && ydex == 1 && zdex == 2 )  sprintf(dexes,"pig,pjg,k") ;
1326        } else {
1327          if ( xdex == 0 && ydex == 1 )  sprintf(dexes,"pig,pjg") ;
1328          if ( ydex == 0 && xdex == 1 )  sprintf(dexes,"pjg,pig") ;
1329        }
1330
1331        /* construct variable name */
1332        if ( p->node_kind & FOURD )
1333        {
1334          sprintf(vname,"%s%s(%s,itrace)",p->name,tag,dexes) ;
1335          if ( strlen(core) > 0 )
1336            sprintf(vname2,"%s_%s%s(%s,itrace)",core,p->use,tag,dexes) ;
1337          else
1338            sprintf(vname2,"%s%s(%s,itrace)",p->name,tag,dexes) ;
1339        }
1340        else
1341        {
1342          sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
1343          if ( strlen(core) > 0 )
1344            sprintf(vname2,"%s_%s%s(%s)",core,p->name,tag,dexes) ;
1345          else
1346            sprintf(vname2,"%s%s(%s)",p->name,tag,dexes) ;
1347        }
1348
1349        grid = "grid%" ;
1350        if ( p->node_kind & FOURD )
1351        {
1352           grid = "" ;
1353fprintf(fp,"DO itrace =  PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
1354        }
1355
1356        if ( dir == UNPACKIT ) 
1357        {
1358          if ( down_path == INTERP_UP )
1359          {
1360            if ( zdex >= 0 ) {
1361fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
1362            } else {
1363fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
1364            }
1365fprintf(fp,"IF ( %s_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
1366                 corename, p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
1367            if ( zdex >= 0 ) {
1368fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], grid, vname2 ) ;
1369            } else {
1370              fprintf(fp,"%s%s = xv(1) ;\n", grid,vname2) ;
1371            }
1372fprintf(fp,"ENDIF\n") ;
1373          }
1374          else
1375          {
1376            if ( zdex >= 0 ) {
1377fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
1378                                    ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname2) ;
1379            } else {
1380fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname2) ;
1381            }
1382          }
1383        }
1384        else
1385        {
1386          if ( down_path == INTERP_UP )
1387          {
1388            if ( zdex >= 0 ) {
1389fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1390                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1391            } else {
1392fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname2) ;
1393            }
1394          }
1395          else
1396          {
1397            if ( zdex >= 0 ) {
1398fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1399                           ddim[zdex][0], ddim[zdex][1], grid, vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1400            } else {
1401fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname2) ;
1402            }
1403          }
1404        }
1405        if ( p->node_kind & FOURD )
1406        {
1407fprintf(fp,"ENDDO\n") ;
1408        }
1409      }
1410    }
1411  }
1412
1413  return(0) ;
1414}
1415
1416/*****************/
1417
1418int
1419count_fields ( node_t * node , int * d2 , int * d3 , char * corename , int down_path )
1420{
1421  node_t * p ;
1422  int zdex ;
1423/* count up the total number of levels from all fields */
1424  for ( p = node ;  p != NULL ; p = p->next )
1425  {
1426    if ( p->node_kind == FOURD ) 
1427    {
1428      count_fields( p->members , d2 , d3 , corename , down_path ) ;  /* RECURSE */
1429    }
1430    else
1431    {
1432      if ( p->io_mask & down_path )
1433      {
1434        if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1435        {
1436          if ( p->node_kind == FOURD )
1437            zdex = get_index_for_coord( p->members , COORD_Z ) ;
1438          else
1439            zdex = get_index_for_coord( p , COORD_Z ) ;
1440 
1441          if ( zdex < 0 ) {
1442            (*d2)++ ;   /* if no zdex then only 2 d */
1443          } else {
1444            (*d3)++ ;   /* if has a zdex then 3 d */
1445          }
1446        }
1447      }
1448    }
1449  }
1450  return(0) ;
1451}
1452
1453/*****************/
1454
1455int
1456gen_comms ( char * dirname )
1457{
1458  if ( sw_dm_parallel )
1459    fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
1460
1461  gen_halos( "inc" , NULL, Halos ) ;
1462  gen_shift( "inc" ) ;
1463  gen_periods( "inc", Periods ) ;
1464  gen_swaps( "inc", Swaps ) ;
1465  gen_cycles( "inc", Cycles ) ;
1466  gen_xposes( "inc" ) ;
1467  gen_comm_descrips( "inc" ) ;
1468  gen_datacalls( "inc" ) ;
1469  gen_nest_packing( "inc" ) ;
1470
1471  return(0) ;
1472}
1473
Note: See TracBrowser for help on using the repository browser.