source: trunk/WRF.COMMON/WRFV2/external/RSL/gen_comms.c @ 3992

Last change on this file since 3992 was 11, checked in by aslmd, 15 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 45.5 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 )
15{
16  node_t * p, * q ;
17  node_t * dimd ;
18  char commname[NAMELEN] ;
19  char fname[NAMELEN] ;
20  char tmp[4096], tmp2[4096], tmp3[4096] ;
21  char commuse[4096] ;
22  int maxstenwidth, stenwidth ;
23  FILE * fp ;
24  char * t1, * t2 ;
25  char * pos1 , * pos2 ;
26  char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
27  int zdex ;
28
29  if ( dirname == NULL ) return(1) ;
30
31  for ( p = Halos ; p != NULL ; p = p->next )
32  {
33    strcpy( commname, p->name ) ;
34    make_upper_case(commname) ;
35    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
36    else                       { sprintf(fname,"%s.inc",commname) ; }
37    if ((fp = fopen( fname , "w" )) == NULL ) 
38    {
39      fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
40      continue ; 
41    }
42    /* get maximum stencil width */
43    maxstenwidth = 0 ;
44    strcpy( tmp, p->comm_define ) ;
45    t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
46    while ( t1 != NULL )
47    {
48      strcpy( tmp2 , t1 ) ;
49      if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
50       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
51      stenwidth = atoi (t2) ;
52      if ( stenwidth == 0 )
53       { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
54      if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
55      t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
56    }
57    print_warning(fp,fname) ;
58    fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
59    fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
60    fprintf(fp,"    BECAUSE IT CONTAINS AN RSL HALO OPERATION\n" ) ;
61    fprintf(fp,"#endif\n") ;
62
63    fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
64    fprintf(fp,"  CALL wrf_debug ( 50 , 'set up halo %s' )\n",commname ) ;
65    fprintf(fp,"  CALL setup_halo_rsl( grid )\n" ) ;
66    fprintf(fp,"  CALL reset_msgs_%dpt\n", maxstenwidth ) ;
67
68    /* pass through description again now and generate the calls  */
69    strcpy( tmp, p->comm_define ) ;
70    strcpy( commuse, p->use ) ;
71    t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
72    while ( t1 != NULL )
73    {
74      strcpy( tmp2 , t1 ) ;
75      if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
76       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
77      stenwidth = atoi (t2) ;
78      t2 = strtok_rentr(NULL,", ", &pos2) ;
79
80      while ( t2 != NULL )
81      {
82        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
83        {
84          fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ;
85        }
86        else
87        {
88
89          strcpy( varref, t2 ) ;
90          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
91             if ( !strncmp( q->use,  "dyn_", 4 )) {
92                  char * core ;
93                  core = q->use+4 ;
94                  sprintf(varref,"grid%%%s_%s",core,t2) ;
95             } else {
96                  sprintf(varref,"grid%%%s",t2) ;
97             }
98          }
99
100          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
101          {
102            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) ;
103          }
104          else if ( q->boundary_array )
105          {
106            fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ;
107          }
108          else
109          {
110            if ( q->node_kind & FOURD )
111            {
112              node_t *member ;
113              zdex = get_index_for_coord( q , COORD_Z ) ;
114              if ( zdex >=1 && zdex <= 3 )
115              {
116                for ( member = q->members ; member != NULL ; member = member->next )
117                {
118                  if ( strcmp( member->name, "-" ) )
119                  {
120                    fprintf(fp,"  if ( P_%s .GT. 1 ) CALL add_msg_%dpt_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n", 
121                       member->name, stenwidth, q->type->name, t2 , member->name, zdex+1 ) ;
122                  }
123                }
124              }
125              else
126              {
127                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
128              }
129            }
130            else
131            {
132              strcpy (indices,"");
133              if ( sw_deref_kludge ) /* &&  strchr (t2, '%') != NULLCHARPTR ) */
134              {
135                sprintf(post,")") ;
136                sprintf(indices, "%s",index_with_firstelem("(","",tmp3,q,post)) ;
137              }
138              dimd = get_dimnode_for_coord( q , COORD_Z ) ;
139              zdex = get_index_for_coord( q , COORD_Z ) ;
140              if ( dimd != NULL )
141              {
142                char dimstrg[256] ;
143
144                if      ( dimd->len_defined_how == DOMAIN_STANDARD )
145                    sprintf(dimstrg,"(glen(%d))",zdex+1) ;
146                else if ( dimd->len_defined_how == NAMELIST )
147                {
148                  if ( !strcmp(dimd->assoc_nl_var_s,"1") )
149                    sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
150                  else
151                    sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
152                }
153                else if ( dimd->len_defined_how == CONSTANT )
154                    sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
155
156                fprintf(fp,"  CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, dimstrg ) ;
157              }
158              else if ( q->ndims == 2 )  /* 2d */
159              {
160                fprintf(fp,"  CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, "1" ) ;
161              }
162            }
163          }
164          q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
165        }
166        t2 = strtok_rentr( NULL , ", " , &pos2 ) ;
167      }
168      t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
169    }
170    fprintf(fp,"  CALL stencil_%dpt ( grid%%domdesc , grid%%comms ( %s ) )\n", maxstenwidth , commname ) ;
171    fprintf(fp,"ENDIF\n") ;
172    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchange halo %s' )\n",commname ) ;
173    fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%comms( %s ) )\n", commname ) ;
174
175    close_the_file(fp) ;
176  }
177  return(0) ;
178}
179
180int
181gen_periods ( char * dirname )
182{
183  node_t * p, * q ;
184  char commname[NAMELEN] ;
185  char fname[NAMELEN] ;
186  char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
187  char tmp[4096], tmp2[4096], tmp3[4096], commuse[4096] ;
188  int maxperwidth, perwidth ;
189  FILE * fp ;
190  char * t1, * t2 ;
191  char * pos1 , * pos2 ;
192  node_t * dimd ;
193  int zdex ;
194
195  if ( dirname == NULL ) return(1) ;
196
197  for ( p = Periods ; p != NULL ; p = p->next )
198  {
199    strcpy( commname, p->name ) ;
200    make_upper_case(commname) ;
201    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
202    else                       { sprintf(fname,"%s.inc",commname) ; }
203    if ((fp = fopen( fname , "w" )) == NULL ) 
204    {
205      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
206      continue ; 
207    }
208    /* get maximum stencil width */
209    maxperwidth = 0 ;
210    strcpy( tmp, p->comm_define ) ;
211    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
212    while ( t1 != NULL )
213    {
214      strcpy( tmp2 , t1 ) ;
215      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
216       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
217      perwidth = atoi (t2) ;
218      if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
219      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
220    }
221    print_warning(fp,fname) ;
222
223    fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
224    fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
225    fprintf(fp,"    BECAUSE IT CONTAINS AN RSL PERIOD OPERATION\n" ) ;
226    fprintf(fp,"#endif\n") ;
227    fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value .AND. (config_flags%%periodic_x .OR. config_flags%%periodic_y )) THEN\n",commname ) ;
228
229    fprintf(fp,"  CALL wrf_debug ( 50 , 'setting up period %s' )\n",commname ) ;
230    fprintf(fp,"  CALL setup_period_rsl( grid )\n" ) ;
231    fprintf(fp,"  CALL reset_period\n") ;
232
233    /* pass through description again now and generate the calls  */
234    strcpy( tmp, p->comm_define ) ;
235    strcpy( commuse, p->use ) ;
236    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
237    while ( t1 != NULL )
238    {
239      strcpy( tmp2 , t1 ) ;
240      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
241       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
242      perwidth = atoi (t2) ;
243      t2 = strtok_rentr(NULL,",", &pos2) ;
244      while ( t2 != NULL )
245      {
246        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
247        {
248          fprintf(stderr,"WARNING 2 : %s in period spec %s is not defined in registry.\n",t2,commname) ;
249        }
250        else
251        {
252          if ( q->boundary_array )
253          {
254            fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ;
255          }
256          else
257          {
258
259            strcpy( varref, t2 ) ;
260            if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
261               if ( !strncmp( q->use,  "dyn_", 4 )) {
262                    char * core ;
263                    core = q->use+4 ;
264                    sprintf(varref,"grid%%%s_%s",core,t2) ;
265               } else {
266                    sprintf(varref,"grid%%%s",t2) ;
267               }
268            }
269
270            if ( q->node_kind & FOURD )
271            {
272              node_t *member ;
273              zdex = get_index_for_coord( q , COORD_Z ) ;
274              if ( zdex >=1 && zdex <= 3 )
275              {
276                for ( member = q->members ; member != NULL ; member = member->next )
277                {
278                  if ( strcmp( member->name, "-" ) )
279                  {
280                    fprintf(fp,"  if ( P_%s .GT. 1 ) CALL add_msg_period_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
281                       member->name, q->type->name, t2 , member->name, zdex+1 ) ;
282                  }
283                }
284              }
285              else
286              {
287                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
288              }
289            }
290            else
291            {
292              strcpy (indices,"");
293              if ( sw_deref_kludge ) /* &&  strchr (t2, '%') != NULLCHARPTR ) */
294              {
295                sprintf(post,")") ;
296                sprintf(indices, "%s",index_with_firstelem("(","",tmp3,q,post)) ;
297              }
298              dimd = get_dimnode_for_coord( q , COORD_Z ) ;
299              zdex = get_index_for_coord( q , COORD_Z ) ;
300              if ( dimd != NULL )
301              {
302                char dimstrg[256] ;
303
304                if      ( dimd->len_defined_how == DOMAIN_STANDARD )
305                    sprintf(dimstrg,"(glen(%d))",zdex+1) ;
306                else if ( dimd->len_defined_how == NAMELIST )
307                {
308                  if ( !strcmp(dimd->assoc_nl_var_s,"1") )
309                    sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
310                  else
311                    sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
312                }
313                else if ( dimd->len_defined_how == CONSTANT )
314                    sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
315
316                fprintf(fp,"  CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, dimstrg ) ;
317              }
318              else if ( q->ndims == 2 )  /* 2d */
319              {
320                fprintf(fp,"  CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, "1" ) ;
321              }
322            }
323          }
324          q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
325        }
326        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
327      }
328      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
329    }
330    fprintf(fp,"  CALL period_def ( grid%%domdesc , grid%%comms ( %s ) , %d )\n",commname , maxperwidth ) ;
331    fprintf(fp,"ENDIF\n") ;
332    fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ; 
333    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchanging period %s on x' )\n",commname ) ;
334    fprintf(fp,"  CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , x_period_flag )\n",commname ) ;
335    fprintf(fp,"END IF\n") ; 
336    fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
337    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchanging period %s on y' )\n",commname ) ;
338    fprintf(fp,"  CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , y_period_flag )\n",commname ) ;
339    fprintf(fp,"END IF\n") ;
340
341    close_the_file(fp) ;
342  }
343  return(0) ;
344}
345
346int
347gen_xposes ( char * dirname )
348{
349  node_t * p, * q ;
350  char commname[NAMELEN] ;
351  char fname[NAMELEN] ;
352  char tmp[4096], tmp2[4096], tmp3[4096] ;
353  char commuse[4096] ;
354  FILE * fp ;
355  char * t1, * t2 ;
356  char * pos1 , * pos2 ;
357  char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
358  char ** x ;
359  char indices[NAMELEN], post[NAMELEN], varname[NAMELEN], varref[NAMELEN] ;
360
361  if ( dirname == NULL ) return(1) ;
362
363  for ( p = Xposes ; p != NULL ; p = p->next )
364  {
365    for ( x = xposedir ; *x ; x++ )
366    {
367      strcpy( commname, p->name ) ;
368      make_upper_case(commname) ;
369      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
370      else                       { sprintf(fname,"%s_%s.inc",commname,*x) ; }
371      if ((fp = fopen( fname , "w" )) == NULL ) 
372      {
373        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
374        continue ; 
375      }
376
377      print_warning(fp,fname) ;
378      fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
379      fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
380      fprintf(fp,"    BECAUSE IT CONTAINS AN RSL TRANSPOSE OPERATION\n" ) ;
381      fprintf(fp,"#endif\n") ;
382      fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
383
384      fprintf(fp,"  CALL wrf_debug ( 50 , 'setting up xpose %s' )\n",commname ) ;
385      fprintf(fp,"  CALL setup_xpose_rsl( grid )\n") ;
386      fprintf(fp,"  CALL reset_msgs_xpose\n" ) ;
387
388      strcpy( tmp, p->comm_define ) ;
389      strcpy( commuse, p->use ) ;
390      t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
391      while ( t1 != NULL )
392      {
393        strcpy( tmp2 , t1 ) ;
394
395/* Z array */
396        t2 = strtok_rentr(tmp2,",", &pos2) ;
397        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
398         { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
399        strcpy( varref, t2 ) ;
400        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
401           if ( !strncmp( q->use,  "dyn_", 4 )) {
402                char * core ;
403                core = q->use+4 ;
404                sprintf(varref,"grid%%%s_%s",core,t2) ;
405           } else {
406                sprintf(varref,"grid%%%s",t2) ;
407           }
408        }
409        if ( q->proc_orient != ALL_Z_ON_PROC ) 
410         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
411        if ( q->ndims != 3 )
412         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
413        if ( q->boundary_array )
414         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
415        strcpy (indices,"");
416        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
417        {
418          sprintf(post,")") ;
419          sprintf(indices, "%s",index_with_firstelem("(","",tmp3,q,post)) ;
420        }
421        fprintf(fp," CALL add_msg_xpose_%s ( %s%s ,", q->type->name, varref,indices ) ;
422        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
423
424/* X array */
425        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
426        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
427         { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
428        strcpy( varref, t2 ) ;
429        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
430           if ( !strncmp( q->use,  "dyn_", 4 )) {
431                char * core ;
432                core = q->use+4 ;
433                sprintf(varref,"grid%%%s_%s",core,t2) ;
434           } else {
435                sprintf(varref,"grid%%%s",t2) ;
436           }
437        }
438        if ( q->proc_orient != ALL_X_ON_PROC ) 
439         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
440        if ( q->ndims != 3 )
441         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
442        if ( q->boundary_array )
443         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
444        strcpy (indices,"");
445        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
446        {
447          sprintf(post,")") ;
448          sprintf(indices, "%s",index_with_firstelem("(","",tmp3,q,post)) ;
449        }
450        fprintf(fp," %s%s ,", varref, indices ) ;
451        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
452
453/* Y array */
454        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
455        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )   
456         { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
457        strcpy( varref, t2 ) ;
458        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
459           if ( !strncmp( q->use,  "dyn_", 4 )) {
460                char * core ;
461                core = q->use+4 ;
462                sprintf(varref,"grid%%%s_%s",core,t2) ;
463           } else {
464                sprintf(varref,"grid%%%s",t2) ;
465           }
466        }
467        if ( q->proc_orient != ALL_Y_ON_PROC ) 
468         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
469        if ( q->ndims != 3 )
470         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
471        if ( q->boundary_array )
472         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
473        strcpy (indices,"");
474        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
475        {
476          sprintf(post,")") ;
477          sprintf(indices, "%s",index_with_firstelem("(","",tmp3,q,post)) ;
478        }
479        fprintf(fp," %s%s , 3 )\n", varref, indices ) ;
480        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
481        t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
482      }
483      fprintf(fp,"  CALL define_xpose ( grid%%domdesc , grid%%comms ( %s ) )\n", commname ) ;
484      fprintf(fp,"ENDIF\n") ;
485      fprintf(fp,"CALL wrf_debug ( 50 , 'calling wrf_dm_xpose_%s for %s')\n",*x,commname ) ;
486      fprintf(fp,"CALL wrf_dm_xpose_%s ( grid%%domdesc , grid%%comms, %s )\n", *x , commname ) ;
487
488      close_the_file(fp) ;
489    }
490skiperific:
491    ;
492  }
493  return(0) ;
494}
495
496int
497gen_comm_descrips ( char * dirname )
498{
499  node_t * p ;
500  char * fn = "dm_comm_cpp_flags" ;
501  char commname[NAMELEN] ;
502  char fname[NAMELEN] ;
503  FILE * fp ;
504  int ncomm ;
505
506  if ( dirname == NULL ) return(1) ;
507
508  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
509  else                       { sprintf(fname,"%s",fn) ; }
510
511  if ((fp = fopen( fname , "w" )) == NULL )
512  {
513    fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
514  }
515
516  ncomm = 1 ;
517  for ( p = Halos ; p != NULL ; p = p->next )
518  {
519    strcpy( commname, p->name ) ;
520    make_upper_case(commname) ;
521    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
522  }
523  for ( p = Periods ; p != NULL ; p = p->next )
524  {
525    strcpy( commname, p->name ) ;
526    make_upper_case(commname) ;
527    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
528  }
529  for ( p = Xposes ; p != NULL ; p = p->next )
530  {
531    strcpy( commname, p->name ) ;
532    make_upper_case(commname) ;
533    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
534  }
535  fprintf(fp,"-DWRF_RSL_NCOMMS=%d\n",ncomm-1 ) ;
536  return(0) ;
537}
538
539/*
540
541
542
543*/
544
545/* for each core, generate the halo updates to allow shifting all state data */
546int
547gen_shift (  char * dirname )
548{
549  int i, ncore ;
550  FILE * fp ;
551  node_t *p, *q, *dimd ;
552  char * corename ;
553  char **direction ;
554  char *directions[] = { "x", "y", 0L } ;
555  char fname[NAMELEN], vname[NAMELEN], vname2[NAMELEN], core[NAMELEN] ;
556  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
557  int zdex ;
558int said_it = 0 ;
559
560  for ( direction = directions ; *direction != NULL ; direction++ )
561  {
562  for ( ncore = 0 ; ncore < get_num_cores() ; ncore++ )
563  {
564    corename = get_corename_i(ncore) ;
565    if ( dirname == NULL || corename == NULL ) return(1) ;
566    if ( strlen(dirname) > 0 )
567     { sprintf(fname,"%s/%s_shift_halo_%s.inc",dirname,corename,*direction) ; }
568    else
569     { sprintf(fname,"%s_shift_halo_%s.inc",corename,*direction) ; }
570    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
571    print_warning(fp,fname) ;
572    fprintf(fp,"IF ( grid%%shift_%s == invalid_message_value ) THEN\n",*direction ) ;
573    fprintf(fp,"  CALL wrf_debug ( 50 , 'set up halo for %s shift' )\n",*direction ) ;
574    fprintf(fp,"  CALL setup_halo_rsl( grid )\n" ) ;
575    fprintf(fp,"  CALL reset_msgs_%s_shift\n", *direction ) ;
576
577    for ( p = Domain.fields ; p != NULL ; p = p->next )
578    {
579
580/* special cases in WRF */
581if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
582     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
583     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
584  if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
585                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
586                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
587  said_it = 1 ; }
588  continue ;
589}
590
591      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
592          ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
593      {
594
595        if ( p->node_kind & FOURD ) {
596          sprintf(core,"") ;
597        } else {
598          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
599          else                                sprintf(core,"") ;
600        }
601
602/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
603        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
604          if ( p->type->type_type == SIMPLE )
605          {
606            for ( i = 1 ; i <= p->ntl ; i++ )
607            {
608              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
609              else              sprintf(vname,"%s",p->name ) ;
610              if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
611              else              sprintf(vname2,"%s%s",core,p->name ) ;
612              if ( p->node_kind & FOURD )
613              {
614                node_t *member ;
615                zdex = get_index_for_coord( p , COORD_Z ) ;
616                if ( zdex >=1 && zdex <= 3 )
617                {
618                  for ( member = p->members ; member != NULL ; member = member->next )
619                  {
620                    if ( strcmp( member->name, "-" ) )
621                    {
622                      fprintf(fp,
623   "  if ( P_%s .GT. 1 ) CALL add_msg_%s_shift_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
624                         member->name, *direction, p->type->name, vname, member->name, zdex+1 ) ;
625                      p->subject_to_communication = 1 ;
626                    }
627                  }
628                }
629                else
630                {
631                  fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
632                }
633              }
634              else
635              {
636                strcpy (indices,"");
637                if ( sw_deref_kludge ) /* &&  strchr (p->name, '%') != NULLCHARPTR ) */
638                {
639                  sprintf(post,")") ;
640                  sprintf(indices, "%s",index_with_firstelem("(","",tmp3,p,post)) ;
641                }
642                dimd = get_dimnode_for_coord( p , COORD_Z ) ;
643                zdex = get_index_for_coord( p , COORD_Z ) ;
644                if ( dimd != NULL )
645                {
646                  char dimstrg[256] ;
647
648                  if      ( dimd->len_defined_how == DOMAIN_STANDARD )
649                      sprintf(dimstrg,"(glen(%d))",zdex+1) ;
650                  else if ( dimd->len_defined_how == NAMELIST )
651                  {
652                    if ( !strcmp(dimd->assoc_nl_var_s,"1") )
653                      sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
654                    else
655                      sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
656                  }
657                  else if ( dimd->len_defined_how == CONSTANT )
658                      sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
659 
660                  fprintf(fp,"  CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, dimstrg ) ;
661                  p->subject_to_communication = 1 ;
662                }
663                else if ( p->ndims == 2 )  /* 2d */
664                {
665                  fprintf(fp,"  CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, "1" ) ;
666                  p->subject_to_communication = 1 ;
667                }
668              }
669            }
670          }
671        }
672      }
673    }
674    fprintf(fp,"  CALL stencil_%s_shift ( grid%%domdesc , grid%%shift_%s )\n", *direction , *direction ) ;
675    fprintf(fp,"ENDIF\n") ;
676    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchange halo for %s shift' )\n",*direction ) ;
677    fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%shift_%s )\n", *direction ) ;
678
679    for ( p = Domain.fields ; p != NULL ; p = p->next )
680    {
681
682/* special cases in WRF */
683if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
684     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
685     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
686  continue ;
687}
688      if ( p->node_kind & FOURD ) {
689        sprintf(core,"") ;
690      } else {
691        if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
692        else                                sprintf(core,"") ;
693      }
694
695      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
696          ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
697      {
698/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
699        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
700          if ( p->type->type_type == SIMPLE )
701          {
702            for ( i = 1 ; i <= p->ntl ; i++ )
703            {
704              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
705              else              sprintf(vname,"%s",p->name ) ;
706              if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
707              else              sprintf(vname2,"%s%s",core,p->name ) ;
708
709              if ( p->node_kind & FOURD )
710              {
711                node_t *member ;
712                zdex = get_index_for_coord( p , COORD_Z ) ;
713                if ( zdex >=1 && zdex <= 3 )
714                {
715                  for ( member = p->members ; member != NULL ; member = member->next )
716                  {
717                    if ( strcmp( member->name, "-" ) )
718                    {
719                      if ( !strcmp( *direction, "x" ) )
720                      {
721                        fprintf(fp,
722   "  if ( P_%s .GT. 1 ) %s ( ips:min(ide%s,ipe),:,jms:jme,P_%s) = %s (ips+px:min(ide%s,ipe)+px,:,jms:jme,P_%s)\n",
723                         member->name, vname, member->stag_x?"":"-1", member->name, vname, member->stag_x?"":"-1", member->name ) ;
724                      }
725                      else
726                      {
727                        fprintf(fp,
728   "  if ( P_%s .GT. 1 ) %s ( ims:ime,:,jps:min(jde%s,jpe),P_%s) = %s (ims:ime,:,jps+py:min(jde%s,jpe)+py,P_%s)\n",
729                         member->name, vname, member->stag_y?"":"-1", member->name, vname, member->stag_y?"":"-1", member->name ) ;
730                      }
731                    }
732                  }
733                }
734                else
735                {
736                  fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
737                }
738              }
739              else
740              {
741                char * vdim ;
742                vdim = "" ;
743                if ( p->ndims == 3 ) vdim = ":," ;
744                if ( !strcmp( *direction, "x" ) )
745                {
746                  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 ) ;
747                }
748                else
749                {
750                  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" ) ;
751                }
752              }
753            }
754          }
755        }
756      }
757    }
758    close_the_file(fp) ;
759  }
760  }
761}
762
763int
764gen_datacalls ( char * dirname )
765{
766  int i ;
767  FILE * fp ;
768  char * corename ;
769  char * fn = "data_calls.inc" ;
770  char fname[NAMELEN] ;
771
772  for ( i = 0 ; i < get_num_cores() ; i++ )
773  {
774    corename = get_corename_i(i) ;
775    if ( dirname == NULL || corename == NULL ) return(1) ;
776    if ( strlen(dirname) > 0 )
777     { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
778    else
779     { sprintf(fname,"%s_%s",corename,fn) ; }
780    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
781    print_warning(fp,fname) ;
782    fprintf(fp," CALL rsl_start_register_f90\n") ;
783    parent_type = SIMPLE;
784    gen_datacalls1( fp , corename, "grid%", FIELD , Domain.fields ) ;
785    gen_datacalls1( fp , corename, "", FOURD , Domain.fields ) ;
786    fprintf(fp,"#ifdef REGISTER_I1\n") ;
787    gen_datacalls1( fp , corename, "", I1 , Domain.fields ) ;
788    fprintf(fp,"#endif\n") ;
789    fprintf(fp," CALL rsl_end_register_f90\n") ;
790    fprintf(fp,"#define  DATA_CALLS_INCLUDED\n") ;
791    close_the_file(fp) ;
792  }
793  return(0) ;
794}
795
796int
797gen_datacalls1 ( FILE * fp , char * corename , char * structname , int mask , node_t * node )
798{
799  node_t * p, * q  ;
800  int i, member_number ;
801  char tmp[NAMELEN],tmp2[NAMELEN], tc ;
802  char indices[NAMELEN], post[NAMELEN] ;
803  char s0[NAMELEN], s1[NAMELEN], s2[NAMELEN] ;
804  char e0[NAMELEN], e1[NAMELEN], e2[NAMELEN] ;
805
806  for ( p = node ; p != NULL ; p = p->next )
807  {
808    if ( ( mask & p->node_kind ) &&
809        ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
810    {
811    if ( (p->subject_to_communication == 1) || ( p->type->type_type == DERIVED ) )
812    {
813      if ( p->type->type_type == SIMPLE )
814      {
815        if ( !strcmp( p->type->name , "real" ) ) tc = 'R' ;
816        if ( !strcmp( p->type->name , "double" ) ) tc = 'D' ;
817        if ( !strcmp( p->type->name , "integer" ) ) tc = 'I' ;
818        for ( i = 1 ; i <= p->ntl ; i++ )
819        {
820/* IF (P_QI .ge. P_FIRST_SCALAR */
821          if ( p->members != NULL )   /* a 4d array */
822          {
823            member_number = 0 ;
824            for ( q = p->members ; q != NULL ; q = q->next )
825            {
826              get_elem( "grid%", "", s0, 0, p , 0 ) ;
827              get_elem( "grid%", "", s1, 1, p , 0 ) ;
828              get_elem( "grid%", "", s2, 2, p , 0 ) ;
829
830              get_elem( "grid%", "", e0, 0, p , 1 ) ;
831              get_elem( "grid%", "", e1, 1, p , 1 ) ;
832              get_elem( "grid%", "", e2, 2, p , 1 ) ;
833
834              sprintf(tmp, "(%s,%s,%s,1+%d)", s0, s1, s2, member_number ) ;
835              sprintf(tmp2, "(%s-%s+1)*(%s-%s+1)*(%s-%s+1)*%cWORDSIZE",e0,s0,e1,s1,e2,s2,tc) ;
836              if ( p->ntl > 1 ) fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s_%d %s , &\n %s  )\n",
837                                             member_number,p->name,structname,p->name,i,tmp,tmp2) ;
838              else              fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s %s, &\n %s )\n",
839                                             member_number,p->name,structname,p->name,tmp,tmp2) ;
840              member_number++ ;
841            }
842          }
843          else
844          {
845            char ca[NAMELEN] ;
846            strcpy (indices,"");
847            if ( sw_deref_kludge )
848            {
849              sprintf(post,")") ;
850              sprintf(indices, "%s",index_with_firstelem("(","",tmp,p,post)) ;
851            }
852            strcpy( ca, "" ) ;
853            if (!strncmp( p->use , "dyn_", 4 )) { char * cb ;  cb = p->use+4 ; sprintf(ca,"%s_", cb) ; }
854            if ( p->ntl > 1 ) fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s_%d%s , SIZE( %s%s%s_%d ) * %cWORDSIZE )\n",
855                                                                                   structname,ca,p->name,i,indices,
856                                                                                   structname,ca,p->name,i,tc ) ;
857            else              fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s%s , SIZE( %s%s%s  ) * %cWORDSIZE )\n",
858                                                                                   structname,ca,p->name,indices,
859                                                                                   structname,ca,p->name, tc) ;
860          }
861        }
862      }
863      else if ( p->type->type_type == DERIVED )
864      {
865        parent_type = DERIVED;
866        sprintf( tmp , "grid%%%s%%", p->name ) ; 
867        gen_datacalls1 ( fp , corename , tmp , mask, p->type->fields ) ;
868      }
869    }
870  }
871  }
872  return(0) ;
873}
874
875/*****************/
876/*****************/
877
878gen_nest_packing ( char * dirname )
879{
880  gen_nest_pack( dirname ) ;   
881  gen_nest_unpack( dirname ) ; 
882}
883
884#define PACKIT 1
885#define UNPACKIT 2
886
887int
888gen_nest_pack ( char * dirname )
889{
890  int i ;
891  FILE * fp ;
892  char * corename ;
893  char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
894  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
895  int ipath ;
896  char ** fnp ; char * fn ;
897  char fname[NAMELEN] ;
898  node_t *node, *p, *dim ;
899  int xdex, ydex, zdex ;
900  char ddim[3][2][NAMELEN] ;
901  char mdim[3][2][NAMELEN] ;
902  char pdim[3][2][NAMELEN] ;
903  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
904  int d2, d3 ;
905
906  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
907  {
908    fn = *fnp ;
909    for ( i = 0 ; i < get_num_cores() ; i++ )
910    {
911      corename = get_corename_i(i) ;
912      if ( dirname == NULL || corename == NULL ) return(1) ;
913      if ( strlen(dirname) > 0 ) {
914       if ( strlen( corename ) > 0 )
915         { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
916       else
917         { sprintf(fname,"%s/%s",dirname,fn) ; }
918      } else { 
919       if ( strlen( corename ) > 0 ) 
920          { sprintf(fname,"%s_%s",corename,fn) ; }
921       else
922          { sprintf(fname,"%s",fn) ; }
923      }
924      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
925      print_warning(fp,fname) ;
926
927      d2 = 0 ;
928      d3 = 0 ;
929      node = Domain.fields ;
930
931      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
932
933      if ( d2 + d3 > 0 ) {
934        if ( down_path[ipath] == INTERP_UP )
935        {
936
937          fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
938          fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
939          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
940          fprintf(fp,"                        i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
941          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
942 
943          gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
944
945          fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
946          fprintf(fp,"                         msize*RWORDSIZE,                             &\n") ;
947          fprintf(fp,"                         i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
948          fprintf(fp,"ENDDO\n") ;
949
950        }
951        else
952        {
953
954          fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
955          fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
956          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
957          fprintf(fp,"                        i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
958          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
959 
960          gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
961
962          fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
963          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
964          fprintf(fp,"                        i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
965          fprintf(fp,"ENDDO\n") ;
966
967        }
968      }
969
970      close_the_file(fp) ;
971    }
972  }
973  return(0) ;
974}
975
976int
977gen_nest_unpack ( char * dirname )
978{
979  int i ;
980  FILE * fp ;
981  char * corename ;
982  char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
983  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
984  int ipath ;
985  char ** fnp ; char * fn ;
986  char fname[NAMELEN] ;
987  node_t *node, *p, *dim ;
988  int xdex, ydex, zdex ;
989  char ddim[3][2][NAMELEN] ;
990  char mdim[3][2][NAMELEN] ;
991  char pdim[3][2][NAMELEN] ;
992  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
993  int d2, d3 ;
994
995  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
996  {
997    fn = *fnp ;
998    for ( i = 0 ; i < get_num_cores() ; i++ )
999    {
1000      d2 = 0 ;
1001      d3 = 0 ;
1002      node = Domain.fields ;
1003
1004      corename = get_corename_i(i) ;
1005      if ( dirname == NULL || corename == NULL ) return(1) ;
1006      if ( strlen(dirname) > 0 )
1007       { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
1008      else
1009       { sprintf(fname,"%s_%s",corename,fn) ; }
1010      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1011      print_warning(fp,fname) ;
1012
1013      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
1014
1015      if ( d2 + d3 > 0 ) {
1016        if ( down_path[ipath] == INTERP_UP )
1017        {
1018
1019          fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
1020          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1021
1022          gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
1023
1024          fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
1025          fprintf(fp,"ENDDO\n") ;
1026
1027        }
1028        else
1029        {
1030
1031          fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
1032          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1033          gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
1034          fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
1035          fprintf(fp,"ENDDO\n") ;
1036
1037        }
1038      }
1039
1040      close_the_file(fp) ;
1041    }
1042  }
1043  return(0) ;
1044}
1045
1046int
1047gen_nest_packunpack ( FILE *fp , node_t * node , char * corename, int dir, int down_path )
1048{
1049  int i ;
1050  node_t *p, *p1, *dim ;
1051  int d2, d3, xdex, ydex, zdex ;
1052  char ddim[3][2][NAMELEN] ;
1053  char mdim[3][2][NAMELEN] ;
1054  char pdim[3][2][NAMELEN] ;
1055  char vname[NAMELEN], vname2[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
1056  char c, d ;
1057
1058  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
1059  {
1060
1061    if ( p1->node_kind & FOURD )
1062    {
1063      gen_nest_packunpack ( fp, p1->members, corename, dir , down_path ) ;  /* RECURSE over members */
1064      continue ;
1065    }
1066    else
1067    {
1068      p = p1 ;
1069    }
1070
1071    if ( p->io_mask & down_path )
1072    {
1073      if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1074      {
1075
1076        if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
1077        else                                sprintf(core,"") ;
1078
1079        if ( p->ntl > 1 ) sprintf(tag,"_2") ;
1080        else              sprintf(tag,"") ;
1081
1082        set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
1083        zdex = get_index_for_coord( p , COORD_Z ) ;
1084        xdex = get_index_for_coord( p , COORD_X ) ;
1085        ydex = get_index_for_coord( p , COORD_Y ) ;
1086
1087        if ( down_path == INTERP_UP )
1088        {
1089          c = ( dir == PACKIT )?'n':'p' ;
1090          d = ( dir == PACKIT )?'2':'1' ;
1091        } else {
1092          c = ( dir == UNPACKIT )?'n':'p' ;
1093          d = ( dir == UNPACKIT )?'2':'1' ;
1094        }
1095
1096        if ( zdex >= 0 ) {
1097          if      ( xdex == 0 && zdex == 1 && ydex == 2 )  sprintf(dexes,"pig,k,pjg") ;
1098          else if ( zdex == 0 && xdex == 1 && ydex == 2 )  sprintf(dexes,"k,pig,pjg") ;
1099          else if ( xdex == 0 && ydex == 1 && zdex == 2 )  sprintf(dexes,"pig,pjg,k") ;
1100        } else {
1101          if ( xdex == 0 && ydex == 1 )  sprintf(dexes,"pig,pjg") ;
1102          if ( ydex == 0 && xdex == 1 )  sprintf(dexes,"pjg,pig") ;
1103        }
1104
1105        /* construct variable name */
1106        if ( p->scalar_array_member )
1107        {
1108          sprintf(vname,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
1109          if ( strlen(core) > 0 )
1110            sprintf(vname2,"%s_%s%s(%s,P_%s)",core,p->use,tag,dexes,p->name) ;
1111          else
1112            sprintf(vname2,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
1113        }
1114        else
1115        {
1116          sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
1117          if ( strlen(core) > 0 )
1118            sprintf(vname2,"%s_%s%s(%s)",core,p->name,tag,dexes) ;
1119          else
1120            sprintf(vname2,"%s%s(%s)",p->name,tag,dexes) ;
1121        }
1122
1123        if ( p->scalar_array_member )
1124        {
1125fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1126        }
1127
1128        if ( dir == UNPACKIT ) 
1129        {
1130          if ( down_path == INTERP_UP )
1131          {
1132            if ( zdex >= 0 ) {
1133fprintf(fp,"CALL rsl_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
1134            } else {
1135fprintf(fp,"CALL rsl_from_child_msg(RWORDSIZE,xv)\n" ) ;
1136            }
1137fprintf(fp,"IF ( %s_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
1138                 corename, p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
1139            if ( zdex >= 0 ) {
1140fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(grid%%%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], vname2 ) ;
1141            } else {
1142fprintf(fp,"grid%%%s = xv(1) ;\n", vname2) ;
1143            }
1144fprintf(fp,"ENDIF\n") ;
1145          }
1146          else
1147          {
1148            if ( zdex >= 0 ) {
1149fprintf(fp,"CALL rsl_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\ngrid%%%s = xv(k)\nENDDO\n",
1150                                    ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], vname2) ;
1151            } else {
1152fprintf(fp,"CALL rsl_from_parent_msg(RWORDSIZE,xv)\ngrid%%%s = xv(1)\n", vname2) ;
1153            }
1154          }
1155        }
1156        else
1157        {
1158          if ( down_path == INTERP_UP )
1159          {
1160            if ( zdex >= 0 ) {
1161fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1162                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1163            } else {
1164fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_to_parent_msg(RWORDSIZE,xv)\n", vname2) ;
1165            }
1166          }
1167          else
1168          {
1169            if ( zdex >= 0 ) {
1170fprintf(fp,"DO k = %s,%s\nxv(k)= grid%%%s\nENDDO\nCALL rsl_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1171                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1172            } else {
1173fprintf(fp,"xv(1)=grid%%%s\nCALL rsl_to_child_msg(RWORDSIZE,xv)\n", vname2) ;
1174            }
1175          }
1176        }
1177        if ( p->scalar_array_member )
1178        {
1179fprintf(fp,"ENDIF\n") ;
1180        }
1181      }
1182    }
1183  }
1184
1185  return(0) ;
1186}
1187
1188/*****************/
1189
1190int
1191count_fields ( node_t * node , int * d2 , int * d3 , char * corename , int down_path )
1192{
1193  node_t * p ;
1194  int zdex ;
1195/* count up the total number of levels from all fields */
1196  for ( p = node ;  p != NULL ; p = p->next )
1197  {
1198    if ( p->node_kind == FOURD ) 
1199    {
1200      count_fields( p->members , d2 , d3 , corename , down_path ) ;  /* RECURSE */
1201    }
1202    else
1203    {
1204      if ( p->io_mask & down_path )
1205      {
1206        if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1207        {
1208          if ( p->node_kind == FOURD )
1209            zdex = get_index_for_coord( p->members , COORD_Z ) ;
1210          else
1211            zdex = get_index_for_coord( p , COORD_Z ) ;
1212 
1213          if ( zdex < 0 ) {
1214            (*d2)++ ;   /* if no zdex then only 2 d */
1215          } else {
1216            (*d3)++ ;   /* if has a zdex then 3 d */
1217          }
1218        }
1219      }
1220    }
1221  }
1222  return(0) ;
1223}
1224
1225/*****************/
1226
1227int
1228gen_comms ( char * dirname )
1229{
1230  if ( sw_dm_parallel )
1231    fprintf(stderr,"ADVISORY: RSL version of gen_comms is linked in with registry program.\n") ;
1232
1233  gen_halos( "inc" ) ;
1234  gen_shift( "inc" ) ;
1235  gen_periods( "inc" ) ;
1236  gen_xposes( "inc" ) ;
1237  gen_comm_descrips( "inc" ) ;
1238  gen_datacalls( "inc" ) ;
1239  gen_nest_packing( "inc" ) ;
1240
1241  return(0) ;
1242}
1243
Note: See TracBrowser for help on using the repository browser.