/wrfv2_fire/external/RSL_LITE/gen_comms.c
C | 2448 lines | 2206 code | 166 blank | 76 comment | 833 complexity | a49569cce082a2ef413251e7875b6468 MD5 | raw file
Possible License(s): AGPL-1.0
Large files files are truncated, but you can click here to view the full file
- #include <stdio.h>
- #include <stdlib.h>
- #include <string.h>
- #ifdef _WIN32
- #define index(X,Y) strchr(X,Y)
- #endif
- #include "protos.h"
- #include "registry.h"
- #include "data.h"
- /* For detecting variables that are members of a derived type */
- #define NULLCHARPTR (char *) 0
- static int parent_type;
- /* print actual and dummy arguments and declarations for 4D and i1 arrays */
- int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */, int du /* 0=dummy,1=actual */)
- {
- node_t * q ;
- node_t * dimd ;
- char fname[NAMELEN] ;
- char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
- char commuse[NAMELEN] ;
- int maxstenwidth, stenwidth ;
- char * t1, * t2 , *wordsize ;
- char varref[NAMELEN], moredims[80] ;
- char * pos1 , * pos2 ;
- char * dimspec ;
- char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
- int zdex, d ;
- set_mark( 0, Domain.fields ) ;
- strcpy( tmp, p->comm_define ) ;
- strcpy( commuse, p->use ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- {
- fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ;
- }
- t2 = strtok_rentr(NULL,",", &pos2) ;
- while ( t2 != NULL )
- {
- if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
- { fprintf(stderr,"WARNING 1a : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
- else
- {
- strcpy( varref, t2 ) ;
- if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
- sprintf(varref,"grid%%%s",t2) ;
- }
- if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
- else if ( q->boundary_array ) { ; }
- else
- {
- if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
- if ( q->node_kind & FOURD )
- {
- node_t *member ;
- zdex = get_index_for_coord( q , COORD_Z ) ;
- if ( zdex >=1 && zdex <= 3 )
- {
- set_mem_order( q->members, memord , 3 ) ;
- if ( ad == 0 )
- /* actual or dummy argument */
- {
- /* explicit dummy or actual arguments for 4D arrays */
- if ( q->mark == 0 ) {
- fprintf(fp," num_%s, &\n",q->name) ;
- for ( d = 3 ; d < q->ndims ; d++ ) {
- char *colon, r[80],tx[80] ;
- strcpy(r,"") ;
- range_of_dimension(r,tx,d,q,du?"":"config_flags%") ;
- colon = index(tx,':') ; *colon = '\0' ;
- if ( du ) { /* dummy args */
- fprintf(fp,"%s_sdim%d,%s_edim%d, &\n",q->name,d-2,q->name,d-2) ;
- } else {
- fprintf(fp,"%s,%s,&\n",tx,colon+1) ;
- }
- }
- q->mark = 1 ;
- }
- fprintf(fp," %s, &\n",varref) ;
- }
- else
- {
- /* declaration of dummy arguments for 4D arrays */
- if ( q->mark == 0 ) {
- fprintf(fp," INTEGER, INTENT(IN) :: num_%s\n",q->name) ;
- for ( d = 3 ; d < q->ndims ; d++ ) {
- fprintf(fp," INTEGER, INTENT(IN) :: %s_sdim%d,%s_edim%d\n",q->name,d-2,q->name,d-2) ;
- }
- q->mark = 1 ;
- }
- strcpy(moredims,"") ;
- for ( d = 3 ; d < q->ndims ; d++ ) {
- char temp[80] ;
- sprintf(temp,",%s_sdim%d:%s_edim%d",q->name,d-2,q->name,d-2) ;
- strcat(moredims,temp) ;
- }
- strcat(moredims,",") ;
- fprintf(fp," %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
- q->type->name , varref , moredims, q->name ) ;
- }
- }
- else
- {
- fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
- }
- }
- else if ( q->node_kind & I1 )
- {
- if ( ad == 0 )
- {
- /* explicit dummy or actual arguments for i1 arrays */
- fprintf(fp," %s, &\n",varref) ;
- }
- else
- {
- /* declaration of dummy arguments for i1 arrays */
- strcpy(tmp3,"") ;
- dimspec=dimension_with_ranges( "grid%","(",-1,tmp3,q,")","" ) ;
- fprintf(fp," %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
- }
- }
- }
- }
- t2 = strtok_rentr( NULL , "," , &pos2 ) ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- }
- int print_call_or_def( FILE * fp , node_t *p, char * callorsub,
- char * commname, char * communicator,
- int need_config_flags )
- {
- fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ;
- if (need_config_flags == 1)
- fprintf(fp," config_flags, &\n") ;
- print_4d_i1_decls( fp, p, 0, (!strcmp("CALL",callorsub))?0:1 );
- fprintf(fp," %s, &\n",communicator) ;
- fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
- fprintf(fp," ims, ime, jms, jme, kms, kme, &\n") ;
- fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
- return(0) ;
- }
- int print_decl( FILE * fp , node_t *p, char * communicator,
- int need_config_flags )
- {
- fprintf(fp," USE module_domain, ONLY:domain\n") ;
- fprintf(fp," USE module_configure, ONLY:grid_config_rec_type,in_use_for_config\n") ;
- fprintf(fp," USE module_state_description, ONLY:PARAM_FIRST_SCALAR\n") ;
- fprintf(fp," USE module_driver_constants\n") ;
- fprintf(fp," TYPE(domain) , INTENT(IN) :: grid\n") ;
- if (need_config_flags == 1)
- fprintf(fp," TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags\n") ;
- print_4d_i1_decls( fp, p, 1, 0 );
- fprintf(fp," INTEGER , INTENT(IN) :: %s\n",communicator) ;
- fprintf(fp," INTEGER , INTENT(IN) :: mytask, ntasks, ntasks_x, ntasks_y\n") ;
- fprintf(fp," INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde\n") ;
- fprintf(fp," INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme\n") ;
- fprintf(fp," INTEGER , INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe\n") ;
- fprintf(fp," INTEGER :: itrace\n") ;
- fprintf(fp," INTEGER :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p\n") ;
- fprintf(fp," INTEGER :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m\n") ;
- fprintf(fp," LOGICAL, EXTERNAL :: rsl_comm_iter\n") ;
- fprintf(fp," INTEGER :: idim1, idim2, idim3, idim4, idim5, idim6, idim7\n") ;
- }
- int print_body( FILE * fp, char * commname )
- {
- fprintf(fp," \n") ;
- fprintf(fp,"#ifdef DM_PARALLEL\n") ;
- fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ;
- fprintf(fp,"#endif\n") ;
- fprintf(fp," \n") ;
- fprintf(fp," END SUBROUTINE %s_sub\n",commname) ;
- }
- int
- gen_halos ( char * dirname , char * incname , node_t * halos, int split )
- {
- node_t * p, * q ;
- node_t * dimd ;
- char commname[NAMELEN], subs_fname[NAMELEN] ;
- char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
- char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
- char commuse[NAMELEN] ;
- #define MAX_VDIMS 100
- char vdims[MAX_VDIMS][2][80] ;
- char s[NAMELEN], e[NAMELEN] ;
- int vdimcurs ;
- int maxstenwidth_int, stenwidth ;
- char maxstenwidth[NAMELEN] ;
- FILE * fp ;
- FILE * fpcall ;
- FILE * fpsub ;
- char * t1, * t2 ;
- char * pos1 , * pos2 ;
- char indices[NAMELEN], post[NAMELEN] ;
- int zdex ;
- int n2dR, n3dR ;
- int n2dI, n3dI ;
- int n2dD, n3dD ;
- int n4d ;
- int i, foundvdim ;
- int subgrid ;
- int need_config_flags;
- #define MAX_4DARRAYS 1000
- char name_4d[MAX_4DARRAYS][NAMELEN] ;
- #define FRAC 4
- int num_halos, fraction, ihalo, j ;
- if ( dirname == NULL ) return(1) ;
- if ( split ) {
- for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) { /* howmany deez guys? */
- if ( incname == NULL ) {
- strcpy( commname, p->name ) ;
- make_upper_case(commname) ;
- }
- else {
- strcpy( commname, incname ) ;
- }
- if ( !( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN" )
- || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) {
- num_halos++ ;
- }
- }
- }
- ihalo = 0 ;
- for ( p = halos ; p != NULL ; p = p->next )
- {
- need_config_flags = 0; /* 0 = do not need, 1 = need */
- if ( incname == NULL ) {
- strcpy( commname, p->name ) ;
- make_upper_case(commname) ;
- }
- else {
- strcpy( commname, incname ) ;
- }
- if ( incname == NULL ) {
- if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
- else { sprintf(fname,"%s_inline.inc",commname) ; }
- /* Generate call to custom routine that encapsulates inlined comm calls */
- if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
- else { sprintf(fnamecall,"%s.inc",commname) ; }
- if ((fpcall = fopen( fnamecall , "w" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall ) ;
- continue ;
- }
- print_warning(fpcall,fnamecall) ;
- if ( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN")
- || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) {
- sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ;
- } else {
- if ( split ) {
- j = ihalo / ((num_halos+1)/FRAC+1) ; /* the compiler you save may be your own */
- sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ;
- ihalo++ ;
- } else {
- sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ;
- }
- }
- /* Generate definition of custom routine that encapsulates inlined comm calls */
- if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; }
- else { sprintf(fnamesub,"%s",subs_fname) ; }
- if ((fpsub = fopen( fnamesub , "a" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
- continue ;
- }
- print_warning(fpsub,fnamesub) ;
- }
- else {
- /* for now, retain original behavior when called from gen_shift */
- if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
- else { sprintf(fname,"%s.inc",commname) ; }
- }
- /* Generate inlined comm calls */
- if ((fp = fopen( fname , "w" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
- continue ;
- }
- /* get maximum stencil width */
- maxstenwidth_int = 0 ;
- strcpy( tmp, p->comm_define ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
- if ( !strcmp(t2,"SHW") ) {
- stenwidth = -99 ;
- maxstenwidth_int = -99 ; /* use a run-time computed stencil width based on nest ratio */
- break ; /* note that SHW is set internally by gen_shift, it should never be used in a Registry file */
- } else {
- stenwidth = atoi (t2) ;
- if ( stenwidth == 0 )
- { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
- if ( stenwidth == 4 || stenwidth == 8 ) stenwidth = 1 ;
- else if ( stenwidth == 12 || stenwidth == 24 ) stenwidth = 2 ;
- else if ( stenwidth == 48 ) stenwidth = 3 ;
- else if ( stenwidth == 80 ) stenwidth = 4 ;
- else if ( stenwidth == 120 ) stenwidth = 5 ;
- else if ( stenwidth == 168 ) stenwidth = 6 ;
- else
- { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
- if ( stenwidth > maxstenwidth_int ) maxstenwidth_int = stenwidth ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- if ( maxstenwidth_int == -99 ) {
- sprintf(maxstenwidth,"grid%%parent_grid_ratio") ;
- } else {
- sprintf(maxstenwidth,"%d",maxstenwidth_int) ;
- }
- print_warning(fp,fname) ;
- fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
- /* count up the number of 2d and 3d real arrays and their types */
- n2dR = 0 ; n3dR = 0 ;
- n2dI = 0 ; n3dI = 0 ;
- n2dD = 0 ; n3dD = 0 ;
- n4d = 0 ;
- vdimcurs = 0 ;
- subgrid = -1 ; /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
- strcpy( tmp, p->comm_define ) ;
- strcpy( commuse, p->use ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
- t2 = strtok_rentr(NULL,",", &pos2) ;
- while ( t2 != NULL )
- {
- if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
- { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
- else
- {
- if ( subgrid == -1 ) { /* first one */
- subgrid = q->subgrid ;
- } else if ( subgrid != q->subgrid ) {
- fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
- }
- if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
- { 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) ; }
- else if ( q->boundary_array )
- { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
- else
- {
- /* 20061004 -- collect all the vertical dimensions so we can use a MAX
- on them when calling RSL_LITE_INIT_EXCH */
- if ( q->ndims == 3 || q->node_kind & FOURD ) {
- if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
- zdex = get_index_for_coord( q , COORD_Z ) ;
- if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
- strcpy(s,"kps") ;
- strcpy(e,"kpe") ;
- }
- else if ( dimd->len_defined_how == NAMELIST ) {
- need_config_flags = 1;
- if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
- strcpy(s,"1") ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- } else {
- sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- }
- }
- else if ( dimd->len_defined_how == CONSTANT ) {
- sprintf(s,"%d",dimd->coord_start) ;
- sprintf(e,"%d",dimd->coord_end) ;
- }
- for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
- if ( !strcmp( vdims[i][1], e ) ) {
- foundvdim = 1 ; break ;
- }
- }
- if ( ! foundvdim ) {
- if (vdimcurs < 100 ) {
- strcpy( vdims[vdimcurs][0], s ) ;
- strcpy( vdims[vdimcurs][1], e ) ;
- vdimcurs++ ;
- } else {
- fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
- fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
- fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
- exit(5) ;
- }
- }
- }
- }
- if ( q->node_kind & FOURD ) {
- if ( n4d < MAX_4DARRAYS ) {
- int d ;
- char temp[80], tx[80], r[10], *colon ;
- strcpy( name_4d[n4d], q->name ) ;
- for ( d = 3 ; d < q->ndims ; d++ ) {
- sprintf(temp,"*(%s_edim%d-%s_sdim%d+1)",q->name,d-2,q->name,d-2) ;
- strcat( name_4d[n4d],temp) ;
- }
- } else {
- fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
- fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
- fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
- exit(5) ;
- }
- n4d++ ;
- }
- else
- {
- if ( ! strcmp( q->type->name, "real") ) {
- if ( q->ndims == 3 ) { n3dR++ ; }
- else if ( q->ndims == 2 ) { n2dR++ ; }
- } else if ( ! strcmp( q->type->name, "integer") ) {
- if ( q->ndims == 3 ) { n3dI++ ; }
- else if ( q->ndims == 2 ) { n2dI++ ; }
- } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
- if ( q->ndims == 3 ) { n3dD++ ; }
- else if ( q->ndims == 2 ) { n2dD++ ; }
- }
- }
- }
- }
- t2 = strtok_rentr( NULL , "," , &pos2 ) ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- /* generate the stencil init statement for Y transfer */
- #if 0
- fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxstenwidth,fname) ;
- #endif
- if ( subgrid != 0 ) {
- fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
- }
- fprintf(fp,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
- fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
- fprintf(fp," 0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
- fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
- fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
- fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
- fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
- fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
- if ( n4d > 0 ) {
- fprintf(fp, " %d &\n", n3dR ) ;
- for ( i = 0 ; i < n4d ; i++ ) {
- fprintf(fp," + num_%s &\n", name_4d[i] ) ;
- }
- fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
- } else {
- fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
- }
- fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
- fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
- fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
- fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
- if ( subgrid == 0 ) {
- fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
- for ( i = 0 ; i < vdimcurs ; i++ ) {
- fprintf(fp,",%s &\n",vdims[i][1] ) ;
- }
- fprintf(fp,"))\n") ;
- } else {
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- /* generate packs prior to stencil exchange in Y */
- gen_packs_halo( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ;
- /* generate stencil exchange in Y */
- fprintf(fp," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
- /* generate unpacks after stencil exchange in Y */
- gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
- fprintf(fp,"ENDDO\n") ;
- /* generate the stencil init statement for X transfer */
- fprintf(fp,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
- fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ;
- fprintf(fp," 1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
- fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
- fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p ))\n" ) ;
- fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
- fprintf(fp," rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, & \n" ) ;
- fprintf(fp," rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, & \n" ) ;
- if ( n4d > 0 ) {
- fprintf(fp, " %d &\n", n3dR ) ;
- for ( i = 0 ; i < n4d ; i++ ) {
- fprintf(fp," + num_%s &\n", name_4d[i] ) ;
- }
- fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
- } else {
- fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
- }
- fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
- fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
- fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
- fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
- if ( subgrid == 0 ) {
- fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
- for ( i = 0 ; i < vdimcurs ; i++ ) {
- fprintf(fp,",%s &\n",vdims[i][1] ) ;
- }
- fprintf(fp,"))\n") ;
- } else {
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- /* generate packs prior to stencil exchange in X */
- gen_packs_halo( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ;
- /* generate stencil exchange in X */
- fprintf(fp," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ;
- /* generate unpacks after stencil exchange in X */
- gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
- fprintf(fp," ENDDO\n") ;
- if ( subgrid != 0 ) {
- fprintf(fp,"ENDIF\n") ;
- }
- close_the_file(fp) ;
- if ( incname == NULL ) {
- /* Finish call to custom routine that encapsulates inlined comm calls */
- print_call_or_def(fpcall, p, "CALL", commname, "local_communicator", need_config_flags );
- close_the_file(fpcall) ;
- /* Generate definition of custom routine that encapsulates inlined comm calls */
- print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator", need_config_flags );
- print_decl(fpsub, p, "local_communicator", need_config_flags );
- print_body(fpsub, commname);
- close_the_file(fpsub) ;
- }
- }
- return(0) ;
- }
- 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 )
- {
- node_t * q ;
- node_t * dimd ;
- char fname[NAMELEN] ;
- char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
- char commuse[NAMELEN] ;
- int maxstenwidth, stenwidth ;
- char * t1, * t2 , *wordsize ;
- char varref[NAMELEN] ;
- char varname[NAMELEN] ;
- char * pos1 , * pos2 ;
- char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
- int xdex,ydex,zdex ;
- strcpy( tmp, p->comm_define ) ;
- strcpy( commuse, p->use ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
- t2 = strtok_rentr(NULL,",", &pos2) ;
- while ( t2 != NULL )
- {
- if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
- { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
- else
- {
- strcpy( varname, t2 ) ;
- strcpy( varref, t2 ) ;
- if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
- sprintf(varref,"grid%%%s",t2) ;
- }
- if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
- else if ( q->boundary_array ) { ; }
- else
- {
- if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
- if ( q->node_kind & FOURD )
- {
- node_t *member ;
- zdex = get_index_for_coord( q , COORD_Z ) ;
- if ( zdex >=1 && zdex <= 3 )
- {
- int d ;
- char * colon ;
- char moredims[80], tx[80], temp[10], r[80] ;
- set_mem_order( q->members, memord , 3 ) ;
- fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
- strcpy(moredims,"") ;
- for ( d = q->ndims-1 ; d >= 3 ; d-- ) {
- fprintf(fp," DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ;
- }
- for ( d = 3 ; d < q->ndims ; d++ ) {
- strcpy(r,"") ;
- range_of_dimension( r, tx, d, q, "config_flags%" ) ;
- colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ;
- sprintf(temp,"idim%d",d-2) ;
- strcat(moredims,",") ; strcat(moredims,temp) ;
- }
- strcat(moredims,",") ;
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- 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",
- packname, commname, varref , moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
- !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
- fprintf(fp,"thisdomain_max_halo_width, &\n") ;
- }
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
- fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- fprintf(fp," ENDIF\n") ;
- for ( d = 3 ; d < q->ndims ; d++ ) {
- fprintf(fp," ENDDO ! idim%d \n",d-2 ) ;
- }
- fprintf(fp,"ENDDO\n") ;
- }
- else
- {
- fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
- }
- }
- else
- {
- set_mem_order( q, memord , 3 ) ;
- if ( q->ndims == 3 ) {
- dimd = get_dimnode_for_coord( q , COORD_Z ) ;
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- zdex = get_index_for_coord( q , COORD_Z ) ;
- fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- if ( dimd != NULL )
- {
- char s[256], e[256] ;
- if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
- 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",
- packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
- fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- }
- else if ( dimd->len_defined_how == NAMELIST )
- {
- if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
- strcpy(s,"1") ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- } else {
- sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- }
- 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",
- packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
- fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
- fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
- }
- }
- else if ( dimd->len_defined_how == CONSTANT )
- {
- 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",
- packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
- }
- }
- }
- fprintf(fp,"ENDIF\n") ;
- } else if ( q->ndims == 2 ) {
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- 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",
- packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
- fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
- }
- fprintf(fp,"ENDIF\n") ;
- }
- }
- }
-
- }
- t2 = strtok_rentr( NULL , "," , &pos2 ) ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- }
- 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 )
- {
- node_t * q ;
- node_t * dimd ;
- char fname[NAMELEN] ;
- char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
- char commuse[NAMELEN] ;
- int maxstenwidth, stenwidth ;
- char * t1, * t2 , *wordsize ;
- char varref[NAMELEN] ;
- char varname[NAMELEN] ;
- char * pos1 , * pos2 ;
- char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
- int xdex,ydex,zdex ;
- strcpy( tmp, p->comm_define ) ;
- strcpy( commuse, p->use ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
- t2 = strtok_rentr(NULL,",", &pos2) ;
- while ( t2 != NULL )
- {
- if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
- { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
- else
- {
- strcpy( varname, t2 ) ;
- strcpy( varref, t2 ) ;
- if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
- sprintf(varref,"grid%%%s",t2) ;
- }
- if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
- else if ( q->boundary_array ) { ; }
- else
- {
- if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
- else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
- if ( q->node_kind & FOURD )
- {
- node_t *member ;
- zdex = get_index_for_coord( q , COORD_Z ) ;
- if ( zdex >=1 && zdex <= 3 )
- {
- set_mem_order( q->members, memord , 3 ) ;
- fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- fprintf(fp," CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %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) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
- !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
- fprintf(fp,"thisdomain_max_halo_width, &\n") ;
- }
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
- fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- fprintf(fp," ENDIF\n") ;
- fprintf(fp,"ENDDO\n") ;
- }
- else
- {
- fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
- }
- }
- else
- {
- set_mem_order( q, memord , 3 ) ;
- if ( q->ndims == 3 ) {
- dimd = get_dimnode_for_coord( q , COORD_Z ) ;
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- zdex = get_index_for_coord( q , COORD_Z ) ;
- fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- if ( dimd != NULL )
- {
- char s[256], e[256] ;
- if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
- 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) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
- fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
- }
- }
- else if ( dimd->len_defined_how == NAMELIST )
- {
- if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
- strcpy(s,"1") ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- } else {
- sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
- sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
- }
- 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) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
- fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
- fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
- }
- }
- else if ( dimd->len_defined_how == CONSTANT )
- {
- 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) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
- }
- }
- }
- fprintf(fp,"ENDIF\n") ;
- } else if ( q->ndims == 2 ) {
- xdex = get_index_for_coord( q , COORD_X ) ;
- ydex = get_index_for_coord( q , COORD_Y ) ;
- fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
- 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) ) ;
- fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
- if ( q->subgrid == 0 ) {
- fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
- fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
- fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
- } else {
- fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
- fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
- fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
- }
- fprintf(fp,"ENDIF\n") ;
- }
- }
- }
-
- }
- t2 = strtok_rentr( NULL , "," , &pos2 ) ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- }
- int
- gen_periods ( char * dirname , node_t * periods )
- {
- node_t * p, * q ;
- node_t * dimd ;
- char commname[NAMELEN] ;
- char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
- char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
- char commuse[NAMELEN] ;
- int maxperwidth, perwidth ;
- FILE * fp ;
- FILE * fpcall ;
- FILE * fpsub ;
- char * t1, * t2 ;
- char varref[NAMELEN] ;
- char * pos1 , * pos2 ;
- char indices[NAMELEN], post[NAMELEN] ;
- int zdex ;
- int n2dR, n3dR ;
- int n2dI, n3dI ;
- int n2dD, n3dD ;
- int n4d ;
- int i ;
- #define MAX_4DARRAYS 1000
- char name_4d[MAX_4DARRAYS][NAMELEN] ;
- if ( dirname == NULL ) return(1) ;
- /* Open and truncate REGISTRY_COMM_DM_PERIOD_subs.inc so file exists even if there are no periods. */
- if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
- else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
- if ((fpsub = fopen( fnamesub , "w" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
- }
- if ( fpsub != NULL ) {
- print_warning(fpsub,fnamesub) ;
- fclose(fpsub) ;
- }
- for ( p = periods ; p != NULL ; p = p->next )
- {
- strcpy( commname, p->name ) ;
- make_upper_case(commname) ;
- if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
- else { sprintf(fname,"%s_inline.inc",commname) ; }
- /* Generate call to custom routine that encapsulates inlined comm calls */
- if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
- else { sprintf(fnamecall,"%s.inc",commname) ; }
- if ((fpcall = fopen( fnamecall , "w" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
- continue ;
- }
- print_warning(fpcall,fnamecall) ;
- print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
- close_the_file(fpcall) ;
- /* Generate definition of custom routine that encapsulates inlined comm calls */
- if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
- else { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
- if ((fpsub = fopen( fnamesub , "a" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
- continue ;
- }
- print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
- print_decl(fpsub, p, "local_communicator_periodic", 1 );
- print_body(fpsub, commname);
- close_the_file(fpsub) ;
- /* Generate inlined comm calls */
- if ((fp = fopen( fname , "w" )) == NULL )
- {
- fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
- continue ;
- }
- /* get maximum period width */
- maxperwidth = 0 ;
- strcpy( tmp, p->comm_define ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
- perwidth = atoi (t2) ;
- if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- print_warning(fp,fname) ;
- fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
- /* count up the number of 2d and 3d real arrays and their types */
- n2dR = 0 ; n3dR = 0 ;
- n2dI = 0 ; n3dI = 0 ;
- n2dD = 0 ; n3dD = 0 ;
- n4d = 0 ;
- strcpy( tmp, p->comm_define ) ;
- strcpy( commuse, p->use ) ;
- t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
- for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
- while ( t1 != NULL )
- {
- strcpy( tmp2 , t1 ) ;
- if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
- { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
- t2 = strtok_rentr(NULL,",", &pos2) ;
- while ( t2 != NULL )
- {
- if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
- { fprintf(stderr,"WARNING 1 : %s in period spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
- else
- {
- if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
- { 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) ; }
- else if ( q->boundary_array )
- { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
- else
- {
- if ( q->node_kind & FOURD ) {
- if ( n4d < MAX_4DARRAYS ) {
- strcpy( name_4d[n4d], q->name ) ;
- } else {
- fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
- fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
- fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
- exit(5) ;
- }
- n4d++ ;
- }
- else
- {
- if ( ! strcmp( q->type->name, "real") ) {
- if ( q->ndims == 3 ) { n3dR++ ; }
- else if ( q->ndims == 2 ) { n2dR++ ; }
- } else if ( ! strcmp( q->type->name, "integer") ) {
- if ( q->ndims == 3 ) { n3dI++ ; }
- else if ( q->ndims == 2 ) { n2dI++ ; }
- } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
- if ( q->ndims == 3 ) { n3dD++ ; }
- else if ( q->ndims == 2 ) { n2dD++ ; }
- }
- }
- }
- }
- t2 = strtok_rentr( NULL , "," , &pos2 ) ;
- }
- t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
- }
- fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
- /* generate the stencil init statement for X transfer */
- fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
- if ( n4d > 0 ) {
- fprintf(fp, " %d &\n", n3dR ) ;
- for ( i = 0 ; i < n4d ; i++ ) {
- fprintf(fp," + num_%s &\n", name_4d[i] ) ;
- }
- fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
- } else {
- fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
- }
- fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
- fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
- fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
- fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
- fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
- /* generate packs prior to exchange in X */
- gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
- /* generate exchange in X */
- fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_X ( local_com…
Large files files are truncated, but you can click here to view the full file