#include #include #include #include #include "protos.h" #include "registry.h" #include "data.h" #include "sym.h" static FILE * fp ; #define GEN_INPUT 1 #define GEN_OUTPUT 2 #define OP_F(A,B) \ fn = B ; \ if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } \ else { sprintf(fname,"%s",fn) ; } \ if ((A = fopen( fname , "w" )) == NULL ) return(1) ; \ print_warning(A,fname) ; \ sym_forget() ; int gen_wrf_io ( char * dirname ) { char fname[NAMELEN], *fn ; if ( dirname == NULL ) return(1) ; #if 1 OP_F(fp,"wrf_metaput_input.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | INPUT , GEN_OUTPUT ) ; OP_F(fp,"wrf_metaput_restart.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | RESTART , GEN_OUTPUT ) ; OP_F(fp,"wrf_metaput_history.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | HISTORY , GEN_OUTPUT ) ; OP_F(fp,"wrf_metaput_boundary.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | BOUNDARY , GEN_OUTPUT ) ; OP_F(fp,"wrf_histout.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist1out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist2out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist3out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist4out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist5out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist6out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist7out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist8out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist9out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist10out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist11out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_inputout.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput1out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput2out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput3out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput4out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput5out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput6out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput7out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput8out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput9out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput10out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput11out.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_restartout.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_OUTPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_bdyout.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_OUTPUT ) ; close_the_file(fp) ; #endif #if 1 OP_F(fp,"wrf_metaget_input.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | INPUT , GEN_INPUT ) ; OP_F(fp,"wrf_metaget_restart.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | RESTART , GEN_INPUT ) ; OP_F(fp,"wrf_metaget_history.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | HISTORY , GEN_INPUT ) ; OP_F(fp,"wrf_metaget_boundary.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , METADATA | BOUNDARY , GEN_INPUT ) ; OP_F(fp,"wrf_histin.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist1in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist2in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist3in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist4in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist5in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist6in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist7in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist8in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist9in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist10in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxhist11in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_inputin.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput1in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput2in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput3in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput4in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput5in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput6in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput7in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput8in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput9in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput10in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_auxinput11in.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_restartin.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_INPUT ) ; close_the_file(fp) ; OP_F(fp,"wrf_bdyin.inc") ; gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_INPUT ) ; close_the_file(fp) ; #endif return(0) ; } int set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag ) { int i, j ; node_t *p ; char d ; char * stag ; if ( node == NULL ) return(1) ; for ( i = 0 ; i < 3 ; i++ ) for ( j = 0 ; j < 2 ; j++ ) { strcpy(ddim[i][j],"1") ; strcpy(mdim[i][j],"1") ; strcpy(pdim[i][j],"1") ; } for ( i = 0 ; i < node->ndims ; i++ ) { p = node->dims[i] ; if ( p->len_defined_how == DOMAIN_STANDARD ) { if ( sw_3dvar_iry_kludge ) { switch( p->coord_axis ) { /* vvv */ case(COORD_X) : d = 'i' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; case(COORD_Y) : d = 'j' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; /* ^^^ */ case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; default : stag = "1" ; break ; } } else { switch( p->coord_axis ) { case(COORD_X) : d = 'i' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; case(COORD_Y) : d = 'j' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; default : stag = "1" ; break ; } } sprintf(ddim[i][0],"%s%cds",prepend,d) ; sprintf(ddim[i][1],stag,prepend,d) ; /* note that stag has printf format info in it */ sprintf(mdim[i][0],"%s%cms",prepend,d) ; sprintf(mdim[i][1],"%s%cme",prepend,d) ; sprintf(pdim[i][0],"%s%cps",prepend,d) ; if ( ! sw_disregard_stag ) sprintf(pdim[i][1],"MIN( %s, %s%cpe )",ddim[i][1],prepend,d) ; else sprintf(pdim[i][1],"%s%cpe",prepend,d) ; } else if ( p->len_defined_how == NAMELIST ) { if ( !strcmp( p->assoc_nl_var_s, "1" ) ) { sprintf(ddim[i][0],"1") ; sprintf(mdim[i][0],"1") ; sprintf(pdim[i][0],"1") ; } else { sprintf(ddim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; sprintf(mdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; sprintf(pdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; } sprintf(ddim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; sprintf(mdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; sprintf(pdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; } else if ( p->len_defined_how == CONSTANT ) { sprintf(ddim[i][0],"%d",p->coord_start ) ; sprintf(ddim[i][1],"%d",p->coord_end ) ; sprintf(mdim[i][0],"%d",p->coord_start ) ; sprintf(mdim[i][1],"%d",p->coord_end ) ; sprintf(pdim[i][0],"%d",p->coord_start ) ; sprintf(pdim[i][1],"%d",p->coord_end ) ; } } return(0) ; } int gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int io_mask , int sw_io ) { node_t * p ; int i , ii ; char x[NAMELEN], tag[NAMELEN], dexes[NAMELEN] ; char dname[NAMELEN], dname_tmp[NAMELEN] ; char vname[NAMELEN], vname_x[NAMELEN],vname_1[NAMELEN], vname_2[NAMELEN], memord[NAMELEN] ; char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; char pdim[3][2][NAMELEN] ; char ddim_no[3][2][NAMELEN] ; char mdim_no[3][2][NAMELEN] ; char pdim_no[3][2][NAMELEN] ; char dimname[3][NAMELEN] ; char core[NAMELEN] ; char stagstr[NAMELEN] ; char * tend_tag ; char post[NAMELEN] ; char indices[NAMELEN] ; int pass, passes, stagx, stagy, stagz ; int xi, yi, zi ; node_t * dimnode ; int ok_to_collect_distribute ; /* set a flag according to what the stream is, if we're running on dm processors, if the io layer cannot handle distributed data, and if we're selectively turning off the collect/distribute message passing so that history and restart I/O is to separate files but input and boundary I/O is unaffected */ ok_to_collect_distribute = !sw_distrib_io_layer && sw_dm_parallel && !(sw_dm_serial_in_only && ((io_mask&HISTORY) || (io_mask&AUXHIST1) || (io_mask&AUXHIST2) || (io_mask&AUXHIST3) || (io_mask&AUXHIST4) || (io_mask&AUXHIST5) || (io_mask&AUXHIST6) || (io_mask&AUXHIST7) || (io_mask&AUXHIST8) || (io_mask&AUXHIST9) || (io_mask&AUXHIST10) || (io_mask&AUXHIST11) || (io_mask&RESTART))) ; if ( node == NULL ) return(1) ; if ( structname == NULL ) return(1) ; if ( fp == NULL ) return(1) ; for ( p = node ; p != NULL ; p = p->next ) { if ( p->ndims > 3 ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */ if ( p->node_kind & I1 ) continue ; /* short circuit anything that's not a state var */ set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */ set_dim_strs( p, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */ strcpy(stagstr, "") ; if ( p->stag_x ) strcat(stagstr, "X") ; if ( p->stag_y ) strcat(stagstr, "Y") ; if ( p->stag_z ) strcat(stagstr, "Z") ; if ( !strcmp(p->name,"-") ) continue ; if ( p->node_kind & FOURD ) { node_t * nd , *pp ; char p1[NAMELEN], sv[NAMELEN], tl[25] ; set_dim_strs( p->members, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */ set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */ if ( ! ( io_mask & BOUNDARY ) ) { fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ; fprintf(fp," fid , & ! DataHandle\n") ; fprintf(fp," current_date(1:19) , & ! DateStr\n") ; fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ; strcpy( tl, "" ) ; if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ; if ( ok_to_collect_distribute ) { fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ; } else { fprintf(fp," grid%%%s%s(ims,kms,jms,itrace) , & ! Field\n",p->name,tl) ; } if (!strncmp(p->members->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; if ( sw_io == GEN_OUTPUT ) { fprintf(fp," dryrun , & ! flag\n") ; } set_mem_order( p->members, memord , NAMELEN) ; fprintf(fp," 'XZY' , & ! MemoryOrder\n") ; strcpy(stagstr, "") ; if ( p->members->stag_x ) strcat(stagstr, "X") ; if ( p->members->stag_y ) strcat(stagstr, "Y") ; if ( p->members->stag_z ) strcat(stagstr, "Z") ; fprintf(fp," '%s' , & ! Stagger\n",stagstr) ; if ( sw_io == GEN_OUTPUT ) { for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; for ( i = 0 ; i < 3 ; i++ ) { if (( dimnode = p->members->dims[i]) != NULL ) { switch ( dimnode->coord_axis ) { case (COORD_X) : if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; case (COORD_Y) : if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; case (COORD_Z) : if ( p->members->stag_z ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; } } } fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ; fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ; } fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ; /* global dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } fprintf(fp," & \n") ; /* mem dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } fprintf(fp," & \n") ; /* patch dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } fprintf(fp," & \n") ; fprintf(fp," ierr )\n" ) ; fprintf(fp, " ENDIF\n" ) ; fprintf(fp, "ENDDO\n") ; } /* BOUNDARY FOR 4-D TRACER */ else if ( io_mask & BOUNDARY ) { int ibdy ; int idx ; node_t *fourd_bound_array ; char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ; char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; /* check for the existence of a fourd boundary array */ sprintf(fourd_bnd,"%s_b",p->name) ; if (( fourd_bound_array = get_entry( fourd_bnd ,Domain.fields)) != NULL ) { for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; strcpy( dimname[2] , "bdy_width" ) ; ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ; ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ; ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ; if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL ) { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[1], dimnode->dim_data_name) ; } if ( p->stag_z ) { zdomainend = "kde" ; } else { zdomainend = "(kde-1)" ; } ds2 = "kds" ; de2 = zdomainend ; ms2 = "kds" ; me2 = "kde" ; /* 20020924 */ ps2 = "kds" ; pe2 = zdomainend ; } else { fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ; } for ( pass = 0 ; pass < 2 ; pass++ ) { fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ ) { if ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ; /* west bdy */ } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ; /* east bdy */ } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ; /* south bdy */ } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ; /* north bdy */ } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ; /* west bdy */ } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ; /* east bdy */ } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ; /* south bdy */ } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ; /* north bdy */ } if ( ibdy == 1 || ibdy == 2 ) { if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL ) { idx = get_index_for_coord( p , COORD_Y ) ; if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; } ds1 = "1" ; de1 = ydomainend ; ms1 = "1" ; me1 = "MAX( ide , jde )" ; if ( sw_io == GEN_INPUT ) { ps1 = "1" ; pe1 = ydomainend ; } else if ( sw_io == GEN_OUTPUT ) { ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; } if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[0], dimnode->dim_data_name) ; } } } if ( ibdy == 3 || ibdy == 4 ) { if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL ) { idx = get_index_for_coord( p , COORD_X ) ; if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; } ds1 = "1" ; de1 = xdomainend ; ms1 = "1" ; me1 = "MAX( ide , jde )" ; if ( sw_io == GEN_INPUT ) { ps1 = "1" ; pe1 = xdomainend ; } else if ( sw_io == GEN_OUTPUT ) { ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; } if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[0], dimnode->dim_data_name) ; } } } if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ; else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ; else sprintf(memord,"0") ; fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ; fprintf(fp," fid , & ! DataHandle\n") ; fprintf(fp," current_date(1:19) , & ! DateStr\n") ; fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ; if ( ok_to_collect_distribute ) { fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ; } else { strcpy(bdytag2,"") ; strncat(bdytag2,bdytag, pass+2) ; fprintf(fp," grid%%%s%s(1,kds,1,%d,itrace) , & ! Field\n",p->name,bdytag2,ibdy) ; } if (!strncmp(p->members->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; if ( sw_io == GEN_OUTPUT ) { fprintf(fp," dryrun , & ! flag\n") ; } fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ; strcpy(stagstr, "") ; if ( p->members->stag_x ) strcat(stagstr, "X") ; if ( p->members->stag_y ) strcat(stagstr, "Y") ; if ( p->members->stag_z ) strcat(stagstr, "Z") ; fprintf(fp," '%s' , & ! Stagger\n",stagstr) ; if ( sw_io == GEN_OUTPUT ) { fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ; fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ; } fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; fprintf(fp," ierr )\n" ) ; } fprintf(fp, " ENDIF\n" ) ; fprintf(fp, "ENDDO\n") ; } } } /* if fourd bound array associated with this tracer */ } else if ( p->type != NULL ) { if ( p->type->type == SIMPLE ) { /* //////// BOUNDARY ///////////////////// */ if ( p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA ) && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) ) { int ibdy ; int idx ; char *bdytag, *xdomainend, *ydomainend, *zdomainend ; char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s_",p->use+4) ; else strcpy(core,"") ; for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; strcpy( dimname[2] , "bdy_width" ) ; ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ; ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ; ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ; if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL ) { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[1], dimnode->dim_data_name) ; } if ( p->stag_z ) { zdomainend = "kde" ; } else { zdomainend = "(kde-1)" ; } ds2 = "kds" ; de2 = zdomainend ; ms2 = "kds" ; me2 = "kde" ; /* 20020924 */ ps2 = "kds" ; pe2 = zdomainend ; } else { strcpy(dimname[1],dimname[2]) ; strcpy(dimname[2],"one_element") ; ds2 = ds3 ; de2 = de3 ; ms2 = ms3 ; me2 = me3 ; ps2 = ps3 ; pe2 = pe3 ; ds3 = "1" ; de3 = "1" ; ms3 = "1" ; me3 = "1" ; ps3 = "1" ; pe3 = "1" ; } if ( strlen(p->dname) < 1 ) { fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ; } for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ ) { if ( ibdy == 1 ) { bdytag = "XS" ; /* west bdy */ } else if ( ibdy == 2 ) { bdytag = "XE" ; /* east bdy */ } else if ( ibdy == 3 ) { bdytag = "YS" ; /* south bdy */ } else if ( ibdy == 4 ) { bdytag = "YE" ; /* north bdy */ } if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag) ; } else { sprintf(dname,"%s%s",p->dname,bdytag) ; } make_upper_case(dname) ; if ( ibdy == 1 || ibdy == 2 ) { if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL ) { idx = get_index_for_coord( p , COORD_Y ) ; if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; } ds1 = "1" ; de1 = ydomainend ; ms1 = "1" ; me1 = "MAX( ide , jde )" ; if ( sw_io == GEN_INPUT ) { ps1 = "1" ; pe1 = ydomainend ; } else if ( sw_io == GEN_OUTPUT ) { ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; } if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[0], dimnode->dim_data_name) ; } } } if ( ibdy == 3 || ibdy == 4 ) { if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL ) { idx = get_index_for_coord( p , COORD_X ) ; if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; } ds1 = "1" ; de1 = xdomainend ; ms1 = "1" ; me1 = "MAX( ide , jde )" ; if ( sw_io == GEN_INPUT ) { ps1 = "1" ; pe1 = xdomainend ; } else if ( sw_io == GEN_OUTPUT ) { ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; } if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[0], dimnode->dim_data_name) ; } } } if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ; else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ; else sprintf(memord,"0") ; passes = 1 ; if ( fourdname != NULL ) passes = 2 ; for ( pass = 0 ; pass < passes ; pass++ ) { tend_tag = ( pass == 0 ) ? "_B" : "_BT" ; if ( sw_io == GEN_INPUT ) { if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; if ( ok_to_collect_distribute ) fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; fprintf(fp,"CALL wrf_ext_read_field ( &\n") ; fprintf(fp," fid , & ! DataHandle \n" ) ; fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; if ( fourdname == NULL ) { fprintf(fp," '%s' , & ! Data Name \n", dname ) ; fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ; } else { if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; } else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; } fprintf(fp," '%s' , & ! Data Name \n", dname ) ; fprintf(fp," %s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" , structname , core , fourdname, tend_tag, ibdy, p->name ) ; } if (!strncmp(p->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; /* global dimensions */ fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; fprintf(fp," ierr )\n") ; if ( ok_to_collect_distribute ) { fprintf(fp,"ENDIF\n") ; fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , core , p->name, ibdy) ; fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1) )\n",me1,ms1,me2,ms2,me3,ms3) ; } if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"END IF\n" ) ; } else if ( sw_io == GEN_OUTPUT ) { if ( ok_to_collect_distribute ) fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; fprintf(fp,"CALL wrf_ext_write_field ( &\n") ; fprintf(fp," fid , & ! DataHandle \n" ) ; fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; if ( fourdname == NULL ) { fprintf(fp," '%s' , & ! Data Name \n", dname ) ; fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ; } else { if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; } else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; } fprintf(fp," '%s' , & ! Data Name \n", dname ) ; fprintf(fp," %s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" , structname , core , fourdname, tend_tag, ibdy, p->name ) ; } if (!strncmp(p->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; fprintf(fp," dryrun , & ! flag\n" ) ; fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ; fprintf(fp," '%s' , & ! Units \n",p->units ) ; fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; /* global dimensions */ fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; fprintf(fp," ierr )\n") ; if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"END IF\n" ) ; if ( ok_to_collect_distribute ) fprintf(fp,"ENDIF\n") ; } } } } /* //////// NOT BOUNDARY ///////////////////// */ else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY)) { /* Aug 2004 Namelist variables The i r and h settings will be reenabled but it will work a little differently than i/o of regular state variables: 1) rather than being read or written as records to the dataset, they will be gotten or put as time invariant meta data; in other words, they will only be written once when the dataset is created as the other metadata is now. This has the benefit of reducing the amount of I/O traffic on each write (I can't remember, but that may be why the reading and writing of rconfig data was turned off in the first place). 2) All the rconfig variables will be gotten/put as metadata to input, restart, history, and boundary datasets, regardless of what the 'i', 'r', and 'h' settings are. Instead those settings will control the behavior with respect to the input-from-namelist vs input-from-dataset precedence issue that Bill raised. In other words, if an rconfig entry has an 'i', 'r', or 'h' in the Registry, the dataset value takes precedence over the namelist value. Otherwise, say it is missing the 'i', the reconfig variable's value still appears as metadata in the dataset but the value of the variable in the program does not change as a result of inputting the dataset. */ if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) ) { char c ; char dname[NAMELEN] ; strcpy( dname, p->dname ) ; make_upper_case( dname ) ; if ( !strcmp( p->type->name , "integer" ) ) { c = 'i' ; } else if ( !strcmp( p->type->name , "real" ) ) { c = 'r' ; } else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; } else if ( !strcmp( p->type->name , "logical" ) ) { c = 'l' ; } else { fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ; } if ( sw_io == GEN_OUTPUT ) { if ( io_mask & p->io_mask ) { fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; } } else { if ( io_mask & p->io_mask ) { fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ; fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ; fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; } } } /* end Aug 2004 */ #if 0 else if ( ! (io_mask & METADATA) ) /* state vars */ #else else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) ) /* state vars */ #endif { if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ; else passes = 1 ; for ( pass = 0 ; pass < passes ; pass++ ) /* for multi timelevel vars */ { if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s_",p->use+4) ; else strcpy(core,"") ; /* for multi time level variables gen read for both levels for restart, only _2 for others */ if ( p->ntl > 1 ) { if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ; else sprintf(tag,"_%d",p->ntl) ; } else sprintf(tag,"") ; /* construct variable name */ if ( p->scalar_array_member ) { strcpy(dexes,"") ; for (ii = 0; ii < p->ndims; ii++ ) { switch(p->dims[ii]->coord_axis) { case(COORD_X): strcat(dexes,"ims,") ; break ; case(COORD_Y): strcat(dexes,"jms,") ; break ; case(COORD_Z): strcat(dexes,"kms,") ; break ; default : break ; } } sprintf(vname,"%s%s%s(%sP_%s)",core,p->use,tag,dexes,p->name) ; sprintf(vname_2,"%s%s%s(%sP_%s)",core,p->use,"_2",":,:,:,",p->name) ; sprintf(vname_1,"%s%s%s(%sP_%s)",core,p->use,"_1",":,:,:,",p->name) ; sprintf(vname_x,"%s%s%s(%sP_%s)",core,p->use,tag,":,:,:,",p->name) ; } else { sprintf(vname,"%s%s%s",core,p->name,tag) ; sprintf(vname_x,"%s%s%s",core,p->name,tag) ; sprintf(vname_1,"%s%s%s",core,p->name,"_1") ; sprintf(vname_2,"%s%s%s",core,p->name,"_2") ; } /* construct data name -- maybe same as vname if dname not spec'd */ if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; } else { strcpy(dname_tmp,p->dname) ; } make_upper_case(dname_tmp) ; /* July 2004 New code to generate error if input or output for two state variables would be generated with the same dataname example okay: dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB dyn_em soiltb "SOILTB" -> dyn_em_tg,SOILTB example wrong: dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB misc soiltb "SOILTB" -> gen_soiltb,SOILTB example wrong: misc tg "SOILTB" -> gen_tg,SOILTB misc soiltb "SOILTB" -> gen_soiltb,SOILTB */ if ( pass == 0 ) { char dname_symbol[128] ; sym_nodeptr sym_node ; sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ; /* check and see if it is in the symbol table already */ if ((sym_node = sym_get( dname_symbol )) == NULL ) { /* add it */ sym_node = sym_add ( dname_symbol ) ; strcpy( sym_node->internal_name , p->name ) ; strcpy( sym_node->core_name , core ) ; } else { /* it's there already, check and make sure we don't have an error condition */ if ( (strlen(core) > 0 && strlen( sym_node->core_name ) > 0 && !strcmp( core, sym_node->core_name )) || strlen(core) == 0 || strlen( sym_node->core_name ) == 0 ) { char this_core[64] , sym_core[64] ; strcpy(this_core,"(generic)") ; if ( strlen(core) > 0 ) sprintf(this_core,"(%s)",core) ; strcpy(sym_core,"(generic)") ; if ( strlen(sym_node->core_name) > 0 ) sprintf(this_core,"(%s)",sym_node->core_name) ; fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s %s and %s %s\n", dname_tmp,p->name,this_core,sym_node->internal_name,sym_core ) ; } } } /* end July 2004 */ if ( io_mask & RESTART && p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ; else strcpy(dname,dname_tmp) ; set_mem_order( p, memord , NAMELEN) ; /* kludge for WRF 3DVAR I/O with MM5 analysis kernel */ if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ; if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ; if ( strlen(dname) < 1 ) { fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ; } if ( p->io_mask & io_mask && sw_io == GEN_INPUT ) { if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; if ( p->scalar_array_member ) fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; if ( ok_to_collect_distribute ) fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; strcpy(indices,"") ; sprintf(post,")") ; if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ { sprintf(indices, "%s",index_with_firstelem("(","grid%",t2,p,post)) ; } fprintf(fp,"CALL wrf_ext_read_field ( &\n") ; fprintf(fp," fid , & ! DataHandle \n" ) ; fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; fprintf(fp," '%s' , & ! Data Name \n", dname ) ; if ( p->ndims >= 2 && ok_to_collect_distribute ) fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; else fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices) ; if (!strncmp(p->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; /* global dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } fprintf(fp," & \n") ; /* the first two cases here have to do with if we're running on multiple distributed memory processors and the i/o api layer can't handle decomposed data. So code is generated to read the data on processor zero into a globally sized buffer. In this case, then the domain, memory, and patch dimensions for the globally sized buffer are all just the domain dimensions. Two D arrays are handled separately from three-d arrays because in threeD arrays the middle index is K. In the last case, where the code is either calling a version of the API that supports parallelism or we aren't running in DM-parallel, the field itself and not a global buffer are passed, so we pass the domain, memory, and patch indices directly to the read routine. */ if ( p->ndims == 3 && ok_to_collect_distribute ) { /* mem dimensions are actually domain dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } fprintf(fp," & \n") ; /* patch dimensions are actually domain dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim [i][0], ddim [i][1]) ; } fprintf(fp," & \n") ; } else if ( p->ndims == 2 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) { /* mem dimensions are actually domain dimensions */ fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1] ) ; /* patch dimensions are actually domain dimensions */ fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim [xi][0],ddim [xi][1], ddim [yi][0],ddim [yi][1] ) ; } } else { /* mem dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } fprintf(fp," & \n") ; /* patch dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } fprintf(fp," & \n") ; } fprintf(fp," ierr )\n") ; if ( ok_to_collect_distribute ) fprintf(fp,"END IF\n" ) ; /* In case we have read into a global buffer, generate code to distribute the data just read in */ if ( p->ndims == 3 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) { fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1], ddim_no[zi][0],ddim_no[zi][1]) ; fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], mdim_no[yi][0],mdim_no[yi][1], mdim_no[zi][0],mdim_no[zi][1]) ; fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], pdim_no[yi][0],pdim_no[yi][1], pdim_no[zi][0],pdim_no[zi][1]) ; } } else if ( p->ndims == 2 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) { fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1] ) ; fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], mdim_no[yi][0],mdim_no[yi][1] ) ; fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], pdim_no[yi][0],pdim_no[yi][1] ) ; } else { fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; } } else if ( !strcmp(memord,"Z") && ok_to_collect_distribute ) { fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ; } else if ( !strcmp(memord,"0") && ok_to_collect_distribute ) { fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ; } else if ( ok_to_collect_distribute ) { fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ; } if ( io_mask & INPUT && p->ntl > 1 ) { /* copy time level two into time level one */ if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ; if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ; } if ( p->scalar_array_member ) { fprintf(fp,"END IF\n" ) ; } if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"END IF\n" ) ; } else if ( sw_io == GEN_OUTPUT ) { if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; if ( p->scalar_array_member ) fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; /* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data */ if ( p->ndims == 3 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) { fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; /* fprintf(fp, "ids , ide , jds , jde , kds , kde , &\n") ; */ fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1], ddim_no[zi][0],ddim_no[zi][1]) ; fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], mdim_no[yi][0],mdim_no[yi][1], mdim_no[zi][0],mdim_no[zi][1]) ; fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], pdim_no[yi][0],pdim_no[yi][1], pdim_no[zi][0],pdim_no[zi][1]) ; } } else if ( p->ndims == 2 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) { fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; /* fprintf(fp, "ids , ide , jds , jde , 1 , 1 , &\n") ; */ fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1] ) ; fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], mdim_no[yi][0],mdim_no[yi][1] ) ; fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], pdim_no[yi][0],pdim_no[yi][1] ) ; } else { fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; } } for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; for ( i = 0 ; i < 3 ; i++ ) { if (( dimnode = p->dims[i]) != NULL ) { switch ( dimnode->coord_axis ) { case (COORD_X) : if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; case (COORD_Y) : if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; case (COORD_Z) : if ( p->stag_z ) { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } else { strcpy( dimname[i], dimnode->dim_data_name) ; } break ; } } } if ( ok_to_collect_distribute ) fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; strcpy(indices,"") ; sprintf(post,")") ; if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ { sprintf(indices, "%s",index_with_firstelem("(","grid%",t2,p,post)) ; } if ( !(p->scalar_array_member) ) { fprintf(fp,"CALL wrf_ext_write_field ( &\n") ; fprintf(fp," fid , & ! DataHandle \n" ) ; fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; fprintf(fp," '%s' , & ! Data Name \n", dname ) ; if ( p->ndims >= 2 && ok_to_collect_distribute ) fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; else fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices ) ; if (!strncmp(p->type->name,"real",4)) { fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } fprintf(fp," grid%%communicator , & ! Comm\n") ; fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; fprintf(fp," dryrun , & ! flag\n" ) ; fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ; fprintf(fp," '%s' , & ! Units \n",p->units ) ; fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; /* global dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } fprintf(fp," & \n") ; /* the first two cases here have to do with if we're running on multiple distributed memory processors and the i/o api layer can't handle decomposed data. So code is generated to read the data on processor zero into a globally sized buffer. In this case, then the domain, memory, and patch dimensions for the globally sized buffer are all just the domain domain dimensions. Two D arrays are handled separately from three-d arrays because in threeD arrays the middle index is K. In the last case, where the code is either calling a version of the API that supports parallelism or we aren't running in DM-parallel, the field itself and not a global buffer are passed, so we pass the domain, memory, and patch indices directly to the read routine. */ if ( p->ndims == 3 && ok_to_collect_distribute ) { /* mem dimensions are actually domain dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } fprintf(fp," & \n") ; /* patch dimensions are actually domain dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } fprintf(fp," & \n") ; } else if ( p->ndims == 2 && ok_to_collect_distribute ) { if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) { /* mem dimensions are actually domain dimensions */ fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], ddim_no[yi][0],ddim_no[yi][1] ) ; /* patch dimensions are actually domain dimensions */ fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1], ddim[yi][0],ddim[yi][1] ) ; } } else { /* mem dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } fprintf(fp," & \n") ; /* patch dimensions */ for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } fprintf(fp," & \n") ; } fprintf(fp," ierr )\n") ; if ( ok_to_collect_distribute ) fprintf(fp,"END IF\n" ) ; /* if ( p->scalar_array_member ) fprintf(fp,"END IF\n" ) ; */ if ( !strncmp( p->use, "dyn_", 4 ) ) fprintf(fp,"END IF\n" ) ; } } } } } } if ( p->type->type_type == DERIVED ) { sprintf(x,"%s%s%%",structname,p->name ) ; gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ; } } } return(0) ; }