#include #include #include #include #include "protos.h" #include "registry.h" #include "data.h" int gen_alloc ( char * dirname ) { gen_alloc1( dirname ) ; gen_ddt_write( dirname ) ; return(0) ; } int gen_alloc1 ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; char * fn = "allocs.inc" ; if ( dirname == NULL ) return(1) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } else { sprintf(fname,"%s",fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; gen_alloc2( fp , "grid%", &Domain, 1 ) ; close_the_file( fp ) ; return(0) ; } int gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allocate, 2 = just count */ { node_t * p ; int tag ; char post[NAMELEN], post_for_count[NAMELEN] ; char fname[NAMELEN] ; char x[NAMELEN] ; char tchar ; if ( node == NULL ) return(1) ; for ( p = node->fields ; p != NULL ; p = p->next ) { if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */ (p->node_kind & FIELD) || /* scalar arrays */ (p->node_kind & FOURD) ) /* scalar arrays */ ) { if ( p->type != NULL ) { tchar = '?' ; if ( !strcmp( p->type->name , "real" ) ) { tchar = 'R' ; } else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; } else if ( !strcmp( p->type->name , "logical" ) ) { tchar = 'L' ; } else if ( !strcmp( p->type->name , "integer" ) ) { tchar = 'I' ; } else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; } } if ( p->node_kind & FOURD ) { sprintf(post, ",num_%s)",field_name(t4,p,0)) ; sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; } else { sprintf(post, ")" ) ; sprintf(post_for_count, ")" ) ; } for ( tag = 1 ; tag <= p->ntl ; tag++ ) { if ( !strcmp ( p->use , "_4d_bdy_array_") ) { strcpy(fname,p->name) ; } else { strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; } /* check for errors in memory allocation */ if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; } else { fprintf(fp,"IF(.TRUE.") ; } if ( ! ( p->node_kind & FOURD ) && sw == 1 && ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) ) { fprintf(fp,".AND.(.NOT.inter_domain)",tag) ; } if ( p->ntl > 1 && sw == 1 ) { fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ; } fprintf(fp,")THEN\n") ; if ( p->boundary_array && sw_new_bdys ) { int bdy ; for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { if( p->type != NULL && tchar != '?' ) { fprintf(fp," num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n", array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"), tchar) ; } if ( sw == 1 ) { fprintf(fp, " ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n", structname, fname, bdy_indicator(bdy), dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"), structname, fname, bdy_indicator(bdy), dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%")); fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy)); if( p->type != NULL && (!strcmp( p->type->name , "real" ) || !strcmp( p->type->name , "doubleprecision") ) ) { /* if a real */ fprintf(fp, "initial_data_value\n"); } else if ( !strcmp( p->type->name , "logical" ) ) { fprintf(fp, ".FALSE.\n"); } else if ( !strcmp( p->type->name , "integer" ) ) { fprintf(fp, "0\n"); } } } } else { if( p->type != NULL && tchar != '?' ) { fprintf(fp," num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n", array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"), tchar) ; } if ( sw == 1 ) { fprintf(fp, " ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n", structname, fname, dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"), structname, fname, dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%")); fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname); if( p->type != NULL && (!strcmp( p->type->name , "real" ) || !strcmp( p->type->name , "doubleprecision") ) ) { /* if a real */ fprintf(fp, "initial_data_value\n"); } else if ( !strcmp( p->type->name , "logical" ) ) { fprintf(fp, ".FALSE.\n"); } else if ( !strcmp( p->type->name , "integer" ) ) { fprintf(fp, "0\n"); } } } fprintf(fp,"ELSE\n") ; if ( p->boundary_array && sw_new_bdys ) { int bdy ; for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { fprintf(fp, " ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n", structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ), structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ; } } else { fprintf(fp, " ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n 'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n", structname, fname, dimension_with_ones( "(",t2,p,")" ), structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ; } fprintf(fp,"ENDIF\n") ; /* end of in_use conditional */ } } if ( p->type != NULL ) { if ( p->type->type_type == SIMPLE && p->ndims == 0 && (!strcmp(p->type->name,"integer") || !strcmp(p->type->name,"logical") || !strcmp(p->type->name,"real") || !strcmp(p->type->name,"doubleprecision")) ) { strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; if ( sw == 1 ) { if( !strcmp( p->type->name , "real" ) || !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */ fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n", structname , fname ) ; } else if ( !strcmp( p->type->name , "integer" ) ) { fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n", structname , fname ) ; } else if ( !strcmp( p->type->name , "logical" ) ) { fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n", structname , fname ) ; } } } else if ( p->type->type_type == DERIVED ) { sprintf(x,"%s%s%%",structname,p->name ) ; gen_alloc2(fp,x, p->type, sw) ; } } } return(0) ; } int gen_alloc_count ( char * dirname ) { gen_alloc_count1( dirname ) ; return(0) ; } int gen_alloc_count1 ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; char * fn = "alloc_count.inc" ; if ( dirname == NULL ) return(1) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } else { sprintf(fname,"%s",fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; gen_alloc2( fp , "grid%", &Domain, 0 ) ; close_the_file( fp ) ; return(0) ; } int gen_ddt_write ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; char * fn = "write_ddt.inc" ; if ( dirname == NULL ) return(1) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } else { sprintf(fname,"%s",fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; gen_ddt_write1( fp , "grid%", &Domain ) ; close_the_file( fp ) ; return(0) ; } int gen_ddt_write1 ( FILE * fp , char * structname , node_t * node ) { node_t * p ; int tag ; char post[NAMELEN] ; char fname[NAMELEN] ; char x[NAMELEN] ; if ( node == NULL ) return(1) ; for ( p = node->fields ; p != NULL ; p = p->next ) { if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */ (p->node_kind & FIELD) || /* scalar arrays or... */ (p->node_kind & FOURD) ) /* scalar arrays or... */ ) { if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; } else { sprintf(post,")") ; } for ( tag = 1 ; tag <= p->ntl ; tag++ ) { strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; if ( p->node_kind & FOURD ) { fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ; } else { if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ; if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ; } } } } return(0) ; } int gen_dealloc ( char * dirname ) { gen_dealloc1( dirname ) ; return(0) ; } int gen_dealloc1 ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; char * fn = "deallocs.inc" ; if ( dirname == NULL ) return(1) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } else { sprintf(fname,"%s",fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; gen_dealloc2( fp , "grid%", &Domain ) ; close_the_file( fp ) ; return(0) ; } int gen_dealloc2 ( FILE * fp , char * structname , node_t * node ) { node_t * p ; int tag ; char post[NAMELEN] ; char fname[NAMELEN] ; char x[NAMELEN] ; if ( node == NULL ) return(1) ; for ( p = node->fields ; p != NULL ; p = p->next ) { if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */ (p->node_kind & FIELD) || /* scalar arrays or */ (p->node_kind & FOURD) ) /* scalar arrays or */ ) { if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; } else { sprintf(post,")") ; } for ( tag = 1 ; tag <= p->ntl ; tag++ ) { strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; if ( p->boundary && sw_new_bdys ) { { int bdy ; for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { fprintf(fp, "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ; fprintf(fp, " DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s%s. ')\n endif\n", structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ; fprintf(fp, " NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ; fprintf(fp, "ENDIF\n" ) ; } } } else { fprintf(fp, "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ; fprintf(fp, " DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s. ')\n endif\n", structname, fname, structname, fname ) ; fprintf(fp, " NULLIFY(%s%s)\n",structname, fname ) ; fprintf(fp, "ENDIF\n" ) ; } } } if ( p->type != NULL ) { if ( p->type->type_type == SIMPLE && p->ndims == 0 && (!strcmp(p->type->name,"integer") || !strcmp(p->type->name,"real") || !strcmp(p->type->name,"doubleprecision")) ) { } else if ( p->type->type_type == DERIVED ) { sprintf(x,"%s%s%%",structname,p->name ) ; gen_dealloc2(fp,x, p->type) ; } } } return(0) ; }