?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge remote-tracking branch 'origin/release-v4.6.1'
[WRF.git] / external / RSL_LITE / gen_comms.c
blobd62c5cb5af40fef9c5f34de94824206ad6eb0bf4
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 int
1222 #if ( WRFPLUS == 1 )
1223 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 )
1224 #else
1225 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 )
1226 #endif
1227 {
1228 node_t * q ;
1229 node_t * dimd ;
1230 char fname[NAMELEN] ;
1231 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG], tmp4[NAMELEN_LONG] ;
1232 char commuse[NAMELEN] ;
1233 int maxstenwidth, stenwidth ;
1234 char * t1, * t2 , *wordsize ;
1235 char varref[NAMELEN] ;
1236 char varname[NAMELEN] ;
1237 char * pos1 , * pos2 ;
1238 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
1239 int xdex,ydex,zdex ;
1240
1241 strcpy( tmp, p->comm_define ) ;
1242 strcpy( commuse, p->use ) ;
1243 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1244 while ( t1 != NULL )
1245 {
1246 strcpy( tmp2 , t1 ) ;
1247 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1248 { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
1249 t2 = strtok_rentr(NULL,",", &pos2) ;
1250 while ( t2 != NULL )
1251 {
1252 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1253 { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
1254 else
1255 {
1256
1257 strcpy( varname, t2 ) ;
1258 strcpy( varref, t2 ) ;
1259 #if ( WRFPLUS == 1 )
1260 if ( nta == 1) { sprintf(varref,"g_%s",t2) ; }
1261 if ( nta == 2 ) { sprintf(varref,"a_%s",t2) ; }
1262 #endif
1263 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1264 sprintf(varref,"grid%%%s",t2) ;
1265 #if ( WRFPLUS == 1 )
1266 if ( nta == 1) { sprintf(varref,"grid%%g_%s",t2) ; }
1267 if ( nta == 2 ) { sprintf(varref,"grid%%a_%s",t2) ; }
1268 #endif
1269 }
1270
1271 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
1272 else if ( q->boundary_array ) { ; }
1273 else
1274 {
1275 if(!always_interp_mp && p->mp_var) {
1276 fprintf(fp,"if(interp_mp) then\n");
1277 }
1278
1279 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
1280 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
1281 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
1282 if ( q->node_kind & FOURD )
1283 {
1284 node_t *member ;
1285 zdex = get_index_for_coord( q , COORD_Z ) ;
1286 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1287 if ( zdex >=1 && zdex <= 3 && dimd != NULL )
1288 {
1289 int d ;
1290 char * colon ;
1291 char moredims[80], tx[80], temp[10], r[80] ;
1292 char sd[256], ed[256] , sm[256], em[256] , sp[256], ep[256] ;
1293
1294 set_mem_order( q->members, memord , 3 ) ;
1295 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
1296 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
1297 } else {
1298 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n","chem" ) ;
1299 }
1300 strcpy(moredims,"") ;
1301 for ( d = q->ndims-1 ; d >= 3 ; d-- ) {
1302 fprintf(fp," DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ;
1303 }
1304 for ( d = 3 ; d < q->ndims ; d++ ) {
1305 strcpy(r,"") ;
1306 range_of_dimension( r, tx, d, q, "config_flags%" ) ;
1307 colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ;
1308 sprintf(temp,"idim%d",d-2) ;
1309 strcat(moredims,",") ; strcat(moredims,temp) ;
1310 }
1311 strcat(moredims,",") ;
1312 xdex = get_index_for_coord( q , COORD_X ) ;
1313 ydex = get_index_for_coord( q , COORD_Y ) ;
1314 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1315 strcpy(sd,"kds") ; strcpy(ed,"kde" ) ;
1316 strcpy(sm,"kms") ; strcpy(em,"kme" ) ;
1317 strcpy(sp,"kps") ; strcpy(ep,"kpe" ) ;
1318 } else if ( dimd->len_defined_how == NAMELIST ) {
1319 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1320 strcpy(sd,"1") ;
1321 sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1322 } else {
1323 sprintf(sd,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1324 sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1325 }
1326 strcpy(sm,sd) ; strcpy(em,ed ) ;
1327 strcpy(sp,sd) ; strcpy(ep,ed ) ;
1328 } else if ( dimd->len_defined_how == CONSTANT ) {
1329 sprintf(sd,"%d",dimd->coord_start) ; sprintf(ed,"%d",dimd->coord_end) ;
1330 strcpy(sm,sd) ; strcpy(em,ed ) ;
1331 strcpy(sp,sd) ; strcpy(ep,ed ) ;
1332 }
1333 if (strcmp("xbchem%chem_ic",varref) != 0 && strcmp("xachem%chem_ic",varref) != 0) {
1334 fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1335 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",
1336 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) ) ;
1337 } else {
1338 fprintf(fp," IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1339 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",
1340 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) ) ;
1341 }
1342 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1343 if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
1344 !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
1345 fprintf(fp,"thisdomain_max_halo_width, &\n") ;
1346 }
1347 if ( q->subgrid == 0 ) {
1348 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",sd,ed) ;
1349 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",sm,em) ;
1350 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",sp,ep) ;
1351 } else {
1352 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, %s, %s, &\n",sd,ed) ;
1353 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) ;
1354 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) ;
1355 }
1356 fprintf(fp," ENDIF\n") ;
1357 for ( d = 3 ; d < q->ndims ; d++ ) {
1358 fprintf(fp," ENDDO ! idim%d \n",d-2 ) ;
1359 }
1360
1361 fprintf(fp,"ENDDO\n") ;
1362 }
1363 else
1364 {
1365 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1366 }
1367 }
1368 else
1369 {
1370 set_mem_order( q, memord , 3 ) ;
1371 if ( q->ndims == 3 ) {
1372
1373 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1374 xdex = get_index_for_coord( q , COORD_X ) ;
1375 ydex = get_index_for_coord( q , COORD_Y ) ;
1376 zdex = get_index_for_coord( q , COORD_Z ) ;
1377 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1378 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",
1379 packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1380 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1381 if ( dimd != NULL )
1382 {
1383 char s[256], e[256] ;
1384 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1385 if ( q->subgrid == 0 ) {
1386 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1387 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1388 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1389 } else {
1390 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1391 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") ;
1392 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") ;
1393 }
1394 }
1395 else if ( dimd->len_defined_how == NAMELIST )
1396 {
1397 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1398 strcpy(s,"1") ;
1399 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1400 } else {
1401 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1402 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1403 }
1404 if ( q->subgrid == 0 ) {
1405 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
1406 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
1407 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
1408 } else {
1409 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1410 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) ;
1411 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) ;
1412 }
1413 }
1414 else if ( dimd->len_defined_how == CONSTANT )
1415 {
1416 if ( q->subgrid == 0 ) {
1417 fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1418 fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1419 fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
1420 } else {
1421 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1422 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) ;
1423 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) ;
1424 }
1425 }
1426 }
1427 fprintf(fp,"ENDIF\n") ;
1428 } else if ( q->ndims == 2 ) {
1429 xdex = get_index_for_coord( q , COORD_X ) ;
1430 ydex = get_index_for_coord( q , COORD_Y ) ;
1431 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1432 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",
1433 packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1434 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1435 if ( q->subgrid == 0 ) {
1436 fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
1437 fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
1438 fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
1439 } else {
1440 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1441 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") ;
1442 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") ;
1443 }
1444 fprintf(fp,"ENDIF\n") ;
1445 }
1446 }
1447 if(!always_interp_mp && p->mp_var) {
1448 fprintf(fp,"endif\n");
1449 }
1450 }
1451 }
1452 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1453 }
1454 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1455 }
1456 }
1457
1458 int
1459 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 )
1460 {
1461 node_t * q ;
1462 node_t * dimd ;
1463 char fname[NAMELEN] ;
1464 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
1465 char commuse[NAMELEN] ;
1466 int maxstenwidth, stenwidth ;
1467 char * t1, * t2 , *wordsize ;
1468 char varref[NAMELEN] ;
1469 char varname[NAMELEN] ;
1470 char * pos1 , * pos2 ;
1471 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
1472 int xdex,ydex,zdex ;
1473
1474 strcpy( tmp, p->comm_define ) ;
1475 strcpy( commuse, p->use ) ;
1476 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1477 while ( t1 != NULL )
1478 {
1479 strcpy( tmp2 , t1 ) ;
1480 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1481 { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
1482 t2 = strtok_rentr(NULL,",", &pos2) ;
1483 while ( t2 != NULL )
1484 {
1485 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1486 { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
1487 else
1488 {
1489
1490 strcpy( varname, t2 ) ;
1491 strcpy( varref, t2 ) ;
1492 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1493 sprintf(varref,"grid%%%s",t2) ;
1494 }
1495
1496 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
1497 else if ( q->boundary_array ) { ; }
1498 else
1499 {
1500 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
1501 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
1502 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
1503 if ( q->node_kind & FOURD )
1504 {
1505 node_t *member ;
1506 zdex = get_index_for_coord( q , COORD_Z ) ;
1507 if ( zdex >=1 && zdex <= 3 )
1508 {
1509 set_mem_order( q->members, memord , 3 ) ;
1510 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
1511 xdex = get_index_for_coord( q , COORD_X ) ;
1512 ydex = get_index_for_coord( q , COORD_Y ) ;
1513 fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1514 fprintf(fp," CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n",
1515 packname, commname, varref , shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
1516 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1517 if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
1518 !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
1519 fprintf(fp,"thisdomain_max_halo_width, &\n") ;
1520 }
1521 if ( q->subgrid == 0 ) {
1522 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1523 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1524 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1525 } else {
1526 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1527 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") ;
1528 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") ;
1529 }
1530 fprintf(fp," ENDIF\n") ;
1531 fprintf(fp,"ENDDO\n") ;
1532 }
1533 else
1534 {
1535 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1536 }
1537 }
1538 else
1539 {
1540 set_mem_order( q, memord , 3 ) ;
1541 if ( q->ndims == 3 ) {
1542
1543 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
1544 xdex = get_index_for_coord( q , COORD_X ) ;
1545 ydex = get_index_for_coord( q , COORD_Y ) ;
1546 zdex = get_index_for_coord( q , COORD_Z ) ;
1547 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1548 if ( dimd != NULL )
1549 {
1550 char s[256], e[256] ;
1551
1552 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
1553 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) ) ;
1554 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1555 if ( q->subgrid == 0 ) {
1556 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
1557 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
1558 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
1559 } else {
1560 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1561 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") ;
1562 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") ;
1563 }
1564 }
1565 else if ( dimd->len_defined_how == NAMELIST )
1566 {
1567 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
1568 strcpy(s,"1") ;
1569 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1570 } else {
1571 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
1572 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
1573 }
1574 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) ) ;
1575 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1576 if ( q->subgrid == 0 ) {
1577 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
1578 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
1579 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
1580 } else {
1581 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1582 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) ;
1583 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) ;
1584 }
1585 }
1586 else if ( dimd->len_defined_how == CONSTANT )
1587 {
1588 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) ) ;
1589 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1590 if ( q->subgrid == 0 ) {
1591 fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1592 fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
1593 fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
1594 } else {
1595 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1596 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) ;
1597 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) ;
1598 }
1599 }
1600 }
1601 fprintf(fp,"ENDIF\n") ;
1602 } else if ( q->ndims == 2 ) {
1603 xdex = get_index_for_coord( q , COORD_X ) ;
1604 ydex = get_index_for_coord( q , COORD_Y ) ;
1605 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
1606 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) ) ;
1607 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
1608 if ( q->subgrid == 0 ) {
1609 fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
1610 fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
1611 fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
1612 } else {
1613 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
1614 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") ;
1615 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") ;
1616 }
1617 fprintf(fp,"ENDIF\n") ;
1618 }
1619 }
1620 }
1621
1622 }
1623 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1624 }
1625 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1626 }
1627 }
1628
1629 int
1630 gen_periods ( char * dirname , node_t * periods )
1631 {
1632 node_t * p, * q ;
1633 node_t * dimd ;
1634 char commname[NAMELEN] ;
1635 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
1636 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1637 char commuse[NAMELEN] ;
1638 int maxperwidth, perwidth ;
1639 FILE * fp ;
1640 FILE * fpcall ;
1641 FILE * fpsub ;
1642 char * t1, * t2 ;
1643 char varref[NAMELEN] ;
1644 char * pos1 , * pos2 ;
1645 char indices[NAMELEN], post[NAMELEN] ;
1646 int zdex ;
1647 int n2dR, n3dR ;
1648 int n2dI, n3dI ;
1649 int n2dD, n3dD ;
1650 int n4d ;
1651 int i ;
1652 #define MAX_4DARRAYS 1000
1653 char name_4d[MAX_4DARRAYS][NAMELEN] ;
1654
1655 if ( dirname == NULL ) return(1) ;
1656
1657 /* Open and truncate REGISTRY_COMM_DM_PERIOD_subs.inc so file exists even if there are no periods. */
1658 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
1659 else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
1660 if ((fpsub = fopen( fnamesub , "w" )) == NULL )
1661 {
1662 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
1663 }
1664 if ( fpsub != NULL ) {
1665 print_warning(fpsub,fnamesub) ;
1666 fclose(fpsub) ;
1667 }
1668
1669 for ( p = periods ; p != NULL ; p = p->next )
1670 {
1671 strcpy( commname, p->name ) ;
1672 make_upper_case(commname) ;
1673 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
1674 else { sprintf(fname,"%s_inline.inc",commname) ; }
1675 /* Generate call to custom routine that encapsulates inlined comm calls */
1676 if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
1677 else { sprintf(fnamecall,"%s.inc",commname) ; }
1678 if ((fpcall = fopen( fnamecall , "w" )) == NULL )
1679 {
1680 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
1681 continue ;
1682 }
1683 print_warning(fpcall,fnamecall) ;
1684 #if ( WRFPLUS == 1 )
1685 print_call_or_def(fpcall, p, "CALL", commname, 0, "local_communicator_periodic", 1 );
1686 #else
1687 print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
1688 #endif
1689 close_the_file(fpcall) ;
1690
1691 /* Generate definition of custom routine that encapsulates inlined comm calls */
1692 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
1693 else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
1694 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
1695 {
1696 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
1697 continue ;
1698 }
1699 #if ( WRFPLUS == 1 )
1700 print_call_or_def(fpsub, p, "SUBROUTINE", commname, 0, "local_communicator_periodic", 1 );
1701 print_decl(fpsub, p, "local_communicator_periodic", 1, 0 );
1702 print_body(fpsub, commname, 0);
1703 #else
1704 print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
1705 print_decl(fpsub, p, "local_communicator_periodic", 1 );
1706 print_body(fpsub, commname);
1707 #endif
1708 close_the_file(fpsub) ;
1709
1710 /* Generate inlined comm calls */
1711 if ((fp = fopen( fname , "w" )) == NULL )
1712 {
1713 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
1714 continue ;
1715 }
1716 /* get maximum period width */
1717 maxperwidth = 0 ;
1718 strcpy( tmp, p->comm_define ) ;
1719 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1720 while ( t1 != NULL )
1721 {
1722 strcpy( tmp2 , t1 ) ;
1723 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1724 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
1725 perwidth = atoi (t2) ;
1726 if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
1727 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1728 }
1729 print_warning(fp,fname) ;
1730
1731 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1732
1733 /* count up the number of 2d and 3d real arrays and their types */
1734 n2dR = 0 ; n3dR = 0 ;
1735 n2dI = 0 ; n3dI = 0 ;
1736 n2dD = 0 ; n3dD = 0 ;
1737 n4d = 0 ;
1738 strcpy( tmp, p->comm_define ) ;
1739 strcpy( commuse, p->use ) ;
1740 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1741 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
1742 while ( t1 != NULL )
1743 {
1744 strcpy( tmp2 , t1 ) ;
1745 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1746 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1747 t2 = strtok_rentr(NULL,",", &pos2) ;
1748 while ( t2 != NULL )
1749 {
1750 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1751 { fprintf(stderr,"WARNING 1 : %s in period spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1752 else
1753 {
1754 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1755 { 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) ; }
1756 else if ( q->boundary_array )
1757 { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
1758 else
1759 {
1760 if ( q->node_kind & FOURD ) {
1761 if ( n4d < MAX_4DARRAYS ) {
1762 strcpy( name_4d[n4d], q->name ) ;
1763 } else {
1764 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1765 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1766 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1767 exit(5) ;
1768 }
1769 n4d++ ;
1770 }
1771 else
1772 {
1773 if ( ! strcmp( q->type->name, "real") ) {
1774 if ( q->ndims == 3 ) { n3dR++ ; }
1775 else if ( q->ndims == 2 ) { n2dR++ ; }
1776 } else if ( ! strcmp( q->type->name, "integer") ) {
1777 if ( q->ndims == 3 ) { n3dI++ ; }
1778 else if ( q->ndims == 2 ) { n2dI++ ; }
1779 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1780 if ( q->ndims == 3 ) { n3dD++ ; }
1781 else if ( q->ndims == 2 ) { n2dD++ ; }
1782 }
1783 }
1784 }
1785 }
1786 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1787 }
1788 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1789 }
1790
1791 fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
1792
1793 /* generate the stencil init statement for X transfer */
1794 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1795 if ( n4d > 0 ) {
1796 fprintf(fp, " %d &\n", n3dR ) ;
1797 for ( i = 0 ; i < n4d ; i++ ) {
1798 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1799 }
1800 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1801 } else {
1802 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1803 }
1804 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1805 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1806 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1807 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1808 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1809 /* generate packs prior to exchange in X */
1810 gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1811 /* generate exchange in X */
1812 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1813 /* generate unpacks after exchange in X */
1814 gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1815 fprintf(fp,"END IF\n") ;
1816
1817
1818 fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
1819 /* generate the init statement for Y transfer */
1820 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
1821 if ( n4d > 0 ) {
1822 fprintf(fp, " %d &\n", n3dR ) ;
1823 for ( i = 0 ; i < n4d ; i++ ) {
1824 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1825 }
1826 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1827 } else {
1828 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1829 }
1830 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1831 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1832 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1833 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1834 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1835 /* generate packs prior to exchange in Y */
1836 gen_packs( fp, p, maxperwidth, 0, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1837 /* generate exchange in Y */
1838 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_Y ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1839 /* generate unpacks after exchange in Y */
1840 gen_packs( fp, p, maxperwidth, 0, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
1841 fprintf(fp,"END IF\n") ;
1842
1843 close_the_file(fp) ;
1844 }
1845 return(0) ;
1846 }
1847
1848 int
1849 gen_swaps ( char * dirname , node_t * swaps )
1850 {
1851 node_t * p, * q ;
1852 node_t * dimd ;
1853 char commname[NAMELEN] ;
1854 char fname[NAMELEN] ;
1855 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1856 char commuse[NAMELEN] ;
1857 FILE * fp ;
1858 char * t1, * t2 ;
1859 char * pos1 , * pos2 ;
1860 char indices[NAMELEN], post[NAMELEN] ;
1861 int zdex ;
1862 int n2dR, n3dR ;
1863 int n2dI, n3dI ;
1864 int n2dD, n3dD ;
1865 int n4d ;
1866 int i, xy ;
1867 #define MAX_4DARRAYS 1000
1868 char name_4d[MAX_4DARRAYS][NAMELEN] ;
1869
1870 if ( dirname == NULL ) return(1) ;
1871
1872 for ( p = swaps ; p != NULL ; p = p->next )
1873 {
1874 strcpy( commname, p->name ) ;
1875 make_upper_case(commname) ;
1876 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
1877 else { sprintf(fname,"%s.inc",commname) ; }
1878 if ((fp = fopen( fname , "w" )) == NULL )
1879 {
1880 fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
1881 continue ;
1882 }
1883 print_warning(fp,fname) ;
1884
1885 for ( xy = 0 ; xy < 2 ; xy++ ) {
1886
1887 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1888
1889 /* count up the number of 2d and 3d real arrays and their types */
1890 n2dR = 0 ; n3dR = 0 ;
1891 n2dI = 0 ; n3dI = 0 ;
1892 n2dD = 0 ; n3dD = 0 ;
1893 n4d = 0 ;
1894 strcpy( tmp, p->comm_define ) ;
1895 strcpy( commuse, p->use ) ;
1896 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1897 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
1898 while ( t1 != NULL )
1899 {
1900 strcpy( tmp2 , t1 ) ;
1901 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1902 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1903 t2 = strtok_rentr(NULL,",", &pos2) ;
1904 while ( t2 != NULL )
1905 {
1906 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1907 { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1908 else
1909 {
1910 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1911 { 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) ; }
1912 else if ( q->boundary_array )
1913 { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
1914 else
1915 {
1916 if ( q->node_kind & FOURD ) {
1917 if ( n4d < MAX_4DARRAYS ) {
1918 strcpy( name_4d[n4d], q->name ) ;
1919 } else {
1920 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1921 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1922 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1923 exit(5) ;
1924 }
1925 n4d++ ;
1926 }
1927 else
1928 {
1929 if ( ! strcmp( q->type->name, "real") ) {
1930 if ( q->ndims == 3 ) { n3dR++ ; }
1931 else if ( q->ndims == 2 ) { n2dR++ ; }
1932 } else if ( ! strcmp( q->type->name, "integer") ) {
1933 if ( q->ndims == 3 ) { n3dI++ ; }
1934 else if ( q->ndims == 2 ) { n2dI++ ; }
1935 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1936 if ( q->ndims == 3 ) { n3dD++ ; }
1937 else if ( q->ndims == 2 ) { n2dD++ ; }
1938 }
1939 }
1940 }
1941 }
1942 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1943 }
1944 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1945 }
1946
1947 fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
1948
1949 /* generate the init statement for X swap */
1950 fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
1951 if ( n4d > 0 ) {
1952 fprintf(fp, " %d &\n", n3dR ) ;
1953 for ( i = 0 ; i < n4d ; i++ ) {
1954 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1955 }
1956 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1957 } else {
1958 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1959 }
1960 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1961 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1962 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1963 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1964 fprintf(fp," thisdomain_max_halo_width, &\n" ) ;
1965 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
1966 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1967 /* generate packs prior to stencil exchange */
1968 gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1969 /* generate stencil exchange in X */
1970 fprintf(fp," CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1971 /* generate unpacks after stencil exchange */
1972 gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
1973
1974 fprintf(fp,"END IF\n") ;
1975
1976 }
1977 close_the_file(fp) ;
1978 }
1979 return(0) ;
1980 }
1981
1982 int
1983 gen_cycles ( char * dirname , node_t * cycles )
1984 {
1985 node_t * p, * q ;
1986 node_t * dimd ;
1987 char commname[NAMELEN] ;
1988 char fname[NAMELEN] ;
1989 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
1990 char commuse[NAMELEN] ;
1991 FILE * fp ;
1992 char * t1, * t2 ;
1993 char * pos1 , * pos2 ;
1994 char indices[NAMELEN], post[NAMELEN] ;
1995 int zdex ;
1996 int n2dR, n3dR ;
1997 int n2dI, n3dI ;
1998 int n2dD, n3dD ;
1999 int n4d ;
2000 int i, xy, inout ;
2001 #define MAX_4DARRAYS 1000
2002 char name_4d[MAX_4DARRAYS][NAMELEN] ;
2003
2004 if ( dirname == NULL ) return(1) ;
2005
2006 for ( p = cycles ; p != NULL ; p = p->next )
2007 {
2008 strcpy( commname, p->name ) ;
2009 make_upper_case(commname) ;
2010 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
2011 else { sprintf(fname,"%s.inc",commname) ; }
2012 if ((fp = fopen( fname , "w" )) == NULL )
2013 {
2014 fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
2015 continue ;
2016 }
2017
2018 /* get inout */
2019 inout = 0 ;
2020 strcpy( tmp, p->comm_define ) ;
2021 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2022 strcpy( tmp2 , t1 ) ;
2023 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
2024 { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
2025 inout = atoi (t2) ;
2026
2027 print_warning(fp,fname) ;
2028
2029 for ( xy = 0 ; xy < 2 ; xy++ ) {
2030
2031 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
2032
2033 /* count up the number of 2d and 3d real arrays and their types */
2034 n2dR = 0 ; n3dR = 0 ;
2035 n2dI = 0 ; n3dI = 0 ;
2036 n2dD = 0 ; n3dD = 0 ;
2037 n4d = 0 ;
2038 strcpy( tmp, p->comm_define ) ;
2039 strcpy( commuse, p->use ) ;
2040 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2041 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
2042 while ( t1 != NULL )
2043 {
2044 strcpy( tmp2 , t1 ) ;
2045 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
2046 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
2047 t2 = strtok_rentr(NULL,",", &pos2) ;
2048 while ( t2 != NULL )
2049 {
2050 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2051 { fprintf(stderr,"WARNING 1 : %s in cycle spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
2052 else
2053 {
2054 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
2055 { 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) ; }
2056 else if ( q->boundary_array )
2057 { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
2058 else
2059 {
2060 if ( q->node_kind & FOURD ) {
2061 if ( n4d < MAX_4DARRAYS ) {
2062 strcpy( name_4d[n4d], q->name ) ;
2063 } else {
2064 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
2065 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
2066 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
2067 exit(5) ;
2068 }
2069 n4d++ ;
2070 }
2071 else
2072 {
2073 if ( ! strcmp( q->type->name, "real") ) {
2074 if ( q->ndims == 3 ) { n3dR++ ; }
2075 else if ( q->ndims == 2 ) { n2dR++ ; }
2076 } else if ( ! strcmp( q->type->name, "integer") ) {
2077 if ( q->ndims == 3 ) { n3dI++ ; }
2078 else if ( q->ndims == 2 ) { n2dI++ ; }
2079 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
2080 if ( q->ndims == 3 ) { n3dD++ ; }
2081 else if ( q->ndims == 2 ) { n2dD++ ; }
2082 }
2083 }
2084 }
2085 }
2086 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2087 }
2088 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
2089 }
2090
2091 fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
2092
2093 /* generate the init statement for X swap */
2094 fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
2095 if ( n4d > 0 ) {
2096 fprintf(fp, " %d &\n", n3dR ) ;
2097 for ( i = 0 ; i < n4d ; i++ ) {
2098 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
2099 }
2100 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
2101 } else {
2102 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
2103 }
2104 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
2105 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
2106 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
2107 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
2108 fprintf(fp," thisdomain_max_halo_width, &\n") ;
2109 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
2110 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
2111 /* generate packs prior to stencil exchange */
2112 gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
2113 /* generate stencil exchange in X */
2114 fprintf(fp," CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
2115 /* generate unpacks after stencil exchange */
2116 gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
2117
2118 fprintf(fp,"END IF\n") ;
2119
2120 }
2121 close_the_file(fp) ;
2122 }
2123 return(0) ;
2124 }
2125
2126 int
2127 gen_xposes ( char * dirname )
2128 {
2129 node_t * p, * q ;
2130 char commname[NAMELEN] ;
2131 char fname[NAMELEN] ;
2132 char tmp[4096], tmp2[4096], tmp3[4096] ;
2133 char commuse[4096] ;
2134 FILE * fp ;
2135 char * t1, * t2 ;
2136 char * pos1 , * pos2 ;
2137 char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
2138 char ** x ;
2139 char post[NAMELEN], varname[NAMELEN], memord[10] ;
2140 char indices_z[NAMELEN], varref_z[NAMELEN] ;
2141 char indices_x[NAMELEN], varref_x[NAMELEN] ;
2142 char indices_y[NAMELEN], varref_y[NAMELEN] ;
2143
2144 if ( dirname == NULL ) return(1) ;
2145
2146 for ( p = Xposes ; p != NULL ; p = p->next )
2147 {
2148 for ( x = xposedir ; *x ; x++ )
2149 {
2150 strcpy( commname, p->name ) ;
2151 make_upper_case(commname) ;
2152 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
2153 else { sprintf(fname,"%s_%s.inc",commname,*x) ; }
2154 if ((fp = fopen( fname , "w" )) == NULL )
2155 {
2156 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
2157 continue ;
2158 }
2159
2160 print_warning(fp,fname) ;
2161
2162 strcpy( tmp, p->comm_define ) ;
2163 strcpy( commuse, p->use ) ;
2164 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
2165 while ( t1 != NULL )
2166 {
2167 strcpy( tmp2 , t1 ) ;
2168
2169 /* Z array */
2170 t2 = strtok_rentr(tmp2,",", &pos2) ;
2171 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2172 { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2173 strcpy( varref_z, t2 ) ;
2174 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2175 sprintf(varref_z,"grid%%%s",t2) ;
2176 }
2177 if ( q->proc_orient != ALL_Z_ON_PROC )
2178 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2179 if ( q->ndims != 3 )
2180 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2181 if ( q->boundary_array )
2182 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2183 strcpy (indices_z,"");
2184 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2185 {
2186 sprintf(post,")") ;
2187 sprintf(indices_z, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2188 }
2189 if ( q->node_kind & FOURD ) {
2190 strcat( varref_z, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
2191 }
2192
2193 /* X array */
2194 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2195 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2196 { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2197 strcpy( varref_x, t2 ) ;
2198 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2199 sprintf(varref_x,"grid%%%s",t2) ;
2200 }
2201 if ( q->proc_orient != ALL_X_ON_PROC )
2202 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2203 if ( q->ndims != 3 )
2204 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2205 if ( q->boundary_array )
2206 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2207 strcpy (indices_x,"");
2208 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2209 {
2210 sprintf(post,")") ;
2211 sprintf(indices_x, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2212 }
2213 if ( q->node_kind & FOURD ) {
2214 strcat( varref_x, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
2215 }
2216
2217 /* Y array */
2218 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
2219 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
2220 { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
2221 strcpy( varref_y, t2 ) ;
2222 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
2223 sprintf(varref_y,"grid%%%s",t2) ;
2224 }
2225 if ( q->proc_orient != ALL_Y_ON_PROC )
2226 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
2227 if ( q->ndims != 3 )
2228 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2229 if ( q->boundary_array )
2230 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
2231 strcpy (indices_y,"");
2232 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
2233 {
2234 sprintf(post,")") ;
2235 sprintf(indices_y, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
2236 }
2237 if ( q->node_kind & FOURD ) {
2238 strcat( varref_y, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
2239 }
2240
2241 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
2242 }
2243 set_mem_order( q, memord , 3 ) ;
2244 if ( !strcmp( *x , "z2x" ) ) {
2245 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2246 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2247 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2248 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2249 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2250 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2251 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2252 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
2253 } else if ( !strcmp( *x , "x2z" ) ) {
2254 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2255 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2256 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2257 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2258 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2259 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2260 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2261 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
2262 } else if ( !strcmp( *x , "x2y" ) ) {
2263 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2264 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2265 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2266 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2267 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2268 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2269 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2270 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2271 } else if ( !strcmp( *x , "y2x" ) ) {
2272 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2273 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2274 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2275 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2276 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2277 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2278 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2279 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2280 } else if ( !strcmp( *x , "y2z" ) ) {
2281 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2282 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2283 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2284 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2285 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2286 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2287 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2288 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2289 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2290 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2291 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2292 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2293 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2294 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2295 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2296 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x)\n" ) ;
2297 } else if ( !strcmp( *x , "z2y" ) ) {
2298 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2299 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
2300 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2301 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
2302 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
2303 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2304 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2305 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x )\n" ) ;
2306 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
2307 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
2308 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
2309 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
2310 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
2311 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
2312 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
2313 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
2314 }
2315
2316 close_the_file(fp) ;
2317 }
2318 skiperific:
2319 ;
2320 }
2321 return(0) ;
2322 }
2323
2324 int
2325 gen_comm_descrips ( char * dirname )
2326 {
2327 node_t * p ;
2328 char * fn = "dm_comm_cpp_flags" ;
2329 char commname[NAMELEN] ;
2330 char fname[NAMELEN] ;
2331 FILE * fp ;
2332 int ncomm ;
2333
2334 if ( dirname == NULL ) return(1) ;
2335
2336 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
2337 else { sprintf(fname,"%s",fn) ; }
2338
2339 if ((fp = fopen( fname , "w" )) == NULL )
2340 {
2341 fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
2342 }
2343
2344 return(0) ;
2345 }
2346
2347
2348
2349 int
2350 gen_shift ( char * dirname )
2351 {
2352 int i ;
2353 FILE * fp ;
2354 node_t *p, *q, *dimd ;
2355 char **direction ;
2356 char *directions[] = { "x", "y", 0L } ;
2357 char fname[NAMELEN], vname[NAMELEN] ;
2358 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
2359 char memord[NAMELEN] ;
2360 int xdex,ydex,zdex ;
2361 node_t Shift ;
2362 int said_it = 0 ;
2363 int said_it2 = 0 ;
2364
2365 for ( direction = directions ; *direction != NULL ; direction++ )
2366 {
2367 if ( dirname == NULL ) return(1) ;
2368 if ( sw_unidir_shift_halo ) {
2369 sprintf(fname,"shift_halo") ; /* SamT: bug fix: remove extra arg */
2370 } else {
2371 sprintf(fname,"shift_halo_%s_halo",*direction) ;
2372 }
2373
2374 Shift.next = NULL ;
2375 sprintf( Shift.use, "" ) ;
2376 strcpy( Shift.comm_define, "SHW:" ) ;
2377 strcpy( Shift.name , fname ) ;
2378 if ( sw_move ) {
2379 for ( p = Domain.fields ; p != NULL ; p = p->next ) {
2380 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
2381 {
2382
2383 /* special cases in WRF */
2384 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
2385 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
2386 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
2387 if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
2388 fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
2389 fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
2390 said_it = 1 ; }
2391 continue ;
2392 }
2393
2394 /* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
2395 /* also make sure we don't shift or halo any transpose variables (ALL_X_ON_PROC or ALL_Y_ON_PROC) */
2396 if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) &&
2397 !(p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC) ) {
2398
2399 if ( p->subgrid != 0 ) { /* moving nests not implemented for subgrid variables */
2400 if ( sw_move && ! said_it2 ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for subgrid variables \n") ;
2401 said_it2 = 1 ; }
2402 continue ;
2403 }
2404 if ( p->type->type_type == SIMPLE )
2405 {
2406 for ( i = 1 ; i <= p->ntl ; i++ )
2407 {
2408 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2409 else sprintf(vname,"%s",p->name ) ;
2410 strcat( Shift.comm_define, vname ) ;
2411 strcat( Shift.comm_define, "," ) ;
2412 }
2413 }
2414 }
2415 }
2416 }
2417 if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
2418 }
2419
2420 /* if unidir halo, then only generate on x pass */
2421 if ( ! ( sw_unidir_shift_halo && !strcmp(*direction,"y" ) ) ) {
2422 gen_halos( dirname , NULL, &Shift, 0 ) ;
2423 }
2424
2425 sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ;
2426 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2427
2428 /* now generate the shifts themselves */
2429 if ( sw_move ) {
2430 for ( p = Domain.fields ; p != NULL ; p = p->next )
2431 {
2432
2433 /* special cases in WRF */
2434 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
2435 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
2436 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
2437 continue ;
2438 }
2439 /* do not shift transpose variables */
2440 if ( p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC ) continue ;
2441
2442 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
2443 {
2444
2445 if ( p->type->type_type == SIMPLE )
2446 {
2447 for ( i = 1 ; i <= p->ntl ; i++ )
2448 {
2449
2450 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2451 else sprintf(vname,"%s",p->name ) ;
2452
2453 if ( p->node_kind & FOURD )
2454 {
2455 node_t *member ;
2456
2457 xdex = get_index_for_coord( p , COORD_X ) ;
2458 ydex = get_index_for_coord( p , COORD_Y ) ;
2459 zdex = get_index_for_coord( p , COORD_Z ) ;
2460 if ( zdex >=1 && zdex <= 3 )
2461 {
2462 int d ;
2463 char r[10], tx[80], temp[80], moredims[80], *colon ;
2464 set_mem_order( p->members, memord , 3 ) ;
2465 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
2466 for ( d = p->ndims-1; d >= 3 ; d-- ) {
2467 strcpy(r,"") ;
2468 range_of_dimension( r, tx, d, p, "config_flags%") ;
2469 colon = index(tx,':') ; *colon = ',' ;
2470 fprintf(fp, " DO idim%d = %s\n", d-2, tx ) ;
2471 }
2472 strcpy(moredims,"") ;
2473 for ( d = 3 ; d < p->ndims ; d++ ) {
2474 sprintf(temp,"idim%d",d-2) ;
2475 strcat(moredims,",") ; strcat(moredims,temp) ;
2476 }
2477 strcat(moredims,",") ;
2478 if ( !strcmp( *direction, "x" ) )
2479 {
2480 char * stag = "" ;
2481 stag = p->members->stag_x?"":"-1" ;
2482 if ( !strncmp( memord , "XYZ", 3 ) ) {
2483 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2484 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 ) ;
2485 fprintf(fp,"ENDIF\n") ;
2486 } else if ( !strncmp( memord , "YXZ", 3 ) ) {
2487 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2488 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 ) ;
2489 fprintf(fp,"ENDIF\n") ;
2490 } else if ( !strncmp( memord , "XZY", 3 ) ) {
2491 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2492 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 ) ;
2493 fprintf(fp,"ENDIF\n") ;
2494 } else if ( !strncmp( memord , "YZX", 3 ) ) {
2495 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2496 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 ) ;
2497 fprintf(fp,"ENDIF\n") ;
2498 } else if ( !strncmp( memord , "ZXY", 3 ) ) {
2499 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2500 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 ) ;
2501 fprintf(fp,"ENDIF\n") ;
2502 } else if ( !strncmp( memord , "ZYX", 3 ) ) {
2503 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2504 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 ) ;
2505 fprintf(fp,"ENDIF\n") ;
2506 } else if ( !strncmp( memord , "XY", 2 ) ) {
2507 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2508 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 ) ;
2509 fprintf(fp,"ENDIF\n") ;
2510 } else if ( !strncmp( memord , "YX", 2 ) ) {
2511 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2512 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 ) ;
2513 fprintf(fp,"ENDIF\n") ;
2514 }
2515 }
2516 else
2517 {
2518 char * stag = "" ;
2519 stag = p->members->stag_y?"":"-1" ;
2520 if ( !strncmp( memord , "XYZ", 3 ) ) {
2521 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2522 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 ) ;
2523 fprintf(fp,"ENDIF\n") ;
2524 } else if ( !strncmp( memord , "YXZ", 3 ) ) {
2525 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2526 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 ) ;
2527 fprintf(fp,"ENDIF\n") ;
2528 } else if ( !strncmp( memord , "XZY", 3 ) ) {
2529 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2530 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 ) ;
2531 fprintf(fp,"ENDIF\n") ;
2532 } else if ( !strncmp( memord , "YZX", 3 ) ) {
2533 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2534 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 ) ;
2535 fprintf(fp,"ENDIF\n") ;
2536 } else if ( !strncmp( memord , "ZXY", 3 ) ) {
2537 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2538 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 ) ;
2539 fprintf(fp,"ENDIF\n") ;
2540 } else if ( !strncmp( memord , "ZYX", 3 ) ) {
2541 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2542 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 ) ;
2543 fprintf(fp,"ENDIF\n") ;
2544 } else if ( !strncmp( memord , "XY", 2 ) ) {
2545 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2546 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 ) ;
2547 fprintf(fp,"ENDIF\n") ;
2548 } else if ( !strncmp( memord , "YX", 2 ) ) {
2549 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2550 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 ) ;
2551 fprintf(fp,"ENDIF\n") ;
2552 }
2553 }
2554 for ( d = p->ndims-1; d >= 3 ; d-- ) {
2555 fprintf(fp, " ENDDO\n" ) ;
2556 }
2557 fprintf(fp, " ENDDO\n" ) ;
2558 }
2559 else
2560 {
2561 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
2562 }
2563 }
2564 else
2565 {
2566 xdex = get_index_for_coord( p , COORD_X ) ;
2567 ydex = get_index_for_coord( p , COORD_Y ) ;
2568 set_mem_order( p, memord , 3 ) ;
2569 if ( !strcmp( *direction, "x" ) ) {
2570 if ( !strcmp( memord , "XYZ" ) ) {
2571 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2572 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" ) ;
2573 fprintf(fp,"ENDIF\n") ;
2574 } else if ( !strcmp( memord , "YXZ" ) ) {
2575 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2576 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" ) ;
2577 fprintf(fp,"ENDIF\n") ;
2578 } else if ( !strcmp( memord , "XZY" ) ) {
2579 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2580 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" ) ;
2581 fprintf(fp,"ENDIF\n") ;
2582 } else if ( !strcmp( memord , "YZX" ) ) {
2583 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2584 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" ) ;
2585 fprintf(fp,"ENDIF\n") ;
2586 } else if ( !strcmp( memord , "ZXY" ) ) {
2587 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2588 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" ) ;
2589 fprintf(fp,"ENDIF\n") ;
2590 } else if ( !strcmp( memord , "ZYX" ) ) {
2591 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2592 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" ) ;
2593 fprintf(fp,"ENDIF\n") ;
2594 } else if ( !strcmp( memord , "XY" ) ) {
2595 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2596 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" ) ;
2597 fprintf(fp,"ENDIF\n") ;
2598 } else if ( !strcmp( memord , "YX" ) ) {
2599 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2600 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" ) ;
2601 fprintf(fp,"ENDIF\n") ;
2602 }
2603 } else {
2604 if ( !strcmp( memord , "XYZ" ) ) {
2605 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2606 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" ) ;
2607 fprintf(fp,"ENDIF\n") ;
2608 } else if ( !strcmp( memord , "YXZ" ) ) {
2609 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2610 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" ) ;
2611 fprintf(fp,"ENDIF\n") ;
2612 } else if ( !strcmp( memord , "XZY" ) ) {
2613 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2614 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" ) ;
2615 fprintf(fp,"ENDIF\n") ;
2616 } else if ( !strcmp( memord , "YZX" ) ) {
2617 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2618 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" ) ;
2619 fprintf(fp,"ENDIF\n") ;
2620 } else if ( !strcmp( memord , "ZXY" ) ) {
2621 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2622 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" ) ;
2623 fprintf(fp,"ENDIF\n") ;
2624 } else if ( !strcmp( memord , "ZYX" ) ) {
2625 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2626 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" ) ;
2627 fprintf(fp,"ENDIF\n") ;
2628 } else if ( !strcmp( memord , "XY" ) ) {
2629 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2630 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" ) ;
2631 fprintf(fp,"ENDIF\n") ;
2632 } else if ( !strcmp( memord , "YX" ) ) {
2633 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
2634 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" ) ;
2635 fprintf(fp,"ENDIF\n") ;
2636 }
2637 }
2638 }
2639 }
2640 }
2641 }
2642 }
2643 } /* if sw_move */
2644 close_the_file(fp) ;
2645 }
2646 return 0; /* SamT: bug fix: return a value */
2647 }
2648
2649 int
2650 gen_datacalls ( char * dirname )
2651 {
2652 FILE * fp ;
2653 char * fn = "data_calls.inc" ;
2654 char fname[NAMELEN] ;
2655
2656 if ( dirname == NULL ) return(1) ;
2657 if ( strlen(dirname) > 0 )
2658 { sprintf(fname,"%s/%s",dirname,fn) ; }
2659 else
2660 { sprintf(fname,"%s",fn) ; }
2661 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2662 print_warning(fp,fname) ;
2663 close_the_file(fp) ;
2664 return(0) ;
2665 }
2666
2667 /*****************/
2668 /*****************/
2669
2670 int
2671 gen_nest_packing ( char * dirname )
2672 {
2673 gen_nest_pack( dirname ) ;
2674 gen_nest_unpack( dirname ) ;
2675 return 0; /* SamT: bug fix: return a value */
2676 }
2677
2678 #define PACKIT 1
2679 #define UNPACKIT 2
2680
2681 int
2682 gen_nest_pack ( char * dirname )
2683 {
2684 int i ;
2685 FILE * fp ;
2686 char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
2687 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
2688 int ipath ;
2689 char ** fnp ; char * fn ;
2690 char * parent ;
2691 char * shw_str ;
2692 char fname[NAMELEN] ;
2693 node_t *node, *p, *dim ;
2694 int xdex, ydex, zdex ;
2695 char ddim[3][2][NAMELEN] ;
2696 char mdim[3][2][NAMELEN] ;
2697 char pdim[3][2][NAMELEN] ;
2698 char vname[NAMELEN] ; char tag[NAMELEN], fourd_names[NAMELEN_LONG] ;
2699 int d2, d3, sw ;
2700 char *info_name ;
2701 int d2_mp, d3_mp;
2702 char fourd_names_mp[NAMELEN_LONG];
2703
2704 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
2705 {
2706 fn = *fnp ;
2707 if ( dirname == NULL ) return(1) ;
2708 if ( strlen(dirname) > 0 ) {
2709 sprintf(fname,"%s/%s",dirname,fn) ;
2710 } else {
2711 sprintf(fname,"%s",fn) ;
2712 }
2713 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2714 print_warning(fp,fname) ;
2715
2716 d2 = d2_mp = 0 ;
2717 d3 = d3_mp = 0 ;
2718 node = Domain.fields ;
2719
2720 count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ,0,0) ;
2721 parent= "" ;
2722 if ( !strcmp(fn,"nest_feedbackup_pack.inc") ) parent="parent_" ;
2723
2724 if ( d2 + d3 > 0 ) {
2725 if ( down_path[ipath] == INTERP_UP )
2726 {
2727 info_name = "rsl_lite_to_parent_info" ;
2728 sw = 0 ;
2729 }
2730 else
2731 {
2732 info_name = "rsl_lite_to_child_info" ;
2733 sw = 1 ;
2734 }
2735
2736 fprintf(fp,"msize = (%d + %s )* nlev + %d\n", d3, fourd_names, d2 ) ;
2737
2738 /* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */
2739 fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ;
2740 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
2741 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
2742 fprintf(fp," ,nids,nide,njds,njde &\n") ;
2743 if (sw) fprintf(fp," ,pgr , sw &\n") ;
2744 fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ;
2745 fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ;
2746 fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ;
2747 fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ;
2748 fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ;
2749 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
2750 fprintf(fp," ,icoord,jcoord &\n") ;
2751 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
2752 fprintf(fp," ,pig,pjg,retval )\n") ;
2753
2754 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2755
2756 gen_nest_packunpack ( fp , Domain.fields, PACKIT, down_path[ipath] ) ;
2757
2758 /* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */
2759 fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ;
2760 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
2761 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
2762 fprintf(fp," ,nids,nide,njds,njde &\n") ;
2763 if (sw) fprintf(fp," ,pgr , sw &\n") ;
2764 fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ;
2765 fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ;
2766 fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ;
2767 fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ;
2768 fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ;
2769 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
2770 fprintf(fp," ,icoord,jcoord &\n") ;
2771 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
2772 fprintf(fp," ,pig,pjg,retval )\n") ;
2773
2774 fprintf(fp,"ENDDO\n") ;
2775 }
2776 close_the_file(fp) ;
2777 }
2778 return(0) ;
2779 }
2780
2781 int
2782 gen_nest_unpack ( char * dirname )
2783 {
2784 int i ;
2785 FILE * fp ;
2786 char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
2787 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
2788 int ipath ;
2789 char ** fnp ; char * fn ;
2790 char fname[NAMELEN] ;
2791 node_t *node, *p, *dim ;
2792 int xdex, ydex, zdex ;
2793 char ddim[3][2][NAMELEN] ;
2794 char mdim[3][2][NAMELEN] ;
2795 char pdim[3][2][NAMELEN] ;
2796 char *info_name ;
2797 char vname[NAMELEN] ; char tag[NAMELEN] ; char fourd_names[NAMELEN_LONG] ;
2798 int d2, d3 ;
2799
2800 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
2801 {
2802 fn = *fnp ;
2803 d2 = 0 ;
2804 d3 = 0 ;
2805 node = Domain.fields ;
2806
2807 if ( dirname == NULL ) return(1) ;
2808 if ( strlen(dirname) > 0 )
2809 { sprintf(fname,"%s/%s",dirname,fn) ; }
2810 else
2811 { sprintf(fname,"%s",fn) ; }
2812 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
2813 print_warning(fp,fname) ;
2814
2815 count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath], 0, 0 ) ;
2816
2817 if ( d2 + d3 > 0 || strlen(fourd_names) > 0 ) {
2818 if ( down_path[ipath] == INTERP_UP )
2819 {
2820 info_name = "rsl_lite_from_child_info" ;
2821 }
2822 else
2823 {
2824 info_name = "rsl_lite_from_parent_info" ;
2825 }
2826
2827 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2828 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
2829 gen_nest_packunpack ( fp , Domain.fields, UNPACKIT, down_path[ipath] ) ;
2830 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
2831 fprintf(fp,"ENDDO\n") ;
2832 }
2833 close_the_file(fp) ;
2834 }
2835 return(0) ;
2836 }
2837
2838 int
2839 gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path )
2840 {
2841 int i, d1 ;
2842 node_t *p, *p1, *dim ;
2843 int d2, d3, xdex, ydex, zdex ;
2844 int nest_mask ;
2845 char * grid ;
2846 const char * feed="NEST_INFLUENCE";
2847 char ddim[3][2][NAMELEN] ;
2848 char mdim[3][2][NAMELEN] ;
2849 char pdim[3][2][NAMELEN] ;
2850 char vname[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ;
2851 char tx[80], moredims[80], temp[80], r[10], *colon ;
2852 char c, d ;
2853 int need_endif;
2854
2855 need_endif=0;
2856 for ( p1 = node ; p1 != NULL ; p1 = p1->next )
2857 {
2858 if(need_endif) {
2859 fprintf(fp,"endif\n");
2860 need_endif=0;
2861 }
2862 if ( p1->node_kind & FOURD )
2863 {
2864 if ( p1->members->next )
2865 nest_mask = p1->members->next->nest_mask ;
2866 else
2867 continue ;
2868 }
2869 else
2870 {
2871 nest_mask = p1->nest_mask ;
2872 }
2873 p = p1 ;
2874
2875 if ( nest_mask & down_path && ! ( down_path==INTERP_UP && p->no_feedback ) )
2876 {
2877 if(p->mp_var) {
2878 fprintf(fp,"if(interp_mp .eqv. .true.) then\n");
2879 need_endif=1;
2880 }
2881 if ( p->node_kind & FOURD ) {
2882 if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
2883 else sprintf(tag,"") ;
2884 set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
2885 zdex = get_index_for_coord( p->members , COORD_Z ) ;
2886 xdex = get_index_for_coord( p->members , COORD_X ) ;
2887 ydex = get_index_for_coord( p->members , COORD_Y ) ;
2888 } else {
2889 if ( p->ntl > 1 ) sprintf(tag,"_2") ;
2890 else sprintf(tag,"") ;
2891 set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
2892 zdex = get_index_for_coord( p , COORD_Z ) ;
2893 xdex = get_index_for_coord( p , COORD_X ) ;
2894 ydex = get_index_for_coord( p , COORD_Y ) ;
2895 }
2896
2897 if ( down_path == INTERP_UP )
2898 {
2899 c = ( dir == PACKIT )?'n':'p' ;
2900 d = ( dir == PACKIT )?'2':'1' ;
2901 } else {
2902 c = ( dir == UNPACKIT )?'n':'p' ;
2903 d = ( dir == UNPACKIT )?'2':'1' ;
2904 }
2905
2906 if ( zdex >= 0 ) {
2907 if ( xdex == 0 && zdex == 1 && ydex == 2 ) sprintf(dexes,"pig,k,pjg") ;
2908 else if ( zdex == 0 && xdex == 1 && ydex == 2 ) sprintf(dexes,"k,pig,pjg") ;
2909 else if ( xdex == 0 && ydex == 1 && zdex == 2 ) sprintf(dexes,"pig,pjg,k") ;
2910 } else {
2911 if ( xdex == 0 && ydex == 1 ) sprintf(dexes,"pig,pjg") ;
2912 if ( ydex == 0 && xdex == 1 ) sprintf(dexes,"pjg,pig") ;
2913 }
2914
2915 /* construct variable name */
2916 if ( p->node_kind & FOURD )
2917 {
2918 strcpy(moredims,"") ;
2919 for ( d1 = 3 ; d1 < p->ndims ; d1++ ) {
2920 sprintf(temp,"idim%d",d1-2) ;
2921 strcat(moredims,",") ; strcat(moredims,temp) ;
2922 }
2923 strcat(moredims,",") ;
2924 sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
2925 }
2926 else
2927 {
2928 sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
2929 }
2930
2931 grid = "grid%" ;
2932 if ( p->node_kind & FOURD )
2933 {
2934 grid = "" ;
2935 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
2936 for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
2937 strcpy(r,"") ;
2938 range_of_dimension(r, tx, d1, p, "config_flags%" ) ;
2939 colon = index( tx, ':' ) ; *colon = ',' ;
2940 fprintf(fp,"DO idim%d = %s \n", d1-2, tx) ;
2941 }
2942 } else {
2943 /* note that in the case if dir != UNPACKIT and down_path == INTERP_UP the data
2944 structure being used is intermediate_grid, not grid. However, intermediate_grid
2945 and grid share the same id (see module_dm.F) so it will not make a difference. */
2946 #if 0
2947 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) ;
2948 #else
2949 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) ;
2950 #endif
2951 }
2952
2953 if ( dir == UNPACKIT )
2954 {
2955 if ( down_path == INTERP_UP )
2956 {
2957 char *sjl = "" ;
2958 if (p->nmm_v_grid)
2959 sjl = "_v" ;
2960 if ( zdex >= 0 ) {
2961 fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
2962 } else {
2963 fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
2964 }
2965 fprintf(fp,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
2966 sjl ,
2967 p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
2968 if ( zdex >= 0 ) {
2969 fprintf(fp,"DO k = %s,%s\n%s(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], feed, grid, vname ) ;
2970 } else {
2971 fprintf(fp,"%s(%s%s,xv(1))\n", feed, grid, vname ) ;
2972 }
2973 fprintf(fp,"ENDIF\n") ;
2974 }
2975 else
2976 {
2977 if ( zdex >= 0 ) {
2978 fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
2979 ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname) ;
2980 } else {
2981 fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname) ;
2982 }
2983 }
2984 }
2985 else
2986 {
2987 if ( down_path == INTERP_UP )
2988 {
2989 if ( zdex >= 0 ) {
2990 fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
2991 ddim[zdex][0], ddim[zdex][1], vname, ddim[zdex][1], ddim[zdex][0] ) ;
2992 } else {
2993 fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname) ;
2994 }
2995 }
2996 else
2997 {
2998 if ( zdex >= 0 ) {
2999 fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
3000 ddim[zdex][0], ddim[zdex][1], grid, vname, ddim[zdex][1], ddim[zdex][0] ) ;
3001 } else {
3002 fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname) ;
3003 }
3004 }
3005 }
3006 if ( p->node_kind & FOURD )
3007 {
3008 for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
3009 fprintf(fp,"ENDDO\n") ;
3010 }
3011 fprintf(fp,"ENDDO\n") ;
3012 }
3013 else
3014 {
3015 fprintf(fp,"ENDIF\n") ; /* in_use_for_config */
3016 }
3017 }
3018 }
3019 if(need_endif) {
3020 fprintf(fp,"endif\n");
3021 need_endif=0;
3022 }
3023
3024 return(0) ;
3025 }
3026
3027 /*****************/
3028
3029 /* STOPPED HERE -- need to include the extra dimensions in the count */
3030
3031 int
3032 count_fields ( node_t * node , int * d2 , int * d3 , char * fourd_names, int down_path,
3033 int send_mp, int no_mp )
3034 {
3035 node_t * p ;
3036 int zdex ;
3037 char temp[80], r[10], tx[80], *colon ;
3038 int d ;
3039
3040 strcpy(fourd_names,"") ; /* only works if non-recursive, but that is ifdefd out below */
3041 /* count up the total number of levels from all fields */
3042 for ( p = node ; p != NULL ; p = p->next )
3043 {
3044 if(send_mp && !p->mp_var) continue;
3045 if(no_mp && p->mp_var) continue;
3046 if ( p->node_kind == FOURD )
3047 {
3048 #if 0
3049 count_fields( p->members , d2 , d3 , down_path, send_mp, no_mp ) ; /* RECURSE */
3050 #else
3051 if ( strlen(fourd_names) > 0 ) strcat(fourd_names," & \n + ") ;
3052 sprintf(temp,"((num_%s - PARAM_FIRST_SCALAR + 1)",p->name) ;
3053 strcat(fourd_names,temp) ;
3054 for ( d = 3 ; d < p->ndims ; d++ ) {
3055 strcpy(r,"") ;
3056 range_of_dimension(r,tx,d,p,"config_flags%") ;
3057 colon = index(tx,':') ; *colon = '\0' ;
3058 sprintf(temp," &\n *((%s)-(%s)+1)",colon+1,tx) ;
3059 strcat(fourd_names,temp) ;
3060 }
3061 strcat(fourd_names,")") ;
3062 #endif
3063 }
3064 else
3065 {
3066 if ( p->nest_mask & down_path )
3067 {
3068 if ( p->node_kind == FOURD )
3069 zdex = get_index_for_coord( p->members , COORD_Z ) ;
3070 else
3071 zdex = get_index_for_coord( p , COORD_Z ) ;
3072
3073 if ( zdex < 0 ) {
3074 (*d2)++ ; /* if no zdex then only 2 d */
3075 } else {
3076 (*d3)++ ; /* if has a zdex then 3 d */
3077 }
3078 }
3079 }
3080 }
3081 return(0) ;
3082 }
3083
3084 /*****************/
3085 /*****************/
3086
3087 int
3088 gen_debug ( char * dirname )
3089 {
3090 int i ;
3091 FILE * fp ;
3092 node_t *p, *q, *dimd ;
3093 char **direction ;
3094 char *directions[] = { "x", "y", 0L } ;
3095 char fname[NAMELEN], vname[NAMELEN] ;
3096 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
3097 int zdex ;
3098 node_t Shift ;
3099 int said_it = 0 ;
3100 int said_it2 = 0 ;
3101
3102 if ( dirname == NULL ) return(1) ;
3103
3104 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/debuggal.inc",dirname) ; }
3105 else { sprintf(fname,"debuggal.inc") ; }
3106 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
3107
3108 /* now generate the shifts themselves */
3109 for ( p = Domain.fields ; p != NULL ; p = p->next )
3110 {
3111
3112 /* special cases in WRF */
3113 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
3114 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
3115 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
3116 continue ;
3117 }
3118
3119 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
3120 {
3121
3122 if ( p->type->type_type == SIMPLE )
3123 {
3124 for ( i = 1 ; i <= p->ntl ; i++ )
3125 {
3126
3127 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
3128 else sprintf(vname,"%s",p->name ) ;
3129
3130 if ( p->node_kind & FOURD )
3131 {
3132 #if 0
3133 node_t *member ;
3134 zdex = get_index_for_coord( p , COORD_Z ) ;
3135 if ( zdex >=1 && zdex <= 3 && strncmp(vname,"fdda",4) )
3136 {
3137 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
3138 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', itrace , %s ( IDEBUG,KDEBUG,JDEBUG,itrace)\n", vname, vname ) ;
3139 fprintf(fp, " ENDDO\n" ) ;
3140 }
3141 else
3142 {
3143 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
3144 }
3145 #endif
3146 }
3147 else
3148 {
3149 if ( p->ndims == 3 ) {
3150 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,KDEBUG,JDEBUG)\n", vname, vname ) ;
3151 } else if ( p->ndims == 2 ) {
3152 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,JDEBUG)\n", vname, vname ) ;
3153 }
3154 }
3155 }
3156 }
3157 }
3158 }
3159
3160 close_the_file(fp) ;
3161 return 0; /* SamT: bug fix: return a value */
3162 }
3163
3164 /*****************/
3165 /*****************/
3166
3167 int
3168 gen_comms ( char * dirname )
3169 {
3170 FILE *fpsub ;
3171 if ( sw_dm_parallel )
3172 fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
3173
3174 /* truncate this file if it exists */
3175 if ((fpsub = fopen( "inc/REGISTRY_COMM_NESTING_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3176 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3177 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_0_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3178 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_1_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3179 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_2_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3180 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_3_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
3181
3182 gen_halos( "inc" , NULL, Halos, 1 ) ;
3183 #if ( WRFPLUS == 1 )
3184 gen_halos_nta( "inc" , NULL, Halos_nta, 1 ) ;
3185 #endif
3186 gen_shift( "inc" ) ;
3187 gen_periods( "inc", Periods ) ;
3188 gen_swaps( "inc", Swaps ) ;
3189 gen_cycles( "inc", Cycles ) ;
3190 gen_xposes( "inc" ) ;
3191 gen_comm_descrips( "inc" ) ;
3192 gen_datacalls( "inc" ) ;
3193 gen_nest_packing( "inc" ) ;
3194 #if 0
3195 gen_debug( "inc" ) ;
3196 #endif
3197
3198 return(0) ;
3199 }
3200
Mirror of the official repository at https://github.com/wrf-model/WRF