?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
updated top-level README and version_decl for V4.4.2 (#1795)
[WRF.git] / external / RSL_LITE / gen_comms.c
blob2a6b2ef5bdf39191119b6ba2eddc1fa5d30d7f32
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4
5 #ifdef _WIN32
6 #define index(X,Y) strchr(X,Y)
7 #endif
8
9 #include "protos.h"
10 #include "registry.h"
11 #include "data.h"
12
13 /* For detecting variables that are members of a derived type */
14 #define NULLCHARPTR (char *) 0
15 static int parent_type;
16
17 /* print actual and dummy arguments and declarations for 4D and i1 arrays */
18 #if ( WRFPLUS == 1 )
19 int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */, int du /* 0=dummy,1=actual */, int nta /* 0=NLM,1=TLM,2=ADM */)
20 #else
21 int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */, int du /* 0=dummy,1=actual */)
22 #endif
23 {
24 node_t * q ;
25 node_t * dimd ;
26 char fname[NAMELEN] ;
27 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
28 char commuse[NAMELEN] ;
29 int maxstenwidth, stenwidth ;
30 char * t1, * t2 , *wordsize ;
31 char varref[NAMELEN], moredims[80] ;
32 char * pos1 , * pos2 ;
33 char * dimspec ;
34 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
35 int zdex, d ;
36
37 set_mark( 0, Domain.fields ) ;
38
39 strcpy( tmp, p->comm_define ) ;
40 strcpy( commuse, p->use ) ;
41 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
42 while ( t1 != NULL )
43 {
44 strcpy( tmp2 , t1 ) ;
45 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
46 {
47 fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ;
48 }
49 t2 = strtok_rentr(NULL,",", &pos2) ;
50 while ( t2 != NULL )
51 {
52 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
53 { fprintf(stderr,"WARNING 1a : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
54 else
55 {
56 strcpy( varref, t2 ) ;
57 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
58 sprintf(varref,"grid%%%s",t2) ;
59 }
60
61 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
62 else if ( q->boundary_array ) { ; }
63 else
64 {
65 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
66 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
67 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
68 if ( q->node_kind & FOURD )
69 {
70 node_t *member ;
71 zdex = get_index_for_coord( q , COORD_Z ) ;
72 if ( zdex >=1 && zdex <= 3 )
73 {
74 set_mem_order( q->members, memord , 3 ) ;
75 if ( ad == 0 )
76 /* actual or dummy argument */
77 {
78 /* explicit dummy or actual arguments for 4D arrays */
79 if ( q->mark == 0 ) {
80 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
81 fprintf(fp," num_%s, &\n",q->name) ;
82 }
83 for ( d = 3 ; d < q->ndims ; d++ ) {
84 char *colon, r[80],tx[80] ;
85 strcpy(r,"") ;
86 range_of_dimension(r,tx,d,q,du?"":"config_flags%") ;
87 colon = index(tx,':') ; *colon = '\0' ;
88 if ( du ) { /* dummy args */
89 fprintf(fp,"%s_sdim%d,%s_edim%d, &\n",q->name,d-2,q->name,d-2) ;
90 } else {
91 fprintf(fp,"%s,%s,&\n",tx,colon+1) ;
92 }
93
94 }
95 q->mark = 1 ;
96 }
97 #if ( WRFPLUS == 1 )
98 if ( nta == 0 ) fprintf(fp," %s, &\n",varref) ;
99 if ( nta == 1 ) {
100 fprintf(fp," %s, &\n",varref) ;
101 fprintf(fp," g_%s, &\n",varref) ;
102 }
103 if ( nta == 2 ) fprintf(fp," a_%s, &\n",varref) ;
104 #else
105 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
106 fprintf(fp," %s, &\n",varref) ;
107 } else {
108 fprintf(fp," num_%s, &\n","chem") ;
109 }
110 #endif
111 }
112 else
113 {
114 /* declaration of dummy arguments for 4D arrays */
115 if ( q->mark == 0 ) {
116 fprintf(fp," INTEGER, INTENT(IN) :: num_%s\n",q->name) ;
117 for ( d = 3 ; d < q->ndims ; d++ ) {
118 fprintf(fp," INTEGER, INTENT(IN) :: %s_sdim%d,%s_edim%d\n",q->name,d-2,q->name,d-2) ;
119 }
120
121 q->mark = 1 ;
122 }
123 strcpy(moredims,"") ;
124 for ( d = 3 ; d < q->ndims ; d++ ) {
125 char temp[80] ;
126 sprintf(temp,",%s_sdim%d:%s_edim%d",q->name,d-2,q->name,d-2) ;
127 strcat(moredims,temp) ;
128 }
129 strcat(moredims,",") ;
130
131 #if ( WRFPLUS == 1 )
132 if ( nta == 0 )
133 fprintf(fp," %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
134 q->type->name , varref , moredims, q->name ) ;
135 if ( nta == 1 ) {
136 fprintf(fp," %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
137 q->type->name , varref , moredims, q->name ) ;
138 fprintf(fp," %s, INTENT(INOUT) :: g_%s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
139 q->type->name , varref , moredims, q->name ) ;
140 }
141 if ( nta == 2 )
142 fprintf(fp," %s, INTENT(INOUT) :: a_%s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
143 q->type->name , varref , moredims, q->name ) ;
144 #else
145 dimspec=dimension_with_ranges( "grid%","",-1,tmp3,q,"","" ) ;
146 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
147 fprintf(fp," %s, INTENT(INOUT) :: %s ( %s %snum_%s)\n",
148 q->type->name , varref , dimspec, moredims, q->name ) ;
149 } else {
150 fprintf(fp," INTEGER, INTENT(IN) :: num_%s\n","chem") ;
151 }
152 #endif
153 }
154 }
155 else
156 {
157 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
158 }
159 }
160 else if ( q->node_kind & I1 )
161 {
162 if ( ad == 0 )
163 {
164 /* explicit dummy or actual arguments for i1 arrays */
165 #if ( WRFPLUS == 1 )
166 if ( nta == 0 ) fprintf(fp," %s, &\n",varref) ;
167 if ( nta == 1 ) {
168 fprintf(fp," %s, &\n",varref) ;
169 fprintf(fp," g_%s, &\n",varref) ;
170 }
171 if ( nta == 2 ) fprintf(fp," a_%s, &\n",varref) ;
172 #else
173 fprintf(fp," %s, &\n",varref) ;
174 #endif
175 }
176 else
177 {
178 /* declaration of dummy arguments for i1 arrays */
179 strcpy(tmp3,"") ;
180 dimspec=dimension_with_ranges( "grid%","(",-1,tmp3,q,")","" ) ;
181 #if ( WRFPLUS == 1 )
182 if ( nta == 0 )
183 fprintf(fp," %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
184 if ( nta == 1 ) {
185 fprintf(fp," %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
186 fprintf(fp," %s, INTENT(INOUT) :: g_%s %s\n", q->type->name , varref , dimspec ) ;
187 }
188 if ( nta == 2 )
189 fprintf(fp," %s, INTENT(INOUT) :: a_%s %s\n", q->type->name , varref , dimspec ) ;
190 #else
191 fprintf(fp," %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
192 #endif
193 }
194 }
195 }
196 }
197 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
198 }
199 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
200 }
201 return 0; /* SamT: bug fix: return a value */
202 }
203
204 int print_call_or_def( FILE * fp , node_t *p, char * callorsub,
205 #if ( WRFPLUS == 1 )
206 char * commname, int nta /* 0=NLM,1=TLM,2=ADM */, char * communicator,
207 #else
208 char * commname, char * communicator,
209 #endif
210 int need_config_flags )
211 {
212 #if ( WRFPLUS == 1 )
213 if ( nta == 0 ) { fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ; }
214 if ( nta == 1 ) { fprintf(fp,"%s %s_TL_sub ( grid, &\n",callorsub,commname) ; }
215 if ( nta == 2 ) { fprintf(fp,"%s %s_AD_sub ( grid, &\n",callorsub,commname) ; }
216 #else
217 fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ;
218 #endif
219 if (need_config_flags == 1)
220 fprintf(fp," config_flags, &\n") ;
221 #if ( WRFPLUS == 1 )
222 print_4d_i1_decls( fp, p, 0, (!strcmp("CALL",callorsub))?0:1, nta );
223 #else
224 print_4d_i1_decls( fp, p, 0, (!strcmp("CALL",callorsub))?0:1 );
225 #endif
226 fprintf(fp," %s, &\n",communicator) ;
227 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
228 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
229 fprintf(fp," ims, ime, jms, jme, kms, kme, &\n") ;
230 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
231 return(0) ;
232 }
233
234 int print_decl( FILE * fp , node_t *p, char * communicator,
235 #if ( WRFPLUS == 1 )
236 int need_config_flags, int nta /* 0=NLM,1=TLM,2=ADM */ )
237 #else
238 int need_config_flags )
239 #endif
240 {
241 fprintf(fp," USE module_domain, ONLY:domain\n") ;
242 fprintf(fp," USE module_configure, ONLY:grid_config_rec_type,in_use_for_config\n") ;
243 fprintf(fp," USE module_state_description, ONLY:PARAM_FIRST_SCALAR\n") ;
244 fprintf(fp," USE module_driver_constants\n") ;
245 fprintf(fp," TYPE(domain) , INTENT(IN) :: grid\n") ;
246 if (need_config_flags == 1)
247 fprintf(fp," TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags\n") ;
248 #if ( WRFPLUS == 1 )
249 print_4d_i1_decls( fp, p, 1, 0, nta );
250 #else
251 print_4d_i1_decls( fp, p, 1, 0 );
252 #endif
253 fprintf(fp," INTEGER , INTENT(IN) :: %s\n",communicator) ;
254 fprintf(fp," INTEGER , INTENT(IN) :: mytask, ntasks, ntasks_x, ntasks_y\n") ;
255 fprintf(fp," INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde\n") ;
256 fprintf(fp," INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme\n") ;
257 fprintf(fp," INTEGER , INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe\n") ;
258 fprintf(fp," INTEGER :: itrace\n") ;
259 fprintf(fp," INTEGER :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p\n") ;
260 fprintf(fp," INTEGER :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m\n") ;
261 fprintf(fp," LOGICAL, EXTERNAL :: rsl_comm_iter\n") ;
262 fprintf(fp," INTEGER :: idim1, idim2, idim3, idim4, idim5, idim6, idim7\n") ;
263 return 0; /* SamT: bug fix: return a value */
264 }
265
266 #if ( WRFPLUS == 1 )
267 int print_body( FILE * fp, char * commname, int nta /* 0=NLM,1=TLM,2=ADM */ )
268 #else
269 int print_body( FILE * fp, char * commname )
270 #endif
271 {
272 fprintf(fp," \n") ;
273 fprintf(fp,"CALL push_communicators_for_domain( grid%%id )\n") ;
274 fprintf(fp,"#ifdef DM_PARALLEL\n") ;
275 #if ( WRFPLUS == 1 )
276 if ( nta == 0 ) { fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ; }
277 if ( nta == 1 ) { fprintf(fp,"#include \"%s_TL_inline.inc\"\n",commname) ; }
278 if ( nta == 2 ) { fprintf(fp,"#include \"%s_AD_inline.inc\"\n",commname) ; }
279 #else
280 fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ;
281 #endif
282 fprintf(fp,"#endif\n") ;
283 fprintf(fp,"CALL pop_communicators_for_domain\n") ;
284 fprintf(fp," \n") ;
285 #if ( WRFPLUS == 1 )
286 if ( nta == 0 ) { fprintf(fp," END SUBROUTINE %s_sub\n",commname) ; }
287 if ( nta == 1 ) { fprintf(fp," END SUBROUTINE %s_TL_sub\n",commname) ; }
288 if ( nta == 2 ) { fprintf(fp," END SUBROUTINE %s_AD_sub\n",commname) ; }
289 #else
290 fprintf(fp," END SUBROUTINE %s_sub\n",commname) ;
291 #endif
292 return 0; /* SamT: bug fix: return a value */
293 }
294
295 int
296 gen_halos ( char * dirname , char * incname , node_t * halos, int split )
297 {
298 node_t * p, * q ;
299 node_t * dimd ;
300 char commname[NAMELEN], subs_fname[NAMELEN] ;
301 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
302 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
303 char commuse[NAMELEN] ;
304 #define MAX_VDIMS 100
305 char vdims[MAX_VDIMS][2][80] ;
306 char s[NAMELEN], e[NAMELEN] ;
307 int vdimcurs ;
308 int maxstenwidth_int, stenwidth ;
309 char maxstenwidth[NAMELEN] ;
310 FILE * fp ;
311 FILE * fpcall ;
312 FILE * fpsub ;
313 char * t1, * t2 ;
314 char * pos1 , * pos2 ;
315 char indices[NAMELEN], post[NAMELEN] ;
316 int zdex ;
317 int n2dR, n3dR ;
318 int n2dI, n3dI ;
319 int n2dD, n3dD ;
320 int n4d ;
321 int i, foundvdim ;
322 int subgrid ;
323 int need_config_flags;
324 #define MAX_4DARRAYS 1000
325 char name_4d[MAX_4DARRAYS][NAMELEN] ;
326 #define FRAC 4
327 int num_halos, fraction, ihalo, j ;
328 int always_interp_mp = 1;
329
330 if ( dirname == NULL ) return(1) ;
331
332 if ( split ) {
333 for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) { /* howmany deez guys? */
334 if ( incname == NULL ) {
335 strcpy( commname, p->name ) ;
336 make_upper_case(commname) ;
337 }
338 else {
339 strcpy( commname, incname ) ;
340 }
341 if ( !( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN" )
342 || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) {
343 num_halos++ ;
344 }
345 }
346 }
347
348 ihalo = 0 ;
349 for ( p = halos ; p != NULL ; p = p->next )
350 {
351 need_config_flags = 0; /* 0 = do not need, 1 = need */
352 if ( incname == NULL ) {
353 strcpy( commname, p->name ) ;
354 make_upper_case(commname) ;
355 }
356 else {
357 strcpy( commname, incname ) ;
358 }
359 if ( incname == NULL ) {
360 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
361 else { sprintf(fname,"%s_inline.inc",commname) ; }
362 /* Generate call to custom routine that encapsulates inlined comm calls */
363 if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
364 else { sprintf(fnamecall,"%s.inc",commname) ; }
365 if ((fpcall = fopen( fnamecall , "w" )) == NULL )
366 {
367 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall ) ;
368 continue ;
369 }
370 print_warning(fpcall,fnamecall) ;
371
372 if ( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN")
373 || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) {
374 sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ;
375 } else {
376 if ( split ) {
377 j = ihalo / ((num_halos+1)/FRAC+1) ; /* the compiler you save may be your own */
378 sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ;
379 ihalo++ ;
380 } else {
381 sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ;
382 }
383 }
384
385 /* Generate definition of custom routine that encapsulates inlined comm calls */
386 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; }
387 else { sprintf(fnamesub,"%s",subs_fname) ; }
388 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
389 {
390 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
391 continue ;
392 }
393 print_warning(fpsub,fnamesub) ;
394 }
395 else {
396 /* for now, retain original behavior when called from gen_shift */
397 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
398 else { sprintf(fname,"%s.inc",commname) ; }
399 }
400 /* Generate inlined comm calls */
401 if ((fp = fopen( fname , "w" )) == NULL )
402 {
403 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
404 continue ;
405 }
406 /* get maximum stencil width */
407 maxstenwidth_int = 0 ;
408 strcpy( tmp, p->comm_define ) ;
409 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
410 while ( t1 != NULL )
411 {
412 strcpy( tmp2 , t1 ) ;
413 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
414 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
415 if ( !strcmp(t2,"SHW") ) {
416 stenwidth = -99 ;
417 maxstenwidth_int = -99 ; /* use a run-time computed stencil width based on nest ratio */
418 break ; /* note that SHW is set internally by gen_shift, it should never be used in a Registry file */
419 } else {
420 stenwidth = atoi (t2) ;
421 if ( stenwidth == 0 )
422 { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
423 if ( stenwidth == 4 || stenwidth == 8 ) stenwidth = 1 ;
424 else if ( stenwidth == 12 || stenwidth == 24 ) stenwidth = 2 ;
425 else if ( stenwidth == 48 ) stenwidth = 3 ;
426 else if ( stenwidth == 80 ) stenwidth = 4 ;
427 else if ( stenwidth == 120 ) stenwidth = 5 ;
428 else if ( stenwidth == 168 ) stenwidth = 6 ;
429 else
430 { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
431 if ( stenwidth > maxstenwidth_int ) maxstenwidth_int = stenwidth ;
432 }
433 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
434 }
435
436 if ( maxstenwidth_int == -99 ) {
437 sprintf(maxstenwidth,"grid%%parent_grid_ratio") ;
438 } else {
439 sprintf(maxstenwidth,"%d",maxstenwidth_int) ;
440 }
441
442 print_warning(fp,fname) ;
443
444 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
445
446 /* count up the number of 2d and 3d real arrays and their types */
447 n2dR = 0 ; n3dR = 0 ;
448 n2dI = 0 ; n3dI = 0 ;
449 n2dD = 0 ; n3dD = 0 ;
450 n4d = 0 ;
451 vdimcurs = 0 ;
452 subgrid = -1 ; /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
453 strcpy( tmp, p->comm_define ) ;
454 strcpy( commuse, p->use ) ;
455 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
456 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
457 while ( t1 != NULL )
458 {
459 strcpy( tmp2 , t1 ) ;
460 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
461 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
462 t2 = strtok_rentr(NULL,",", &pos2) ;
463 while ( t2 != NULL )
464 {
465 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
466 { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
467 else
468 {
469 if ( subgrid == -1 ) { /* first one */
470 subgrid = q->subgrid ;
471 } else if ( subgrid != q->subgrid ) {
472 fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
473 }
474 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
475 { 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) ; }
476 else if ( q->boundary_array )
477 { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
478 else
479 {
480
481 /* 20061004 -- collect all the vertical dimensions so we can use a MAX
482 on them when calling RSL_LITE_INIT_EXCH */
483
484 if ( q->ndims == 3 || q->node_kind & FOURD ) {
485 if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
486 zdex = get_index_for_coord( q , COORD_Z ) ;
487 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
488 strcpy(s,"kps") ;
489 strcpy(e,"kpe") ;
490 }
491 else if ( dimd->len_defined_how == NAMELIST ) {
492 need_config_flags = 1;
493 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
494 strcpy(s,"1") ;
495 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
496 } else {
497 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
498 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
499 }
500 }
501 else if ( dimd->len_defined_how == CONSTANT ) {
502 sprintf(s,"%d",dimd->coord_start) ;
503 sprintf(e,"%d",dimd->coord_end) ;
504 }
505 for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
506 if ( !strcmp( vdims[i][1], e ) ) {
507 foundvdim = 1 ; break ;
508 }
509 }
510 if ( ! foundvdim ) {
511 if (vdimcurs < 100 ) {
512 strcpy( vdims[vdimcurs][0], s ) ;
513 strcpy( vdims[vdimcurs][1], e ) ;
514 vdimcurs++ ;
515 } else {
516 fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
517 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
518 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
519 exit(5) ;
520 }
521 }
522 }
523 }
524
525 if ( q->node_kind & FOURD ) {
526 if ( n4d < MAX_4DARRAYS ) {
527 int d ;
528 char temp[80], tx[80], r[10], *colon ;
529 strcpy( name_4d[n4d], q->name ) ;
530 for ( d = 3 ; d < q->ndims ; d++ ) {
531 sprintf(temp,"*(%s_edim%d-%s_sdim%d+1)",q->name,d-2,q->name,d-2) ;
532 strcat( name_4d[n4d],temp) ;
533 }
534 } else {
535 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
536 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
537 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
538 exit(5) ;
539 }
540 n4d++ ;
541 }
542 else
543 {
544 if ( ! strcmp( q->type->name, "real") ) {
545 if ( q->ndims == 3 ) { n3dR++ ; }
546 else if ( q->ndims == 2 ) { n2dR++ ; }
547 } else if ( ! strcmp( q->type->name, "integer") ) {
548 if ( q->ndims == 3 ) { n3dI++ ; }
549 else if ( q->ndims == 2 ) { n2dI++ ; }
550 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
551 if ( q->ndims == 3 ) { n3dD++ ; }
552 else if ( q->ndims == 2 ) { n2dD++ ; }
553 }
554 }
555 }
556 }
557 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
558 }
559 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
560 }
561
562 /* generate the stencil init statement for Y transfer */
563 #if 0
564 fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxstenwidth,fname) ;
565 #endif
566 if ( subgrid != 0 ) {
567 fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
568 }
569
570 fprintf(fp,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
571 fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
572 fprintf(fp," 0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
573 fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
574 fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
575 fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
576 fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
577 fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
578 if ( n4d > 0 ) {
579 fprintf(fp, " %d &\n", n3dR ) ;
580 for ( i = 0 ; i < n4d ; i++ ) {
581 if (strcmp("chem_ic",name_4d[i]) != 0) {
582 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
583 } else {
584 fprintf(fp," + num_%s &\n", "chem" ) ;
585 }
586 }
587 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
588 } else {
589 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
590 }
591 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
592 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
593 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
594 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
595 if ( subgrid == 0 ) {
596 fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
597 for ( i = 0 ; i < vdimcurs ; i++ ) {
598 fprintf(fp,",%s &\n",vdims[i][1] ) ;
599 }
600 fprintf(fp,"))\n") ;
601 } else {
602 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
603 }
604
605 /* generate packs prior to stencil exchange in Y */
606 #if ( WRFPLUS == 1 )
607 gen_packs_halo( fp, p, maxstenwidth, 0, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
608 #else
609 gen_packs_halo( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
610 #endif
611 /* generate stencil exchange in Y */
612 fprintf(fp," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
613 fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
614 /* generate unpacks after stencil exchange in Y */
615 #if ( WRFPLUS == 1 )
616 gen_packs_halo( fp, p, maxstenwidth, 0, 1 , 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
617 #else
618 gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
619 #endif
620 fprintf(fp,"ENDDO\n") ;
621
622 /* generate the stencil init statement for X transfer */
623 fprintf(fp,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
624 fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
625 fprintf(fp," 1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
626 fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
627 fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
628 fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
629 fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
630 fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
631 if ( n4d > 0 ) {
632 fprintf(fp, " %d &\n", n3dR ) ;
633 for ( i = 0 ; i < n4d ; i++ ) {
634 if (strcmp("chem_ic",name_4d[i]) != 0) {
635 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
636 } else {
637 fprintf(fp," + num_%s &\n", "chem" ) ;
638 }
639 }
640 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
641 } else {
642 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
643 }
644 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
645 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
646 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
647 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
648 if ( subgrid == 0 ) {
649 fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
650 for ( i = 0 ; i < vdimcurs ; i++ ) {
651 fprintf(fp,",%s &\n",vdims[i][1] ) ;
652 }
653 fprintf(fp,"))\n") ;
654 } else {
655 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
656 }
657 /* generate packs prior to stencil exchange in X */
658 #if ( WRFPLUS == 1 )
659 gen_packs_halo( fp, p, maxstenwidth, 1, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
660 #else
661 gen_packs_halo( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
662 #endif
663 /* generate stencil exchange in X */
664 fprintf(fp," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
665 fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
666 /* generate unpacks after stencil exchange in X */
667 #if ( WRFPLUS == 1 )
668 gen_packs_halo( fp, p, maxstenwidth, 1, 1, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
669 #else
670 gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
671 #endif
672 fprintf(fp," ENDDO\n") ;
673 if ( subgrid != 0 ) {
674 fprintf(fp,"ENDIF\n") ;
675 }
676 close_the_file(fp) ;
677 if ( incname == NULL ) {
678 /* Finish call to custom routine that encapsulates inlined comm calls */
679 #if ( WRFPLUS == 1 )
680 print_call_or_def(fpcall, p, "CALL", commname, 0, "local_communicator", need_config_flags );
681 #else
682 print_call_or_def(fpcall, p, "CALL", commname, "local_communicator", need_config_flags );
683 #endif
684 close_the_file(fpcall) ;
685 /* Generate definition of custom routine that encapsulates inlined comm calls */
686 #if ( WRFPLUS == 1 )
687 print_call_or_def(fpsub, p, "SUBROUTINE", commname, 0, "local_communicator", need_config_flags );
688 print_decl(fpsub, p, "local_communicator", need_config_flags, 0);
689 print_body(fpsub, commname, 0);
690 #else
691 print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator", need_config_flags );
692 print_decl(fpsub, p, "local_communicator", need_config_flags );
693 print_body(fpsub, commname);
694 #endif
695 close_the_file(fpsub) ;
696 }
697 }
698 return(0) ;
699 }
700
701 #if ( WRFPLUS == 1 )
702 int
703 gen_halos_nta ( char * dirname , char * incname , node_t * halos, int split )
704 {
705 node_t * p, * q ;
706 node_t * dimd ;
707 char commname[NAMELEN], subs_fname[NAMELEN] ;
708 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
709 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
710 char commuse[NAMELEN] ;
711 #define MAX_VDIMS 100
712 char vdims[MAX_VDIMS][2][80] ;
713 char s[NAMELEN], e[NAMELEN] ;
714 int vdimcurs ;
715 int maxstenwidth_int, stenwidth ;
716 char maxstenwidth[NAMELEN] ;
717 /* for TLM */
718 FILE * fp1 ;
719 FILE * fpcall1 ;
720 char fname1[NAMELEN], fnamecall1[NAMELEN] ;
721 /* for ADM */
722 FILE * fp2 ;
723 FILE * fpcall2 ;
724 char fname2[NAMELEN], fnamecall2[NAMELEN] ;
725 FILE * fpsub ;
726 char * t1, * t2 ;
727 char * pos1 , * pos2 ;
728 char indices[NAMELEN], post[NAMELEN] ;
729 int zdex ;
730 int n2dR, n3dR ;
731 int n2dI, n3dI ;
732 int n2dD, n3dD ;
733 int n4d ;
734 int i, foundvdim ;
735 int subgrid ;
736 int need_config_flags;
737 #define MAX_4DARRAYS 1000
738 char name_4d[MAX_4DARRAYS][NAMELEN] ;
739 #define FRAC 4
740 int num_halos, fraction, ihalo, j ;
741 int always_interp_mp = 1 ;
742
743 if ( dirname == NULL ) return(1) ;
744
745 if ( split ) {
746 for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) { /* howmany deez guys? */
747 if ( incname == NULL ) {
748 strcpy( commname, p->name ) ;
749 make_upper_case(commname) ;
750 }
751 else {
752 strcpy( commname, incname ) ;
753 }
754 if ( !( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN" )
755 || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) {
756 num_halos++ ;
757 }
758 }
759 }
760
761 ihalo = 0 ;
762 for ( p = halos ; p != NULL ; p = p->next )
763 {
764 need_config_flags = 0; /* 0 = do not need, 1 = need */
765 if ( incname == NULL ) {
766 strcpy( commname, p->name ) ;
767 make_upper_case(commname) ;
768 }
769 else {
770 strcpy( commname, incname ) ;
771 }
772 if ( incname == NULL ) {
773 /* TLM */
774 if ( strlen(dirname) > 0 ) { sprintf(fname1,"%s/%s_TL_inline.inc",dirname,commname) ; }
775 else { sprintf(fname1,"%s_TL_inline.inc",commname) ; }
776 /* Generate call to custom routine that encapsulates inlined comm calls */
777 if ( strlen(dirname) > 0 ) { sprintf(fnamecall1,"%s/%s_TL.inc",dirname,commname) ; }
778 else { sprintf(fnamecall1,"%s_TL.inc",commname) ; }
779 if ((fpcall1 = fopen( fnamecall1 , "w" )) == NULL )
780 {
781 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall1 ) ;
782 continue ;
783 }
784 print_warning(fpcall1,fnamecall1) ;
785 /* ADM */
786 if ( strlen(dirname) > 0 ) { sprintf(fname2,"%s/%s_AD_inline.inc",dirname,commname) ; }
787 else { sprintf(fname2,"%s_AD_inline.inc",commname) ; }
788 /* Generate call to custom routine that encapsulates inlined comm calls */
789 if ( strlen(dirname) > 0 ) { sprintf(fnamecall2,"%s/%s_AD.inc",dirname,commname) ; }
790 else { sprintf(fnamecall2,"%s_AD.inc",commname) ; }
791 if ((fpcall2 = fopen( fnamecall2 , "w" )) == NULL )
792 {
793 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall2 ) ;
794 continue ;
795 }
796 print_warning(fpcall2,fnamecall2) ;
797
798 if ( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN")
799 || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) {
800 sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ;
801 } else {
802 if ( split ) {
803 j = ihalo / ((num_halos+1)/FRAC+1) ; /* the compiler you save may be your own */
804 sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ;
805 ihalo++ ;
806 } else {
807 sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ;
808 }
809 }
810
811 /* Generate definition of custom routine that encapsulates inlined comm calls */
812 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; }
813 else { sprintf(fnamesub,"%s",subs_fname) ; }
814 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
815 {
816 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
817 continue ;
818 }
819 print_warning(fpsub,fnamesub) ;
820 }
821 else {
822 /* for now, retain original behavior when called from gen_shift */
823 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
824 else { sprintf(fname,"%s.inc",commname) ; }
825 }
826 /* Generate inlined comm calls */
827 /* TLM */
828 if ((fp1 = fopen( fname1 , "w" )) == NULL )
829 {
830 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname1 ) ;
831 continue ;
832 }
833 /* ADM */
834 if ((fp2 = fopen( fname2 , "w" )) == NULL )
835 {
836 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname2 ) ;
837 continue ;
838 }
839 /* get maximum stencil width */
840 maxstenwidth_int = 0 ;
841 strcpy( tmp, p->comm_define ) ;
842 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
843 while ( t1 != NULL )
844 {
845 strcpy( tmp2 , t1 ) ;
846 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
847 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
848 if ( !strcmp(t2,"SHW") ) {
849 stenwidth = -99 ;
850 maxstenwidth_int = -99 ; /* use a run-time computed stencil width based on nest ratio */
851 break ; /* note that SHW is set internally by gen_shift, it should never be used in a Registry file */
852 } else {
853 stenwidth = atoi (t2) ;
854 if ( stenwidth == 0 )
855 { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
856 if ( stenwidth == 4 || stenwidth == 8 ) stenwidth = 1 ;
857 else if ( stenwidth == 12 || stenwidth == 24 ) stenwidth = 2 ;
858 else if ( stenwidth == 48 ) stenwidth = 3 ;
859 else if ( stenwidth == 80 ) stenwidth = 4 ;
860 else if ( stenwidth == 120 ) stenwidth = 5 ;
861 else if ( stenwidth == 168 ) stenwidth = 6 ;
862 else
863 { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
864 if ( stenwidth > maxstenwidth_int ) maxstenwidth_int = stenwidth ;
865 }
866 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
867 }
868
869 if ( maxstenwidth_int == -99 ) {
870 sprintf(maxstenwidth,"grid%%parent_grid_ratio") ;
871 } else {
872 sprintf(maxstenwidth,"%d",maxstenwidth_int) ;
873 }
874
875 /* TLM */
876 print_warning(fp1,fname1) ;
877
878 fprintf(fp1,"CALL wrf_debug(2,'calling %s')\n",fname1) ;
879 /* ADM */
880 print_warning(fp2,fname2) ;
881
882 fprintf(fp2,"CALL wrf_debug(2,'calling %s')\n",fname2) ;
883
884 /* count up the number of 2d and 3d real arrays and their types */
885 n2dR = 0 ; n3dR = 0 ;
886 n2dI = 0 ; n3dI = 0 ;
887 n2dD = 0 ; n3dD = 0 ;
888 n4d = 0 ;
889 vdimcurs = 0 ;
890 subgrid = -1 ; /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
891 strcpy( tmp, p->comm_define ) ;
892 strcpy( commuse, p->use ) ;
893 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
894 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
895 while ( t1 != NULL )
896 {
897 strcpy( tmp2 , t1 ) ;
898 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
899 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
900 t2 = strtok_rentr(NULL,",", &pos2) ;
901 while ( t2 != NULL )
902 {
903 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
904 { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
905 else
906 {
907 if ( subgrid == -1 ) { /* first one */
908 subgrid = q->subgrid ;
909 } else if ( subgrid != q->subgrid ) {
910 fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
911 }
912 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
913 { 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) ; }
914 else if ( q->boundary_array )
915 { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
916 else
917 {
918
919 /* 20061004 -- collect all the vertical dimensions so we can use a MAX
920 on them when calling RSL_LITE_INIT_EXCH */
921
922 if ( q->ndims == 3 || q->node_kind & FOURD ) {
923 if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
924 zdex = get_index_for_coord( q , COORD_Z ) ;
925 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
926 strcpy(s,"kps") ;
927 strcpy(e,"kpe") ;
928 }
929 else if ( dimd->len_defined_how == NAMELIST ) {
930 need_config_flags = 1;
931 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
932 strcpy(s,"1") ;
933 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
934 } else {
935 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
936 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
937 }
938 }
939 else if ( dimd->len_defined_how == CONSTANT ) {
940 sprintf(s,"%d",dimd->coord_start) ;
941 sprintf(e,"%d",dimd->coord_end) ;
942 }
943 for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
944 if ( !strcmp( vdims[i][1], e ) ) {
945 foundvdim = 1 ; break ;
946 }
947 }
948 if ( ! foundvdim ) {
949 if (vdimcurs < 100 ) {
950 strcpy( vdims[vdimcurs][0], s ) ;
951 strcpy( vdims[vdimcurs][1], e ) ;
952 vdimcurs++ ;
953 } else {
954 fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
955 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
956 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
957 exit(5) ;
958 }
959 }
960 }
961 }
962
963 if ( q->node_kind & FOURD ) {
964 if ( n4d < MAX_4DARRAYS ) {
965 int d ;
966 char temp[80], tx[80], r[10], *colon ;
967 strcpy( name_4d[n4d], q->name ) ;
968 for ( d = 3 ; d < q->ndims ; d++ ) {
969 sprintf(temp,"*(%s_edim%d-%s_sdim%d+1)",q->name,d-2,q->name,d-2) ;
970 strcat( name_4d[n4d],temp) ;
971 }
972 } else {
973 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
974 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
975 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
976 exit(5) ;
977 }
978 n4d++ ;
979 }
980 else
981 {
982 if ( ! strcmp( q->type->name, "real") ) {
983 if ( q->ndims == 3 ) { n3dR++ ; }
984 else if ( q->ndims == 2 ) { n2dR++ ; }
985 } else if ( ! strcmp( q->type->name, "integer") ) {
986 if ( q->ndims == 3 ) { n3dI++ ; }
987 else if ( q->ndims == 2 ) { n2dI++ ; }
988 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
989 if ( q->ndims == 3 ) { n3dD++ ; }
990 else if ( q->ndims == 2 ) { n2dD++ ; }
991 }
992 }
993 }
994 }
995 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
996 }
997 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
998 }
999
1000 /* generate the stencil init statement for Y transfer */
1001 #if 0
1002 fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxstenwidth,fname) ;
1003 #endif
1004 if ( subgrid != 0 ) {
1005 /* TLM */
1006 fprintf(fp1,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
1007 /* ADM */
1008 fprintf(fp2,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
1009 }
1010
1011 /* TLM */
1012 fprintf(fp1,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
1013 fprintf(fp1,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
1014 fprintf(fp1," 0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
1015 fprintf(fp1," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1016 fprintf(fp1," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
1017 fprintf(fp1," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
1018 fprintf(fp1," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1019 fprintf(fp1," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
1020 if ( n4d > 0 ) {
1021 fprintf(fp1, " %d &\n", 2*n3dR ) ;
1022 for ( i = 0 ; i < n4d ; i++ ) {
1023 fprintf(fp1," + 2*num_%s &\n", name_4d[i] ) ;
1024 }
1025 fprintf(fp1," , %d, RWORDSIZE, &\n", 2*n2dR ) ;
1026 } else {
1027 fprintf(fp1," %d, %d, RWORDSIZE, &\n", 2*n3dR, 2*n2dR ) ;
1028 }
1029 fprintf(fp1," %d, %d, IWORDSIZE, &\n", 2*n3dI, 2*n2dI ) ;
1030 fprintf(fp1," %d, %d, DWORDSIZE, &\n", 2*n3dD, 2*n2dD ) ;
1031 fprintf(fp1," 0, 0, LWORDSIZE, &\n" ) ;
1032 fprintf(fp1," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1033 if ( subgrid == 0 ) {
1034 fprintf(fp1," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
1035 for ( i = 0 ; i < vdimcurs ; i++ ) {
1036 fprintf(fp1,",%s &\n",vdims[i][1] ) ;
1037 }
1038 fprintf(fp1,"))\n") ;
1039 } else {
1040 fprintf(fp1,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1041 }
1042 /* ADM */
1043 fprintf(fp2,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
1044 fprintf(fp2,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
1045 fprintf(fp2," 0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
1046 fprintf(fp2," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1047 fprintf(fp2," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
1048 fprintf(fp2," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
1049 fprintf(fp2," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1050 fprintf(fp2," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
1051 if ( n4d > 0 ) {
1052 fprintf(fp2, " %d &\n", n3dR ) ;
1053 for ( i = 0 ; i < n4d ; i++ ) {
1054 fprintf(fp2," + num_%s &\n", name_4d[i] ) ;
1055 }
1056 fprintf(fp2," , %d, RWORDSIZE, &\n", n2dR ) ;
1057 } else {
1058 fprintf(fp2," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1059 }
1060 fprintf(fp2," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1061 fprintf(fp2," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1062 fprintf(fp2," 0, 0, LWORDSIZE, &\n" ) ;
1063 fprintf(fp2," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1064 if ( subgrid == 0 ) {
1065 fprintf(fp2," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
1066 for ( i = 0 ; i < vdimcurs ; i++ ) {
1067 fprintf(fp2,",%s &\n",vdims[i][1] ) ;
1068 }
1069 fprintf(fp2,"))\n") ;
1070 } else {
1071 fprintf(fp2,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1072 }
1073 /* generate packs prior to stencil exchange in Y */
1074 /* TLM */
1075 gen_packs_halo( fp1, p, maxstenwidth, 0, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1076 gen_packs_halo( fp1, p, maxstenwidth, 0, 0, 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1077 /* ADM */
1078 gen_packs_halo( fp2, p, maxstenwidth, 0, 0, 2, "RSL_LITE_PACK_AD", "local_communicator", always_interp_mp ) ;
1079 /* generate stencil exchange in Y */
1080 /* TLM */
1081 /* generate stencil exchange in Y */
1082 fprintf(fp1," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1083 fprintf(fp1," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
1084 /* ADM */
1085 /* generate stencil exchange in Y */
1086 fprintf(fp2," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1087 fprintf(fp2," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
1088 /* generate unpacks after stencil exchange in Y */
1089 /* TLM */
1090 gen_packs_halo( fp1, p, maxstenwidth, 0, 1 , 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1091 gen_packs_halo( fp1, p, maxstenwidth, 0, 1 , 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1092 /* ADM */
1093 gen_packs_halo( fp2, p, maxstenwidth, 0, 1 , 2, "RSL_LITE_PACK_AD", "local_communicator", always_interp_mp ) ;
1094 /* TLM */
1095 fprintf(fp1,"ENDDO\n") ;
1096 /* ADM */
1097 fprintf(fp2,"ENDDO\n") ;
1098
1099 /* generate the stencil init statement for X transfer */
1100 /* TLM */
1101 /* generate the stencil init statement for X transfer */
1102 fprintf(fp1,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
1103 fprintf(fp1,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
1104 fprintf(fp1," 1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
1105 fprintf(fp1," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1106 fprintf(fp1," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
1107 fprintf(fp1," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
1108 fprintf(fp1," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1109 fprintf(fp1," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
1110 if ( n4d > 0 ) {
1111 fprintf(fp1, " %d &\n", 2*n3dR ) ;
1112 for ( i = 0 ; i < n4d ; i++ ) {
1113 fprintf(fp1," + 2*num_%s &\n", name_4d[i] ) ;
1114 }
1115 fprintf(fp1," , %d, RWORDSIZE, &\n", 2*n2dR ) ;
1116 } else {
1117 fprintf(fp1," %d, %d, RWORDSIZE, &\n", 2*n3dR, 2*n2dR ) ;
1118 }
1119 fprintf(fp1," %d, %d, IWORDSIZE, &\n", 2*n3dI, 2*n2dI ) ;
1120 fprintf(fp1," %d, %d, DWORDSIZE, &\n", 2*n3dD, 2*n2dD ) ;
1121 fprintf(fp1," 0, 0, LWORDSIZE, &\n" ) ;
1122 fprintf(fp1," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1123 if ( subgrid == 0 ) {
1124 fprintf(fp1," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
1125 for ( i = 0 ; i < vdimcurs ; i++ ) {
1126 fprintf(fp1,",%s &\n",vdims[i][1] ) ;
1127 }
1128 fprintf(fp1,"))\n") ;
1129 } else {
1130 fprintf(fp1,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1131 }
1132 /* ADM */
1133 /* generate the stencil init statement for X transfer */
1134 fprintf(fp2,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
1135 fprintf(fp2,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
1136 fprintf(fp2," 1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
1137 fprintf(fp2," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1138 fprintf(fp2," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
1139 fprintf(fp2," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
1140 fprintf(fp2," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
1141 fprintf(fp2," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
1142 if ( n4d > 0 ) {
1143 fprintf(fp2, " %d &\n", n3dR ) ;
1144 for ( i = 0 ; i < n4d ; i++ ) {
1145 fprintf(fp2," + num_%s &\n", name_4d[i] ) ;
1146 }
1147 fprintf(fp2," , %d, RWORDSIZE, &\n", n2dR ) ;
1148 } else {
1149 fprintf(fp2," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1150 }
1151 fprintf(fp2," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1152 fprintf(fp2," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1153 fprintf(fp2," 0, 0, LWORDSIZE, &\n" ) ;
1154 fprintf(fp2," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1155 if ( subgrid == 0 ) {
1156 fprintf(fp2," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
1157 for ( i = 0 ; i < vdimcurs ; i++ ) {
1158 fprintf(fp2,",%s &\n",vdims[i][1] ) ;
1159 }
1160 fprintf(fp2,"))\n") ;
1161 } else {
1162 fprintf(fp2,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1163 }
1164 /* generate packs prior to stencil exchange in X */
1165 /* TLM */
1166 gen_packs_halo( fp1, p, maxstenwidth, 1, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1167 gen_packs_halo( fp1, p, maxstenwidth, 1, 0, 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1168 /* ADM */
1169 gen_packs_halo( fp2, p, maxstenwidth, 1, 0, 2, "RSL_LITE_PACK_AD", "local_communicator", always_interp_mp ) ;
1170 /* generate stencil exchange in X */
1171 /* TLM */
1172 /* generate stencil exchange in X */
1173 fprintf(fp1," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1174 fprintf(fp1," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
1175 /* ADM */
1176 /* generate stencil exchange in X */
1177 fprintf(fp2," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1178 fprintf(fp2," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
1179 /* generate unpacks after stencil exchange in X */
1180 /* TLM */
1181 gen_packs_halo( fp1, p, maxstenwidth, 1, 1, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1182 gen_packs_halo( fp1, p, maxstenwidth, 1, 1, 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ;
1183 /* ADM */
1184 gen_packs_halo( fp2, p, maxstenwidth, 1, 1, 2, "RSL_LITE_PACK_AD", "local_communicator", always_interp_mp ) ;
1185 /* TLM */
1186 fprintf(fp1," ENDDO\n") ;
1187 if ( subgrid != 0 ) {
1188 fprintf(fp1,"ENDIF\n") ;
1189 }
1190 close_the_file(fp1) ;
1191 /* ADM */
1192 fprintf(fp2," ENDDO\n") ;
1193 if ( subgrid != 0 ) {
1194 fprintf(fp2,"ENDIF\n") ;
1195 }
1196 close_the_file(fp2) ;
1197 if ( incname == NULL ) {
1198 /* Finish call to custom routine that encapsulates inlined comm calls */
1199 /* TLM */
1200 print_call_or_def(fpcall1, p, "CALL", commname, 1, "local_communicator", need_config_flags );
1201 close_the_file(fpcall1) ;
1202 /* ADM */
1203 print_call_or_def(fpcall2, p, "CALL", commname, 2, "local_communicator", need_config_flags );
1204 close_the_file(fpcall2) ;
1205 /* Generate definition of custom routine that encapsulates inlined comm calls */
1206 /* TLM */
1207 print_call_or_def(fpsub, p, "SUBROUTINE", commname, 1, "local_communicator", need_config_flags );
1208 print_decl(fpsub, p, "local_communicator", need_config_flags, 1 );
1209 print_body(fpsub, commname, 1);
1210 /* ADM */
1211 print_call_or_def(fpsub, p, "SUBROUTINE", commname, 2, "local_communicator", need_config_flags );
1212 print_decl(fpsub, p, "local_communicator", need_config_flags, 2 );
1213 print_body(fpsub, commname, 2);
1214 close_the_file(fpsub) ;
1215 }
1216 }
1217 return(0) ;
1218 }
1219 #endif
1220
1221 #if ( WRFPLUS == 1 )
1222 gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, int nta /* 0=NLM,1=TLM,2=ADM*/, char * packname, char * commname, int always_interp_mp )
1223 #else
1224 gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname, int always_interp_mp )
1225 #endif
1226 {
1227 node_t * q ;
1228 node_t * dimd ;
1229 char fname[NAMELEN] ;
1230 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG], tmp4[NAMELEN_LONG] ;
1231 char commuse[NAMELEN] ;
1232 int maxstenwidth, stenwidth ;
1233 char * t1, * t2 , *wordsize ;
1234 char varref[NAMELEN] ;
1235 char varname[NAMELEN] ;
1236 char * pos1 , * pos2 ;
1237 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
1238 int xdex,ydex,zdex ;
1239
1240 strcpy( tmp, p->comm_define ) ;
1241 strcpy( commuse, p->use ) ;
1242 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1243 while ( t1 != NULL )
1244 {
1245 strcpy( tmp2 , t1 ) ;
1246 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1247 { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
1248 t2 = strtok_rentr(NULL,",", &pos2) ;
1249 while ( t2 != NULL )
1250 {
1251 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1252 { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
1253 else
1254 {
1255
1256 strcpy( varname, t2 ) ;
1257 strcpy( varref, t2 ) ;
1258 #if ( WRFPLUS == 1 )
1259 if ( nta == 1) { sprintf(varref,"g_%s",t2) ; }
1260 if ( nta == 2 ) { sprintf(varref,"a_%s",t2) ; }
1261 #endif
1262 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1263 sprintf(varref,"grid%%%s",t2) ;
1264 #if ( WRFPLUS == 1 )
1265 if ( nta == 1) { sprintf(varref,"grid%%g_%s",t2) ; }
1266 if ( nta == 2 ) { sprintf(varref,"grid%%a_%s",t2) ; }
1267 #endif
1268 }
1269
1270 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
1271 else if ( q->boundary_array ) { ; }
1272 else
1273 {
1274 if(!always_interp_mp && p->mp_var) {
1275 fprintf(fp,"if(interp_mp) then\n");
1276 }
1277
1278 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
1279 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
1280 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
1281 if ( q->node_kind & FOURD )
1282 {
1283 node_t *member ;
1284 zdex = get_index_for_coord( q , COORD_Z ) ;
1285 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1286 if ( zdex >=1 && zdex <= 3 && dimd != NULL )
1287 {
1288 int d ;
1289 char * colon ;
1290 char moredims[80], tx[80], temp[10], r[80] ;
1291 char sd[256], ed[256] , sm[256], em[256] , sp[256], ep[256] ;
1292
1293 set_mem_order( q->members, memord , 3 ) ;
1294 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
1295 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
1296 } else {
1297 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n","chem" ) ;
1298 }
1299 strcpy(moredims,"") ;
1300 for ( d = q->ndims-1 ; d >= 3 ; d-- ) {
1301 fprintf(fp," DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ;
1302 }
1303 for ( d = 3 ; d < q->ndims ; d++ ) {
1304 strcpy(r,"") ;
1305 range_of_dimension( r, tx, d, q, "config_flags%" ) ;
1306 colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ;
1307 sprintf(temp,"idim%d",d-2) ;
1308 strcat(moredims,",") ; strcat(moredims,temp) ;
1309 }
1310 strcat(moredims,",") ;
1311 xdex = get_index_for_coord( q , COORD_X ) ;
1312 ydex = get_index_for_coord( q , COORD_Y ) ;
1313 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1314 strcpy(sd,"kds") ; strcpy(ed,"kde" ) ;
1315 strcpy(sm,"kms") ; strcpy(em,"kme" ) ;
1316 strcpy(sp,"kps") ; strcpy(ep,"kpe" ) ;
1317 } else if ( dimd->len_defined_how == NAMELIST ) {
1318 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1319 strcpy(sd,"1") ;
1320 sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1321 } else {
1322 sprintf(sd,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1323 sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1324 }
1325 strcpy(sm,sd) ; strcpy(em,ed ) ;
1326 strcpy(sp,sd) ; strcpy(ep,ed ) ;
1327 } else if ( dimd->len_defined_how == CONSTANT ) {
1328 sprintf(sd,"%d",dimd->coord_start) ; sprintf(ed,"%d",dimd->coord_end) ;
1329 strcpy(sm,sd) ; strcpy(em,ed ) ;
1330 strcpy(sp,sd) ; strcpy(ep,ed ) ;
1331 }
1332 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
1333 fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1334 fprintf(fp," CALL %s ( %s,&\n%s ( %s%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p , rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
1335 packname, commname, varref , index_with_firstelem("","grid%",-1,tmp4,q,""),moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x? 1:0):(q->stag_y?1:0) ) ;
1336 } else {
1337 fprintf(fp," IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1338 fprintf(fp," CALL %s ( %s,&\ngrid%%%s ( %s%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p , rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
1339 packname, commname, varref , index_with_firstelem("","grid%",-1,tmp4,q,""),moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x? 1:0):(q->stag_y?1:0) ) ;
1340 }
1341 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1342 if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
1343 !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
1344 fprintf(fp,"thisdomain_max_halo_width, &\n") ;
1345 }
1346 if ( q->subgrid == 0 ) {
1347 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",sd,ed) ;
1348 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",sm,em) ;
1349 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",sp,ep) ;
1350 } else {
1351 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, %s, %s, &\n",sd,ed) ;
1352 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",sm,em) ;
1353 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",sp,ep) ;
1354 }
1355 fprintf(fp," ENDIF\n") ;
1356 for ( d = 3 ; d < q->ndims ; d++ ) {
1357 fprintf(fp," ENDDO ! idim%d \n",d-2 ) ;
1358 }
1359
1360 fprintf(fp,"ENDDO\n") ;
1361 }
1362 else
1363 {
1364 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1365 }
1366 }
1367 else
1368 {
1369 set_mem_order( q, memord , 3 ) ;
1370 if ( q->ndims == 3 ) {
1371
1372 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1373 xdex = get_index_for_coord( q , COORD_X ) ;
1374 ydex = get_index_for_coord( q , COORD_Y ) ;
1375 zdex = get_index_for_coord( q , COORD_Z ) ;
1376 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1377 fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
1378 packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1379 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1380 if ( dimd != NULL )
1381 {
1382 char s[256], e[256] ;
1383 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1384 if ( q->subgrid == 0 ) {
1385 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1386 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1387 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1388 } else {
1389 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1390 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
1391 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1392 }
1393 }
1394 else if ( dimd->len_defined_how == NAMELIST )
1395 {
1396 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1397 strcpy(s,"1") ;
1398 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1399 } else {
1400 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1401 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1402 }
1403 if ( q->subgrid == 0 ) {
1404 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
1405 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
1406 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
1407 } else {
1408 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1409 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
1410 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
1411 }
1412 }
1413 else if ( dimd->len_defined_how == CONSTANT )
1414 {
1415 if ( q->subgrid == 0 ) {
1416 fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1417 fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1418 fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
1419 } else {
1420 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1421 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
1422 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
1423 }
1424 }
1425 }
1426 fprintf(fp,"ENDIF\n") ;
1427 } else if ( q->ndims == 2 ) {
1428 xdex = get_index_for_coord( q , COORD_X ) ;
1429 ydex = get_index_for_coord( q , COORD_Y ) ;
1430 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1431 fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
1432 packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1433 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1434 if ( q->subgrid == 0 ) {
1435 fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
1436 fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
1437 fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
1438 } else {
1439 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1440 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
1441 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
1442 }
1443 fprintf(fp,"ENDIF\n") ;
1444 }
1445 }
1446 if(!always_interp_mp && p->mp_var) {
1447 fprintf(fp,"endif\n");
1448 }
1449 }
1450 }
1451 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1452 }
1453 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1454 }
1455 }
1456
1457 gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )
1458 {
1459 node_t * q ;
1460 node_t * dimd ;
1461 char fname[NAMELEN] ;
1462 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
1463 char commuse[NAMELEN] ;
1464 int maxstenwidth, stenwidth ;
1465 char * t1, * t2 , *wordsize ;
1466 char varref[NAMELEN] ;
1467 char varname[NAMELEN] ;
1468 char * pos1 , * pos2 ;
1469 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
1470 int xdex,ydex,zdex ;
1471
1472 strcpy( tmp, p->comm_define ) ;
1473 strcpy( commuse, p->use ) ;
1474 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1475 while ( t1 != NULL )
1476 {
1477 strcpy( tmp2 , t1 ) ;
1478 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1479 { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
1480 t2 = strtok_rentr(NULL,",", &pos2) ;
1481 while ( t2 != NULL )
1482 {
1483 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1484 { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
1485 else
1486 {
1487
1488 strcpy( varname, t2 ) ;
1489 strcpy( varref, t2 ) ;
1490 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1491 sprintf(varref,"grid%%%s",t2) ;
1492 }
1493
1494 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
1495 else if ( q->boundary_array ) { ; }
1496 else
1497 {
1498 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
1499 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
1500 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
1501 if ( q->node_kind & FOURD )
1502 {
1503 node_t *member ;
1504 zdex = get_index_for_coord( q , COORD_Z ) ;
1505 if ( zdex >=1 && zdex <= 3 )
1506 {
1507 set_mem_order( q->members, memord , 3 ) ;
1508 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
1509 xdex = get_index_for_coord( q , COORD_X ) ;
1510 ydex = get_index_for_coord( q , COORD_Y ) ;
1511 fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1512 fprintf(fp," CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n",
1513 packname, commname, varref , shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1514 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1515 if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
1516 !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
1517 fprintf(fp,"thisdomain_max_halo_width, &\n") ;
1518 }
1519 if ( q->subgrid == 0 ) {
1520 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1521 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1522 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1523 } else {
1524 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1525 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
1526 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1527 }
1528 fprintf(fp," ENDIF\n") ;
1529 fprintf(fp,"ENDDO\n") ;
1530 }
1531 else
1532 {
1533 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1534 }
1535 }
1536 else
1537 {
1538 set_mem_order( q, memord , 3 ) ;
1539 if ( q->ndims == 3 ) {
1540
1541 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1542 xdex = get_index_for_coord( q , COORD_X ) ;
1543 ydex = get_index_for_coord( q , COORD_Y ) ;
1544 zdex = get_index_for_coord( q , COORD_Z ) ;
1545 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1546 if ( dimd != NULL )
1547 {
1548 char s[256], e[256] ;
1549
1550 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1551 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1552 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1553 if ( q->subgrid == 0 ) {
1554 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1555 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1556 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1557 } else {
1558 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1559 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
1560 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
1561 }
1562 }
1563 else if ( dimd->len_defined_how == NAMELIST )
1564 {
1565 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1566 strcpy(s,"1") ;
1567 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1568 } else {
1569 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1570 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1571 }
1572 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1573 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1574 if ( q->subgrid == 0 ) {
1575 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
1576 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
1577 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
1578 } else {
1579 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1580 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
1581 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
1582 }
1583 }
1584 else if ( dimd->len_defined_how == CONSTANT )
1585 {
1586 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1587 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1588 if ( q->subgrid == 0 ) {
1589 fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1590 fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1591 fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
1592 } else {
1593 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1594 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
1595 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
1596 }
1597 }
1598 }
1599 fprintf(fp,"ENDIF\n") ;
1600 } else if ( q->ndims == 2 ) {
1601 xdex = get_index_for_coord( q , COORD_X ) ;
1602 ydex = get_index_for_coord( q , COORD_Y ) ;
1603 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1604 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1605 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1606 if ( q->subgrid == 0 ) {
1607 fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
1608 fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
1609 fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
1610 } else {
1611 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1612 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
1613 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
1614 }
1615 fprintf(fp,"ENDIF\n") ;
1616 }
1617 }
1618 }
1619
1620 }
1621 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1622 }
1623 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1624 }
1625 }
1626
1627 int
1628 gen_periods ( char * dirname , node_t * periods )
1629 {
1630 node_t * p, * q ;
1631 node_t * dimd ;
1632 char commname[NAMELEN] ;
1633 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
1634 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1635 char commuse[NAMELEN] ;
1636 int maxperwidth, perwidth ;
1637 FILE * fp ;
1638 FILE * fpcall ;
1639 FILE * fpsub ;
1640 char * t1, * t2 ;
1641 char varref[NAMELEN] ;
1642 char * pos1 , * pos2 ;
1643 char indices[NAMELEN], post[NAMELEN] ;
1644 int zdex ;
1645 int n2dR, n3dR ;
1646 int n2dI, n3dI ;
1647 int n2dD, n3dD ;
1648 int n4d ;
1649 int i ;
1650 #define MAX_4DARRAYS 1000
1651 char name_4d[MAX_4DARRAYS][NAMELEN] ;
1652
1653 if ( dirname == NULL ) return(1) ;
1654
1655 /* Open and truncate REGISTRY_COMM_DM_PERIOD_subs.inc so file exists even if there are no periods. */
1656 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
1657 else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
1658 if ((fpsub = fopen( fnamesub , "w" )) == NULL )
1659 {
1660 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
1661 }
1662 if ( fpsub != NULL ) {
1663 print_warning(fpsub,fnamesub) ;
1664 fclose(fpsub) ;
1665 }
1666
1667 for ( p = periods ; p != NULL ; p = p->next )
1668 {
1669 strcpy( commname, p->name ) ;
1670 make_upper_case(commname) ;
1671 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
1672 else { sprintf(fname,"%s_inline.inc",commname) ; }
1673 /* Generate call to custom routine that encapsulates inlined comm calls */
1674 if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
1675 else { sprintf(fnamecall,"%s.inc",commname) ; }
1676 if ((fpcall = fopen( fnamecall , "w" )) == NULL )
1677 {
1678 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
1679 continue ;
1680 }
1681 print_warning(fpcall,fnamecall) ;
1682 #if ( WRFPLUS == 1 )
1683 print_call_or_def(fpcall, p, "CALL", commname, 0, "local_communicator_periodic", 1 );
1684 #else
1685 print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
1686 #endif
1687 close_the_file(fpcall) ;
1688
1689 /* Generate definition of custom routine that encapsulates inlined comm calls */
1690 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
1691 else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
1692 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
1693 {
1694 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
1695 continue ;
1696 }
1697 #if ( WRFPLUS == 1 )
1698 print_call_or_def(fpsub, p, "SUBROUTINE", commname, 0, "local_communicator_periodic", 1 );
1699 print_decl(fpsub, p, "local_communicator_periodic", 1, 0 );
1700 print_body(fpsub, commname, 0);
1701 #else
1702 print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
1703 print_decl(fpsub, p, "local_communicator_periodic", 1 );
1704 print_body(fpsub, commname);
1705 #endif
1706 close_the_file(fpsub) ;
1707
1708 /* Generate inlined comm calls */
1709 if ((fp = fopen( fname , "w" )) == NULL )
1710 {
1711 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
1712 continue ;
1713 }
1714 /* get maximum period width */
1715 maxperwidth = 0 ;
1716 strcpy( tmp, p->comm_define ) ;
1717 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1718 while ( t1 != NULL )
1719 {
1720 strcpy( tmp2 , t1 ) ;
1721 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1722 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
1723 perwidth = atoi (t2) ;
1724 if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
1725 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1726 }
1727 print_warning(fp,fname) ;
1728
1729 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1730
1731 /* count up the number of 2d and 3d real arrays and their types */
1732 n2dR = 0 ; n3dR = 0 ;
1733 n2dI = 0 ; n3dI = 0 ;
1734 n2dD = 0 ; n3dD = 0 ;
1735 n4d = 0 ;
1736 strcpy( tmp, p->comm_define ) ;
1737 strcpy( commuse, p->use ) ;
1738 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1739 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
1740 while ( t1 != NULL )
1741 {
1742 strcpy( tmp2 , t1 ) ;
1743 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1744 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1745 t2 = strtok_rentr(NULL,",", &pos2) ;
1746 while ( t2 != NULL )
1747 {
1748 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1749 { fprintf(stderr,"WARNING 1 : %s in period spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1750 else
1751 {
1752 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1753 { 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) ; }
1754 else if ( q->boundary_array )
1755 { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
1756 else
1757 {
1758 if ( q->node_kind & FOURD ) {
1759 if ( n4d < MAX_4DARRAYS ) {
1760 strcpy( name_4d[n4d], q->name ) ;
1761 } else {
1762 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1763 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1764 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1765 exit(5) ;
1766 }
1767 n4d++ ;
1768 }
1769 else
1770 {
1771 if ( ! strcmp( q->type->name, "real") ) {
1772 if ( q->ndims == 3 ) { n3dR++ ; }
1773 else if ( q->ndims == 2 ) { n2dR++ ; }
1774 } else if ( ! strcmp( q->type->name, "integer") ) {
1775 if ( q->ndims == 3 ) { n3dI++ ; }
1776 else if ( q->ndims == 2 ) { n2dI++ ; }
1777 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1778 if ( q->ndims == 3 ) { n3dD++ ; }
1779 else if ( q->ndims == 2 ) { n2dD++ ; }
1780 }
1781 }
1782 }
1783 }
1784 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1785 }
1786 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1787 }
1788
1789 fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
1790
1791 /* generate the stencil init statement for X transfer */
1792 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1793 if ( n4d > 0 ) {
1794 fprintf(fp, " %d &\n", n3dR ) ;
1795 for ( i = 0 ; i < n4d ; i++ ) {
1796 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1797 }
1798 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1799 } else {
1800 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1801 }
1802 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1803 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1804 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1805 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1806 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1807 /* generate packs prior to exchange in X */
1808 gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1809 /* generate exchange in X */
1810 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1811 /* generate unpacks after exchange in X */
1812 gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1813 fprintf(fp,"END IF\n") ;
1814
1815
1816 fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
1817 /* generate the init statement for Y transfer */
1818 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1819 if ( n4d > 0 ) {
1820 fprintf(fp, " %d &\n", n3dR ) ;
1821 for ( i = 0 ; i < n4d ; i++ ) {
1822 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1823 }
1824 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1825 } else {
1826 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1827 }
1828 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1829 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1830 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1831 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1832 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1833 /* generate packs prior to exchange in Y */
1834 gen_packs( fp, p, maxperwidth, 0, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1835 /* generate exchange in Y */
1836 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_Y ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1837 /* generate unpacks after exchange in Y */
1838 gen_packs( fp, p, maxperwidth, 0, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1839 fprintf(fp,"END IF\n") ;
1840
1841 close_the_file(fp) ;
1842 }
1843 return(0) ;
1844 }
1845
1846 int
1847 gen_swaps ( char * dirname , node_t * swaps )
1848 {
1849 node_t * p, * q ;
1850 node_t * dimd ;
1851 char commname[NAMELEN] ;
1852 char fname[NAMELEN] ;
1853 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1854 char commuse[NAMELEN] ;
1855 FILE * fp ;
1856 char * t1, * t2 ;
1857 char * pos1 , * pos2 ;
1858 char indices[NAMELEN], post[NAMELEN] ;
1859 int zdex ;
1860 int n2dR, n3dR ;
1861 int n2dI, n3dI ;
1862 int n2dD, n3dD ;
1863 int n4d ;
1864 int i, xy ;
1865 #define MAX_4DARRAYS 1000
1866 char name_4d[MAX_4DARRAYS][NAMELEN] ;
1867
1868 if ( dirname == NULL ) return(1) ;
1869
1870 for ( p = swaps ; p != NULL ; p = p->next )
1871 {
1872 strcpy( commname, p->name ) ;
1873 make_upper_case(commname) ;
1874 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
1875 else { sprintf(fname,"%s.inc",commname) ; }
1876 if ((fp = fopen( fname , "w" )) == NULL )
1877 {
1878 fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
1879 continue ;
1880 }
1881 print_warning(fp,fname) ;
1882
1883 for ( xy = 0 ; xy < 2 ; xy++ ) {
1884
1885 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1886
1887 /* count up the number of 2d and 3d real arrays and their types */
1888 n2dR = 0 ; n3dR = 0 ;
1889 n2dI = 0 ; n3dI = 0 ;
1890 n2dD = 0 ; n3dD = 0 ;
1891 n4d = 0 ;
1892 strcpy( tmp, p->comm_define ) ;
1893 strcpy( commuse, p->use ) ;
1894 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1895 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
1896 while ( t1 != NULL )
1897 {
1898 strcpy( tmp2 , t1 ) ;
1899 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1900 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1901 t2 = strtok_rentr(NULL,",", &pos2) ;
1902 while ( t2 != NULL )
1903 {
1904 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1905 { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1906 else
1907 {
1908 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1909 { 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) ; }
1910 else if ( q->boundary_array )
1911 { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
1912 else
1913 {
1914 if ( q->node_kind & FOURD ) {
1915 if ( n4d < MAX_4DARRAYS ) {
1916 strcpy( name_4d[n4d], q->name ) ;
1917 } else {
1918 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1919 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1920 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1921 exit(5) ;
1922 }
1923 n4d++ ;
1924 }
1925 else
1926 {
1927 if ( ! strcmp( q->type->name, "real") ) {
1928 if ( q->ndims == 3 ) { n3dR++ ; }
1929 else if ( q->ndims == 2 ) { n2dR++ ; }
1930 } else if ( ! strcmp( q->type->name, "integer") ) {
1931 if ( q->ndims == 3 ) { n3dI++ ; }
1932 else if ( q->ndims == 2 ) { n2dI++ ; }
1933 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1934 if ( q->ndims == 3 ) { n3dD++ ; }
1935 else if ( q->ndims == 2 ) { n2dD++ ; }
1936 }
1937 }
1938 }
1939 }
1940 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1941 }
1942 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1943 }
1944
1945 fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
1946
1947 /* generate the init statement for X swap */
1948 fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
1949 if ( n4d > 0 ) {
1950 fprintf(fp, " %d &\n", n3dR ) ;
1951 for ( i = 0 ; i < n4d ; i++ ) {
1952 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1953 }
1954 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1955 } else {
1956 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1957 }
1958 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1959 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1960 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1961 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1962 fprintf(fp," thisdomain_max_halo_width, &\n" ) ;
1963 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
1964 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1965 /* generate packs prior to stencil exchange */
1966 gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1967 /* generate stencil exchange in X */
1968 fprintf(fp," CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1969 /* generate unpacks after stencil exchange */
1970 gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1971
1972 fprintf(fp,"END IF\n") ;
1973
1974 }
1975 close_the_file(fp) ;
1976 }
1977 return(0) ;
1978 }
1979
1980 int
1981 gen_cycles ( char * dirname , node_t * cycles )
1982 {
1983 node_t * p, * q ;
1984 node_t * dimd ;
1985 char commname[NAMELEN] ;
1986 char fname[NAMELEN] ;
1987 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1988 char commuse[NAMELEN] ;
1989 FILE * fp ;
1990 char * t1, * t2 ;
1991 char * pos1 , * pos2 ;
1992 char indices[NAMELEN], post[NAMELEN] ;
1993 int zdex ;
1994 int n2dR, n3dR ;
1995 int n2dI, n3dI ;
1996 int n2dD, n3dD ;
1997 int n4d ;
1998 int i, xy, inout ;
1999 #define MAX_4DARRAYS 1000
2000 char name_4d[MAX_4DARRAYS][NAMELEN] ;
2001
2002 if ( dirname == NULL ) return(1) ;
2003
2004 for ( p = cycles ; p != NULL ; p = p->next )
2005 {
2006 strcpy( commname, p->name ) ;
2007 make_upper_case(commname) ;
2008 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
2009 else { sprintf(fname,"%s.inc",commname) ; }
2010 if ((fp = fopen( fname , "w" )) == NULL )
2011 {
2012 fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
2013 continue ;
2014 }
2015
2016 /* get inout */
2017 inout = 0 ;
2018 strcpy( tmp, p->comm_define ) ;
2019 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2020 strcpy( tmp2 , t1 ) ;
2021 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
2022 { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
2023 inout = atoi (t2) ;
2024
2025 print_warning(fp,fname) ;
2026
2027 for ( xy = 0 ; xy < 2 ; xy++ ) {
2028
2029 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
2030
2031 /* count up the number of 2d and 3d real arrays and their types */
2032 n2dR = 0 ; n3dR = 0 ;
2033 n2dI = 0 ; n3dI = 0 ;
2034 n2dD = 0 ; n3dD = 0 ;
2035 n4d = 0 ;
2036 strcpy( tmp, p->comm_define ) ;
2037 strcpy( commuse, p->use ) ;
2038 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2039 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
2040 while ( t1 != NULL )
2041 {
2042 strcpy( tmp2 , t1 ) ;
2043 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
2044 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
2045 t2 = strtok_rentr(NULL,",", &pos2) ;
2046 while ( t2 != NULL )
2047 {
2048 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2049 { fprintf(stderr,"WARNING 1 : %s in cycle spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
2050 else
2051 {
2052 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
2053 { 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) ; }
2054 else if ( q->boundary_array )
2055 { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
2056 else
2057 {
2058 if ( q->node_kind & FOURD ) {
2059 if ( n4d < MAX_4DARRAYS ) {
2060 strcpy( name_4d[n4d], q->name ) ;
2061 } else {
2062 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
2063 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
2064 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
2065 exit(5) ;
2066 }
2067 n4d++ ;
2068 }
2069 else
2070 {
2071 if ( ! strcmp( q->type->name, "real") ) {
2072 if ( q->ndims == 3 ) { n3dR++ ; }
2073 else if ( q->ndims == 2 ) { n2dR++ ; }
2074 } else if ( ! strcmp( q->type->name, "integer") ) {
2075 if ( q->ndims == 3 ) { n3dI++ ; }
2076 else if ( q->ndims == 2 ) { n2dI++ ; }
2077 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
2078 if ( q->ndims == 3 ) { n3dD++ ; }
2079 else if ( q->ndims == 2 ) { n2dD++ ; }
2080 }
2081 }
2082 }
2083 }
2084 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2085 }
2086 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
2087 }
2088
2089 fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
2090
2091 /* generate the init statement for X swap */
2092 fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
2093 if ( n4d > 0 ) {
2094 fprintf(fp, " %d &\n", n3dR ) ;
2095 for ( i = 0 ; i < n4d ; i++ ) {
2096 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
2097 }
2098 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
2099 } else {
2100 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
2101 }
2102 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
2103 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
2104 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
2105 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
2106 fprintf(fp," thisdomain_max_halo_width, &\n") ;
2107 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
2108 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
2109 /* generate packs prior to stencil exchange */
2110 gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
2111 /* generate stencil exchange in X */
2112 fprintf(fp," CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
2113 /* generate unpacks after stencil exchange */
2114 gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
2115
2116 fprintf(fp,"END IF\n") ;
2117
2118 }
2119 close_the_file(fp) ;
2120 }
2121 return(0) ;
2122 }
2123
2124 int
2125 gen_xposes ( char * dirname )
2126 {
2127 node_t * p, * q ;
2128 char commname[NAMELEN] ;
2129 char fname[NAMELEN] ;
2130 char tmp[4096], tmp2[4096], tmp3[4096] ;
2131 char commuse[4096] ;
2132 FILE * fp ;
2133 char * t1, * t2 ;
2134 char * pos1 , * pos2 ;
2135 char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
2136 char ** x ;
2137 char post[NAMELEN], varname[NAMELEN], memord[10] ;
2138 char indices_z[NAMELEN], varref_z[NAMELEN] ;
2139 char indices_x[NAMELEN], varref_x[NAMELEN] ;
2140 char indices_y[NAMELEN], varref_y[NAMELEN] ;
2141
2142 if ( dirname == NULL ) return(1) ;
2143
2144 for ( p = Xposes ; p != NULL ; p = p->next )
2145 {
2146 for ( x = xposedir ; *x ; x++ )
2147 {
2148 strcpy( commname, p->name ) ;
2149 make_upper_case(commname) ;
2150 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
2151 else { sprintf(fname,"%s_%s.inc",commname,*x) ; }
2152 if ((fp = fopen( fname , "w" )) == NULL )
2153 {
2154 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
2155 continue ;
2156 }
2157
2158 print_warning(fp,fname) ;
2159
2160 strcpy( tmp, p->comm_define ) ;
2161 strcpy( commuse, p->use ) ;
2162 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2163 while ( t1 != NULL )
2164 {
2165 strcpy( tmp2 , t1 ) ;
2166
2167 /* Z array */
2168 t2 = strtok_rentr(tmp2,",", &pos2) ;
2169 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2170 { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2171 strcpy( varref_z, t2 ) ;
2172 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2173 sprintf(varref_z,"grid%%%s",t2) ;
2174 }
2175 if ( q->proc_orient != ALL_Z_ON_PROC )
2176 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2177 if ( q->ndims != 3 )
2178 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2179 if ( q->boundary_array )
2180 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2181 strcpy (indices_z,"");
2182 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2183 {
2184 sprintf(post,")") ;
2185 sprintf(indices_z, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2186 }
2187 if ( q->node_kind & FOURD ) {
2188 strcat( varref_z, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
2189 }
2190
2191 /* X array */
2192 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2193 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2194 { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2195 strcpy( varref_x, t2 ) ;
2196 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2197 sprintf(varref_x,"grid%%%s",t2) ;
2198 }
2199 if ( q->proc_orient != ALL_X_ON_PROC )
2200 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2201 if ( q->ndims != 3 )
2202 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2203 if ( q->boundary_array )
2204 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2205 strcpy (indices_x,"");
2206 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2207 {
2208 sprintf(post,")") ;
2209 sprintf(indices_x, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2210 }
2211 if ( q->node_kind & FOURD ) {
2212 strcat( varref_x, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
2213 }
2214
2215 /* Y array */
2216 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2217 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2218 { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2219 strcpy( varref_y, t2 ) ;
2220 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2221 sprintf(varref_y,"grid%%%s",t2) ;
2222 }
2223 if ( q->proc_orient != ALL_Y_ON_PROC )
2224 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2225 if ( q->ndims != 3 )
2226 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2227 if ( q->boundary_array )
2228 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2229 strcpy (indices_y,"");
2230 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2231 {
2232 sprintf(post,")") ;
2233 sprintf(indices_y, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2234 }
2235 if ( q->node_kind & FOURD ) {
2236 strcat( varref_y, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
2237 }
2238
2239 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
2240 }
2241 set_mem_order( q, memord , 3 ) ;
2242 if ( !strcmp( *x , "z2x" ) ) {
2243 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2244 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2245 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2246 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2247 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2248 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2249 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2250 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
2251 } else if ( !strcmp( *x , "x2z" ) ) {
2252 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2253 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2254 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2255 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2256 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2257 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2258 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2259 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
2260 } else if ( !strcmp( *x , "x2y" ) ) {
2261 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2262 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2263 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2264 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2265 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2266 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2267 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2268 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2269 } else if ( !strcmp( *x , "y2x" ) ) {
2270 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2271 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2272 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2273 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2274 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2275 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2276 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2277 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2278 } else if ( !strcmp( *x , "y2z" ) ) {
2279 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2280 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2281 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2282 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2283 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2284 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2285 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2286 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2287 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2288 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2289 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2290 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2291 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2292 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2293 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2294 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x)\n" ) ;
2295 } else if ( !strcmp( *x , "z2y" ) ) {
2296 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2297 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2298 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2299 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2300 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2301 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2302 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2303 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x )\n" ) ;
2304 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2305 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2306 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2307 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2308 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2309 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2310 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2311 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2312 }
2313
2314 close_the_file(fp) ;
2315 }
2316 skiperific:
2317 ;
2318 }
2319 return(0) ;
2320 }
2321
2322 int
2323 gen_comm_descrips ( char * dirname )
2324 {
2325 node_t * p ;
2326 char * fn = "dm_comm_cpp_flags" ;
2327 char commname[NAMELEN] ;
2328 char fname[NAMELEN] ;
2329 FILE * fp ;
2330 int ncomm ;
2331
2332 if ( dirname == NULL ) return(1) ;
2333
2334 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
2335 else { sprintf(fname,"%s",fn) ; }
2336
2337 if ((fp = fopen( fname , "w" )) == NULL )
2338 {
2339 fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
2340 }
2341
2342 return(0) ;
2343 }
2344
2345
2346
2347 int
2348 gen_shift ( char * dirname )
2349 {
2350 int i ;
2351 FILE * fp ;
2352 node_t *p, *q, *dimd ;
2353 char **direction ;
2354 char *directions[] = { "x", "y", 0L } ;
2355 char fname[NAMELEN], vname[NAMELEN] ;
2356 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
2357 char memord[NAMELEN] ;
2358 int xdex,ydex,zdex ;
2359 node_t Shift ;
2360 int said_it = 0 ;
2361 int said_it2 = 0 ;
2362
2363 for ( direction = directions ; *direction != NULL ; direction++ )
2364 {
2365 if ( dirname == NULL ) return(1) ;
2366 if ( sw_unidir_shift_halo ) {
2367 sprintf(fname,"shift_halo") ; /* SamT: bug fix: remove extra arg */
2368 } else {
2369 sprintf(fname,"shift_halo_%s_halo",*direction) ;
2370 }
2371
2372 Shift.next = NULL ;
2373 sprintf( Shift.use, "" ) ;
2374 strcpy( Shift.comm_define, "SHW:" ) ;
2375 strcpy( Shift.name , fname ) ;
2376 if ( sw_move ) {
2377 for ( p = Domain.fields ; p != NULL ; p = p->next ) {
2378 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
2379 {
2380
2381 /* special cases in WRF */
2382 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
2383 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
2384 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
2385 if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
2386 fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
2387 fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
2388 said_it = 1 ; }
2389 continue ;
2390 }
2391
2392 /* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
2393 /* also make sure we don't shift or halo any transpose variables (ALL_X_ON_PROC or ALL_Y_ON_PROC) */
2394 if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) &&
2395 !(p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC) ) {
2396
2397 if ( p->subgrid != 0 ) { /* moving nests not implemented for subgrid variables */
2398 if ( sw_move && ! said_it2 ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for subgrid variables \n") ;
2399 said_it2 = 1 ; }
2400 continue ;
2401 }
2402 if ( p->type->type_type == SIMPLE )
2403 {
2404 for ( i = 1 ; i <= p->ntl ; i++ )
2405 {
2406 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2407 else sprintf(vname,"%s",p->name ) ;
2408 strcat( Shift.comm_define, vname ) ;
2409 strcat( Shift.comm_define, "," ) ;
2410 }
2411 }
2412 }
2413 }
2414 }
2415 if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
2416 }
2417
2418 /* if unidir halo, then only generate on x pass */
2419 if ( ! ( sw_unidir_shift_halo && !strcmp(*direction,"y" ) ) ) {
2420 gen_halos( dirname , NULL, &Shift, 0 ) ;
2421 }
2422
2423 sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ;
2424 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2425
2426 /* now generate the shifts themselves */
2427 if ( sw_move ) {
2428 for ( p = Domain.fields ; p != NULL ; p = p->next )
2429 {
2430
2431 /* special cases in WRF */
2432 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
2433 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
2434 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
2435 continue ;
2436 }
2437 /* do not shift transpose variables */
2438 if ( p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC ) continue ;
2439
2440 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
2441 {
2442
2443 if ( p->type->type_type == SIMPLE )
2444 {
2445 for ( i = 1 ; i <= p->ntl ; i++ )
2446 {
2447
2448 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2449 else sprintf(vname,"%s",p->name ) ;
2450
2451 if ( p->node_kind & FOURD )
2452 {
2453 node_t *member ;
2454
2455 xdex = get_index_for_coord( p , COORD_X ) ;
2456 ydex = get_index_for_coord( p , COORD_Y ) ;
2457 zdex = get_index_for_coord( p , COORD_Z ) ;
2458 if ( zdex >=1 && zdex <= 3 )
2459 {
2460 int d ;
2461 char r[10], tx[80], temp[80], moredims[80], *colon ;
2462 set_mem_order( p->members, memord , 3 ) ;
2463 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
2464 for ( d = p->ndims-1; d >= 3 ; d-- ) {
2465 strcpy(r,"") ;
2466 range_of_dimension( r, tx, d, p, "config_flags%") ;
2467 colon = index(tx,':') ; *colon = ',' ;
2468 fprintf(fp, " DO idim%d = %s\n", d-2, tx ) ;
2469 }
2470 strcpy(moredims,"") ;
2471 for ( d = 3 ; d < p->ndims ; d++ ) {
2472 sprintf(temp,"idim%d",d-2) ;
2473 strcat(moredims,",") ; strcat(moredims,temp) ;
2474 }
2475 strcat(moredims,",") ;
2476 if ( !strcmp( *direction, "x" ) )
2477 {
2478 char * stag = "" ;
2479 stag = p->members->stag_x?"":"-1" ;
2480 if ( !strncmp( memord , "XYZ", 3 ) ) {
2481 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2482 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2483 fprintf(fp,"ENDIF\n") ;
2484 } else if ( !strncmp( memord , "YXZ", 3 ) ) {
2485 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2486 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2487 fprintf(fp,"ENDIF\n") ;
2488 } else if ( !strncmp( memord , "XZY", 3 ) ) {
2489 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2490 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2491 fprintf(fp,"ENDIF\n") ;
2492 } else if ( !strncmp( memord , "YZX", 3 ) ) {
2493 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2494 fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2495 fprintf(fp,"ENDIF\n") ;
2496 } else if ( !strncmp( memord , "ZXY", 3 ) ) {
2497 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2498 fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2499 fprintf(fp,"ENDIF\n") ;
2500 } else if ( !strncmp( memord , "ZYX", 3 ) ) {
2501 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2502 fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2503 fprintf(fp,"ENDIF\n") ;
2504 } else if ( !strncmp( memord , "XY", 2 ) ) {
2505 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2506 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2507 fprintf(fp,"ENDIF\n") ;
2508 } else if ( !strncmp( memord , "YX", 2 ) ) {
2509 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2510 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2511 fprintf(fp,"ENDIF\n") ;
2512 }
2513 }
2514 else
2515 {
2516 char * stag = "" ;
2517 stag = p->members->stag_y?"":"-1" ;
2518 if ( !strncmp( memord , "XYZ", 3 ) ) {
2519 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2520 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2521 fprintf(fp,"ENDIF\n") ;
2522 } else if ( !strncmp( memord , "YXZ", 3 ) ) {
2523 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2524 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2525 fprintf(fp,"ENDIF\n") ;
2526 } else if ( !strncmp( memord , "XZY", 3 ) ) {
2527 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2528 fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2529 fprintf(fp,"ENDIF\n") ;
2530 } else if ( !strncmp( memord , "YZX", 3 ) ) {
2531 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2532 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2533 fprintf(fp,"ENDIF\n") ;
2534 } else if ( !strncmp( memord , "ZXY", 3 ) ) {
2535 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2536 fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2537 fprintf(fp,"ENDIF\n") ;
2538 } else if ( !strncmp( memord , "ZYX", 3 ) ) {
2539 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2540 fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2541 fprintf(fp,"ENDIF\n") ;
2542 } else if ( !strncmp( memord , "XY", 2 ) ) {
2543 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2544 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2545 fprintf(fp,"ENDIF\n") ;
2546 } else if ( !strncmp( memord , "YX", 2 ) ) {
2547 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2548 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
2549 fprintf(fp,"ENDIF\n") ;
2550 }
2551 }
2552 for ( d = p->ndims-1; d >= 3 ; d-- ) {
2553 fprintf(fp, " ENDDO\n" ) ;
2554 }
2555 fprintf(fp, " ENDDO\n" ) ;
2556 }
2557 else
2558 {
2559 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
2560 }
2561 }
2562 else
2563 {
2564 xdex = get_index_for_coord( p , COORD_X ) ;
2565 ydex = get_index_for_coord( p , COORD_Y ) ;
2566 set_mem_order( p, memord , 3 ) ;
2567 if ( !strcmp( *direction, "x" ) ) {
2568 if ( !strcmp( memord , "XYZ" ) ) {
2569 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2570 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2571 fprintf(fp,"ENDIF\n") ;
2572 } else if ( !strcmp( memord , "YXZ" ) ) {
2573 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2574 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2575 fprintf(fp,"ENDIF\n") ;
2576 } else if ( !strcmp( memord , "XZY" ) ) {
2577 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2578 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2579 fprintf(fp,"ENDIF\n") ;
2580 } else if ( !strcmp( memord , "YZX" ) ) {
2581 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2582 fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2583 fprintf(fp,"ENDIF\n") ;
2584 } else if ( !strcmp( memord , "ZXY" ) ) {
2585 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2586 fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2587 fprintf(fp,"ENDIF\n") ;
2588 } else if ( !strcmp( memord , "ZYX" ) ) {
2589 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2590 fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2591 fprintf(fp,"ENDIF\n") ;
2592 } else if ( !strcmp( memord , "XY" ) ) {
2593 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2594 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2595 fprintf(fp,"ENDIF\n") ;
2596 } else if ( !strcmp( memord , "YX" ) ) {
2597 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2598 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
2599 fprintf(fp,"ENDIF\n") ;
2600 }
2601 } else {
2602 if ( !strcmp( memord , "XYZ" ) ) {
2603 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2604 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2605 fprintf(fp,"ENDIF\n") ;
2606 } else if ( !strcmp( memord , "YXZ" ) ) {
2607 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2608 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2609 fprintf(fp,"ENDIF\n") ;
2610 } else if ( !strcmp( memord , "XZY" ) ) {
2611 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2612 fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2613 fprintf(fp,"ENDIF\n") ;
2614 } else if ( !strcmp( memord , "YZX" ) ) {
2615 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2616 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2617 fprintf(fp,"ENDIF\n") ;
2618 } else if ( !strcmp( memord , "ZXY" ) ) {
2619 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2620 fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2621 fprintf(fp,"ENDIF\n") ;
2622 } else if ( !strcmp( memord , "ZYX" ) ) {
2623 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2624 fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2625 fprintf(fp,"ENDIF\n") ;
2626 } else if ( !strcmp( memord , "XY" ) ) {
2627 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2628 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2629 fprintf(fp,"ENDIF\n") ;
2630 } else if ( !strcmp( memord , "YX" ) ) {
2631 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2632 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
2633 fprintf(fp,"ENDIF\n") ;
2634 }
2635 }
2636 }
2637 }
2638 }
2639 }
2640 }
2641 } /* if sw_move */
2642 close_the_file(fp) ;
2643 }
2644 return 0; /* SamT: bug fix: return a value */
2645 }
2646
2647 int
2648 gen_datacalls ( char * dirname )
2649 {
2650 FILE * fp ;
2651 char * fn = "data_calls.inc" ;
2652 char fname[NAMELEN] ;
2653
2654 if ( dirname == NULL ) return(1) ;
2655 if ( strlen(dirname) > 0 )
2656 { sprintf(fname,"%s/%s",dirname,fn) ; }
2657 else
2658 { sprintf(fname,"%s",fn) ; }
2659 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2660 print_warning(fp,fname) ;
2661 close_the_file(fp) ;
2662 return(0) ;
2663 }
2664
2665 /*****************/
2666 /*****************/
2667
2668 int
2669 gen_nest_packing ( char * dirname )
2670 {
2671 gen_nest_pack( dirname ) ;
2672 gen_nest_unpack( dirname ) ;
2673 return 0; /* SamT: bug fix: return a value */
2674 }
2675
2676 #define PACKIT 1
2677 #define UNPACKIT 2
2678
2679 int
2680 gen_nest_pack ( char * dirname )
2681 {
2682 int i ;
2683 FILE * fp ;
2684 char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
2685 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
2686 int ipath ;
2687 char ** fnp ; char * fn ;
2688 char * parent ;
2689 char * shw_str ;
2690 char fname[NAMELEN] ;
2691 node_t *node, *p, *dim ;
2692 int xdex, ydex, zdex ;
2693 char ddim[3][2][NAMELEN] ;
2694 char mdim[3][2][NAMELEN] ;
2695 char pdim[3][2][NAMELEN] ;
2696 char vname[NAMELEN] ; char tag[NAMELEN], fourd_names[NAMELEN_LONG] ;
2697 int d2, d3, sw ;
2698 char *info_name ;
2699 int d2_mp, d3_mp;
2700 char fourd_names_mp[NAMELEN_LONG];
2701
2702 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
2703 {
2704 fn = *fnp ;
2705 if ( dirname == NULL ) return(1) ;
2706 if ( strlen(dirname) > 0 ) {
2707 sprintf(fname,"%s/%s",dirname,fn) ;
2708 } else {
2709 sprintf(fname,"%s",fn) ;
2710 }
2711 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2712 print_warning(fp,fname) ;
2713
2714 d2 = d2_mp = 0 ;
2715 d3 = d3_mp = 0 ;
2716 node = Domain.fields ;
2717
2718 count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ,0,0) ;
2719 parent= "" ;
2720 if ( !strcmp(fn,"nest_feedbackup_pack.inc") ) parent="parent_" ;
2721
2722 if ( d2 + d3 > 0 ) {
2723 if ( down_path[ipath] == INTERP_UP )
2724 {
2725 info_name = "rsl_lite_to_parent_info" ;
2726 sw = 0 ;
2727 }
2728 else
2729 {
2730 info_name = "rsl_lite_to_child_info" ;
2731 sw = 1 ;
2732 }
2733
2734 fprintf(fp,"msize = (%d + %s )* nlev + %d\n", d3, fourd_names, d2 ) ;
2735
2736 /* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */
2737 fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ;
2738 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
2739 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
2740 fprintf(fp," ,nids,nide,njds,njde &\n") ;
2741 if (sw) fprintf(fp," ,pgr , sw &\n") ;
2742 fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ;
2743 fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ;
2744 fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ;
2745 fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ;
2746 fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ;
2747 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
2748 fprintf(fp," ,icoord,jcoord &\n") ;
2749 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
2750 fprintf(fp," ,pig,pjg,retval )\n") ;
2751
2752 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2753
2754 gen_nest_packunpack ( fp , Domain.fields, PACKIT, down_path[ipath] ) ;
2755
2756 /* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */
2757 fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ;
2758 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
2759 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
2760 fprintf(fp," ,nids,nide,njds,njde &\n") ;
2761 if (sw) fprintf(fp," ,pgr , sw &\n") ;
2762 fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ;
2763 fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ;
2764 fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ;
2765 fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ;
2766 fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ;
2767 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
2768 fprintf(fp," ,icoord,jcoord &\n") ;
2769 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
2770 fprintf(fp," ,pig,pjg,retval )\n") ;
2771
2772 fprintf(fp,"ENDDO\n") ;
2773 }
2774 close_the_file(fp) ;
2775 }
2776 return(0) ;
2777 }
2778
2779 int
2780 gen_nest_unpack ( char * dirname )
2781 {
2782 int i ;
2783 FILE * fp ;
2784 char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
2785 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
2786 int ipath ;
2787 char ** fnp ; char * fn ;
2788 char fname[NAMELEN] ;
2789 node_t *node, *p, *dim ;
2790 int xdex, ydex, zdex ;
2791 char ddim[3][2][NAMELEN] ;
2792 char mdim[3][2][NAMELEN] ;
2793 char pdim[3][2][NAMELEN] ;
2794 char *info_name ;
2795 char vname[NAMELEN] ; char tag[NAMELEN] ; char fourd_names[NAMELEN_LONG] ;
2796 int d2, d3 ;
2797
2798 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
2799 {
2800 fn = *fnp ;
2801 d2 = 0 ;
2802 d3 = 0 ;
2803 node = Domain.fields ;
2804
2805 if ( dirname == NULL ) return(1) ;
2806 if ( strlen(dirname) > 0 )
2807 { sprintf(fname,"%s/%s",dirname,fn) ; }
2808 else
2809 { sprintf(fname,"%s",fn) ; }
2810 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2811 print_warning(fp,fname) ;
2812
2813 count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath], 0, 0 ) ;
2814
2815 if ( d2 + d3 > 0 || strlen(fourd_names) > 0 ) {
2816 if ( down_path[ipath] == INTERP_UP )
2817 {
2818 info_name = "rsl_lite_from_child_info" ;
2819 }
2820 else
2821 {
2822 info_name = "rsl_lite_from_parent_info" ;
2823 }
2824
2825 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2826 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2827 gen_nest_packunpack ( fp , Domain.fields, UNPACKIT, down_path[ipath] ) ;
2828 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2829 fprintf(fp,"ENDDO\n") ;
2830 }
2831 close_the_file(fp) ;
2832 }
2833 return(0) ;
2834 }
2835
2836 int
2837 gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path )
2838 {
2839 int i, d1 ;
2840 node_t *p, *p1, *dim ;
2841 int d2, d3, xdex, ydex, zdex ;
2842 int nest_mask ;
2843 char * grid ;
2844 const char * feed="NEST_INFLUENCE";
2845 char ddim[3][2][NAMELEN] ;
2846 char mdim[3][2][NAMELEN] ;
2847 char pdim[3][2][NAMELEN] ;
2848 char vname[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ;
2849 char tx[80], moredims[80], temp[80], r[10], *colon ;
2850 char c, d ;
2851 int need_endif;
2852
2853 need_endif=0;
2854 for ( p1 = node ; p1 != NULL ; p1 = p1->next )
2855 {
2856 if(need_endif) {
2857 fprintf(fp,"endif\n");
2858 need_endif=0;
2859 }
2860 if ( p1->node_kind & FOURD )
2861 {
2862 if ( p1->members->next )
2863 nest_mask = p1->members->next->nest_mask ;
2864 else
2865 continue ;
2866 }
2867 else
2868 {
2869 nest_mask = p1->nest_mask ;
2870 }
2871 p = p1 ;
2872
2873 if ( nest_mask & down_path && ! ( down_path==INTERP_UP && p->no_feedback ) )
2874 {
2875 if(p->mp_var) {
2876 fprintf(fp,"if(interp_mp .eqv. .true.) then\n");
2877 need_endif=1;
2878 }
2879 if ( p->node_kind & FOURD ) {
2880 if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
2881 else sprintf(tag,"") ;
2882 set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
2883 zdex = get_index_for_coord( p->members , COORD_Z ) ;
2884 xdex = get_index_for_coord( p->members , COORD_X ) ;
2885 ydex = get_index_for_coord( p->members , COORD_Y ) ;
2886 } else {
2887 if ( p->ntl > 1 ) sprintf(tag,"_2") ;
2888 else sprintf(tag,"") ;
2889 set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
2890 zdex = get_index_for_coord( p , COORD_Z ) ;
2891 xdex = get_index_for_coord( p , COORD_X ) ;
2892 ydex = get_index_for_coord( p , COORD_Y ) ;
2893 }
2894
2895 if ( down_path == INTERP_UP )
2896 {
2897 c = ( dir == PACKIT )?'n':'p' ;
2898 d = ( dir == PACKIT )?'2':'1' ;
2899 } else {
2900 c = ( dir == UNPACKIT )?'n':'p' ;
2901 d = ( dir == UNPACKIT )?'2':'1' ;
2902 }
2903
2904 if ( zdex >= 0 ) {
2905 if ( xdex == 0 && zdex == 1 && ydex == 2 ) sprintf(dexes,"pig,k,pjg") ;
2906 else if ( zdex == 0 && xdex == 1 && ydex == 2 ) sprintf(dexes,"k,pig,pjg") ;
2907 else if ( xdex == 0 && ydex == 1 && zdex == 2 ) sprintf(dexes,"pig,pjg,k") ;
2908 } else {
2909 if ( xdex == 0 && ydex == 1 ) sprintf(dexes,"pig,pjg") ;
2910 if ( ydex == 0 && xdex == 1 ) sprintf(dexes,"pjg,pig") ;
2911 }
2912
2913 /* construct variable name */
2914 if ( p->node_kind & FOURD )
2915 {
2916 strcpy(moredims,"") ;
2917 for ( d1 = 3 ; d1 < p->ndims ; d1++ ) {
2918 sprintf(temp,"idim%d",d1-2) ;
2919 strcat(moredims,",") ; strcat(moredims,temp) ;
2920 }
2921 strcat(moredims,",") ;
2922 sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
2923 }
2924 else
2925 {
2926 sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
2927 }
2928
2929 grid = "grid%" ;
2930 if ( p->node_kind & FOURD )
2931 {
2932 grid = "" ;
2933 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
2934 for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
2935 strcpy(r,"") ;
2936 range_of_dimension(r, tx, d1, p, "config_flags%" ) ;
2937 colon = index( tx, ':' ) ; *colon = ',' ;
2938 fprintf(fp,"DO idim%d = %s \n", d1-2, tx) ;
2939 }
2940 } else {
2941 /* note that in the case if dir != UNPACKIT and down_path == INTERP_UP the data
2942 structure being used is intermediate_grid, not grid. However, intermediate_grid
2943 and grid share the same id (see module_dm.F) so it will not make a difference. */
2944 #if 0
2945 fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s%s') ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",p->name,tag) ;
2946 #else
2947 fprintf(fp,"IF ( SIZE(%s%s%s) .GT. 1 ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",grid,p->name,tag) ;
2948 #endif
2949 }
2950
2951 if ( dir == UNPACKIT )
2952 {
2953 if ( down_path == INTERP_UP )
2954 {
2955 char *sjl = "" ;
2956 if (p->nmm_v_grid)
2957 sjl = "_v" ;
2958 if ( zdex >= 0 ) {
2959 fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
2960 } else {
2961 fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
2962 }
2963 fprintf(fp,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
2964 sjl ,
2965 p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
2966 if ( zdex >= 0 ) {
2967 fprintf(fp,"DO k = %s,%s\n%s(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], feed, grid, vname ) ;
2968 } else {
2969 fprintf(fp,"%s(%s%s,xv(1))\n", feed, grid, vname ) ;
2970 }
2971 fprintf(fp,"ENDIF\n") ;
2972 }
2973 else
2974 {
2975 if ( zdex >= 0 ) {
2976 fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
2977 ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname) ;
2978 } else {
2979 fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname) ;
2980 }
2981 }
2982 }
2983 else
2984 {
2985 if ( down_path == INTERP_UP )
2986 {
2987 if ( zdex >= 0 ) {
2988 fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
2989 ddim[zdex][0], ddim[zdex][1], vname, ddim[zdex][1], ddim[zdex][0] ) ;
2990 } else {
2991 fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname) ;
2992 }
2993 }
2994 else
2995 {
2996 if ( zdex >= 0 ) {
2997 fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
2998 ddim[zdex][0], ddim[zdex][1], grid, vname, ddim[zdex][1], ddim[zdex][0] ) ;
2999 } else {
3000 fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname) ;
3001 }
3002 }
3003 }
3004 if ( p->node_kind & FOURD )
3005 {
3006 for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
3007 fprintf(fp,"ENDDO\n") ;
3008 }
3009 fprintf(fp,"ENDDO\n") ;
3010 }
3011 else
3012 {
3013 fprintf(fp,"ENDIF\n") ; /* in_use_for_config */
3014 }
3015 }
3016 }
3017 if(need_endif) {
3018 fprintf(fp,"endif\n");
3019 need_endif=0;
3020 }
3021
3022 return(0) ;
3023 }
3024
3025 /*****************/
3026
3027 /* STOPPED HERE -- need to include the extra dimensions in the count */
3028
3029 int
3030 count_fields ( node_t * node , int * d2 , int * d3 , char * fourd_names, int down_path,
3031 int send_mp, int no_mp )
3032 {
3033 node_t * p ;
3034 int zdex ;
3035 char temp[80], r[10], tx[80], *colon ;
3036 int d ;
3037
3038 strcpy(fourd_names,"") ; /* only works if non-recursive, but that is ifdefd out below */
3039 /* count up the total number of levels from all fields */
3040 for ( p = node ; p != NULL ; p = p->next )
3041 {
3042 if(send_mp && !p->mp_var) continue;
3043 if(no_mp && p->mp_var) continue;
3044 if ( p->node_kind == FOURD )
3045 {
3046 #if 0
3047 count_fields( p->members , d2 , d3 , down_path, send_mp, no_mp ) ; /* RECURSE */
3048 #else
3049 if ( strlen(fourd_names) > 0 ) strcat(fourd_names," & \n + ") ;
3050 sprintf(temp,"((num_%s - PARAM_FIRST_SCALAR + 1)",p->name) ;
3051 strcat(fourd_names,temp) ;
3052 for ( d = 3 ; d < p->ndims ; d++ ) {
3053 strcpy(r,"") ;
3054 range_of_dimension(r,tx,d,p,"config_flags%") ;
3055 colon = index(tx,':') ; *colon = '\0' ;
3056 sprintf(temp," &\n *((%s)-(%s)+1)",colon+1,tx) ;
3057 strcat(fourd_names,temp) ;
3058 }
3059 strcat(fourd_names,")") ;
3060 #endif
3061 }
3062 else
3063 {
3064 if ( p->nest_mask & down_path )
3065 {
3066 if ( p->node_kind == FOURD )
3067 zdex = get_index_for_coord( p->members , COORD_Z ) ;
3068 else
3069 zdex = get_index_for_coord( p , COORD_Z ) ;
3070
3071 if ( zdex < 0 ) {
3072 (*d2)++ ; /* if no zdex then only 2 d */
3073 } else {
3074 (*d3)++ ; /* if has a zdex then 3 d */
3075 }
3076 }
3077 }
3078 }
3079 return(0) ;
3080 }
3081
3082 /*****************/
3083 /*****************/
3084
3085 int
3086 gen_debug ( char * dirname )
3087 {
3088 int i ;
3089 FILE * fp ;
3090 node_t *p, *q, *dimd ;
3091 char **direction ;
3092 char *directions[] = { "x", "y", 0L } ;
3093 char fname[NAMELEN], vname[NAMELEN] ;
3094 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
3095 int zdex ;
3096 node_t Shift ;
3097 int said_it = 0 ;
3098 int said_it2 = 0 ;
3099
3100 if ( dirname == NULL ) return(1) ;
3101
3102 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/debuggal.inc",dirname) ; }
3103 else { sprintf(fname,"debuggal.inc") ; }
3104 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
3105
3106 /* now generate the shifts themselves */
3107 for ( p = Domain.fields ; p != NULL ; p = p->next )
3108 {
3109
3110 /* special cases in WRF */
3111 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
3112 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
3113 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
3114 continue ;
3115 }
3116
3117 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
3118 {
3119
3120 if ( p->type->type_type == SIMPLE )
3121 {
3122 for ( i = 1 ; i <= p->ntl ; i++ )
3123 {
3124
3125 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
3126 else sprintf(vname,"%s",p->name ) ;
3127
3128 if ( p->node_kind & FOURD )
3129 {
3130 #if 0
3131 node_t *member ;
3132 zdex = get_index_for_coord( p , COORD_Z ) ;
3133 if ( zdex >=1 && zdex <= 3 && strncmp(vname,"fdda",4) )
3134 {
3135 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
3136 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', itrace , %s ( IDEBUG,KDEBUG,JDEBUG,itrace)\n", vname, vname ) ;
3137 fprintf(fp, " ENDDO\n" ) ;
3138 }
3139 else
3140 {
3141 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
3142 }
3143 #endif
3144 }
3145 else
3146 {
3147 if ( p->ndims == 3 ) {
3148 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,KDEBUG,JDEBUG)\n", vname, vname ) ;
3149 } else if ( p->ndims == 2 ) {
3150 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,JDEBUG)\n", vname, vname ) ;
3151 }
3152 }
3153 }
3154 }
3155 }
3156 }
3157
3158 close_the_file(fp) ;
3159 return 0; /* SamT: bug fix: return a value */
3160 }
3161
3162 /*****************/
3163 /*****************/
3164
3165 int
3166 gen_comms ( char * dirname )
3167 {
3168 FILE *fpsub ;
3169 if ( sw_dm_parallel )
3170 fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
3171
3172 /* truncate this file if it exists */
3173 if ((fpsub = fopen( "inc/REGISTRY_COMM_NESTING_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3174 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3175 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_0_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3176 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_1_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3177 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_2_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3178 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_3_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3179
3180 gen_halos( "inc" , NULL, Halos, 1 ) ;
3181 #if ( WRFPLUS == 1 )
3182 gen_halos_nta( "inc" , NULL, Halos_nta, 1 ) ;
3183 #endif
3184 gen_shift( "inc" ) ;
3185 gen_periods( "inc", Periods ) ;
3186 gen_swaps( "inc", Swaps ) ;
3187 gen_cycles( "inc", Cycles ) ;
3188 gen_xposes( "inc" ) ;
3189 gen_comm_descrips( "inc" ) ;
3190 gen_datacalls( "inc" ) ;
3191 gen_nest_packing( "inc" ) ;
3192 #if 0
3193 gen_debug( "inc" ) ;
3194 #endif
3195
3196 return(0) ;
3197 }
3198
Mirror of the official repository at https://github.com/wrf-model/WRF