Context Navigation

gen_comms.c

Last change on this file was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 108.9 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: