tools/CodeBase/wrfvar.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <sys/types.h>
   4 #include <dirent.h>
   5 #include <sys/wait.h>
   6 #include <string.h>
   7
   8 #define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) )
   9 #define COMPARE2(A,B) ( ! strcmp ( A , B ) )
  10 #define INLINELEN (4*8192)
  11 #define VARLEN 128
  12 #define MAXARGS (4*8192)
  13
  14
  15 #define DBDIR "tools/code_dbase"
  16
  17 int sw_all  = 0 ;
  18
  19
  20 main( int argc, char *argv[] )
  21 {
  22   FILE *fp ;
  23   FILE *calls ;
  24   char fname[VARLEN], syscom[VARLEN] ;
  25   char *rout , *vname ;
  26   if ( argc < 2 || argc > 5 || ( argc == 2 && ! COMPARE2( argv[1] , "rebuild" ) ) ) {
  27     printf("usage : wrfvar varname routinename\n" ) ;
  28     printf("        wrfvar rebuild\n" ) ;
  29     exit(2) ;
  30   }
  31   vname = argv[1] ;
  32   rout = argv[2] ;
  33   if ( argc == 4 && argv[3] != NULL ) {
  34     if ( COMPARE2( argv[3] , "all" ) ) sw_all = 1 ;
  35   }
  36   sprintf( fname, "%s/calls", DBDIR ) ;
  37   if (( fp = fopen ( fname , "r" )) == NULL || COMPARE2( argv[1], "rebuild" ) ) {
  38     int rc ;
  39     printf("Building code database ... please wait\n") ;
  40     sprintf( syscom, "cd tools/CodeBase ; make" ) ;
  41     rc = system( syscom ) ;
  42     if ( WEXITSTATUS( rc ) ) { exit(3) ; }
  43     sprintf( syscom, "tools/build_codebase" ) ;
  44     rc = system( syscom ) ;
  45     if ( WEXITSTATUS( rc ) ) { exit(3) ; }
  46     sprintf( syscom, "ln -sf tools/wrfvar ." ) ;
  47     sprintf( syscom, "ln -sf tools/subinfo ." ) ;
  48     if ( COMPARE2( argv[1] , "rebuild" ) ) exit ;
  49   }
  50   fclose( fp ) ;
  51   lower_case_str ( vname ) ;
  52   lower_case_str ( rout ) ;
  53   printf("<h4>Trace upwards through call tree for %s</h4><p>\n",vname ) ;
  54   wrfvar ( vname, rout, 0 ) ;
  55 }
  56
  57 wrfvar ( char * vname, char *rout, int recursion_level )
  58 {
  59   FILE *ROUT ;
  60   FILE *BBB ;
  61   FILE *ELEF ;
  62   FILE *CALLER ;
  63   FILE *CALLERS ;
  64   FILE *REGISTRY ;
  65   DIR  *dir ;
  66   char inln[INLINELEN], inln2[INLINELEN], inln3[INLINELEN] ;
  67   int i ;
  68   char fname[VARLEN], fname2[VARLEN], sf[VARLEN] ;
  69   char vv[VARLEN], vv2[VARLEN] ;
  70   char u0[VARLEN] , u1[VARLEN] , u2[VARLEN] ;
  71   char v0[VARLEN] , v1[VARLEN] , v2[VARLEN] ;
  72   char r[12][VARLEN], t[12][VARLEN], u[12][VARLEN], v[12][VARLEN] ;
  73   char routfile[VARLEN] ;
  74   char tmp[VARLEN], darg[VARLEN], dintent[VARLEN] ;
  75   char hamuna[VARLEN] ;
  76   char rout1[VARLEN], rout2[VARLEN], rout3[VARLEN] ;
  77   char sourcefile[VARLEN], sourcefile_caller[VARLEN] ;
  78   char s1[VARLEN], s2[VARLEN], s3[VARLEN] ;
  79   char * p, * q, * q1, prev ;
  80   int found_var, nargs_rout, argn, callno, more_calls, first_time ;
  81   int contains_i1_declarations ;
  82
  83   if (( dir = opendir ( DBDIR )) == NULL ) {
  84     fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ;
  85   } closedir( dir ) ;
  86
  87   strcpy( rout1, rout ) ;
  88   strcpy( vv, vname ) ;
  89   strcpy( vv2, vname ) ;
  90   remove_whitespace( vv2 ) ;
  91   /* remove arguments */
  92   if ((q = strchr( vv2 , '(' )) != NULL ) *q = '\0' ;
  93   /* remove time level if there */
  94   if (( q = strrchr( vv2, '_' )) != NULL ) {
  95     if ( COMPARE2( q , "_1" ) || COMPARE2( q , "_2" ) || COMPARE2( q , "_3" ) ) *q = '\0' ;
  96   }
  97   if ( COMPARE( vv2, "grid%" ) || !strcmp( rout, "registry_i1" )) {
  98     if (( REGISTRY = fopen( "Registry/Registry" , "r" )) == NULL ) {
  99           fprintf(stderr,"can not open Registry/Registry\n") ; exit(2) ; }
 100     strcpy( inln, "" ) ;
 101     while ( fgets( inln2, INLINELEN, REGISTRY ) != NULL ) {
 102       int inquote ;
 103       strcat( inln, inln2 ) ;
 104       if (( q = strrchr ( inln, '\\' )) != NULL ) {   /* continuation */
 105         *q = '\0' ; continue ;
 106       }
 107       if (( q = strchr( inln, '#' )) != NULL ) *q = '\0' ;
 108       inquote = 0 ;
 109       for ( p = inln, q = inln2 ; *p ; p++, q++ ) {
 110         if      ( ! inquote && *p == '"' ) { inquote = 1 ; *p = ' ' ; }
 111         else if (   inquote && *p == '"' ) { inquote = 0 ; *p = ' ' ; }
 112         if ( *p == ' ' && inquote ) { *q = '`' ; }
 113         else                        { *q = *p ; }
 114       }
 115       *q = '\0' ;
 116       for ( i = 0 ; i < 11 ; i++ ) {
 117         strcpy( r[i] , "" ) ;
 118         get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ;
 119         if ( i < 10 ) lower_case_str( r[i] ) ;
 120       }
 121       if ( COMPARE2 ( r[0], "state" ) ) {
 122         if ( COMPARE ( r[4], "dyn_" ) ) {
 123           /* if core associated */
 124           sprintf(s1,"%s_",&(r[4][4])) ;
 125           i = strlen(&(r[4][4])) ;
 126 #if 1
 127           { char *x , *y ; int j ;
 128             for ( x = vv2+5 , y = s3 , j = 0 ; j < i ; j++ ) { *y++ = *x++ ; }
 129             *y = '\0' ;
 130           }
 131 #else
 132 /* is there a bug in this?? */
 133           strncpy( s3, vv2+5, i ) ;
 134 fprintf(stderr,"X %s <- %s %d\n", s3, vv2, i ) ;
 135 #endif
 136           sprintf(s2,"%s_",s3) ;
 137           if ( COMPARE2 ( s1, s2 )  &&
 138                 COMPARE2 ( vv2+5+(strlen(r[4])-3), r[2] ) ) {
 139             for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 140             for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 141             printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
 142                    recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
 143           }
 144         } else {
 145           /* if not core associated */
 146           if ( COMPARE2 ( vv2+5, r[2] ) ) {
 147             for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 148             for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 149             printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
 150                    recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
 151           }
 152         }
 153       } else if ( COMPARE2 ( r[0], "rconfig" ) ) {
 154           if ( COMPARE2 ( vv2+5, r[2] ) ) {
 155             for (p = r[8]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 156             printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <br>\n",
 157                    recursion_level+1, r[0], r[1], r[2], r[8] ) ;
 158           }
 159       } else if ( COMPARE2 ( r[0], "i1" ) && !strcmp( rout, "registry_i1" )) {
 160           if ( COMPARE2 ( vv2, r[2] ) ) {
 161             for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 162             for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
 163             printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
 164                    recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
 165           }
 166       }
 167
 168       strcpy( inln, "" ) ;
 169     }
 170     fclose( REGISTRY ) ;
 171     return ;
 172   }
 173
 174   sprintf( routfile, "%s/%s", DBDIR, rout ) ;
 175   strcpy ( sourcefile , "" ) ;
 176   found_var = 0 ;
 177   nargs_rout = 0 ;
 178   if (( ROUT = fopen( routfile, "r" )) == NULL ) return ;
 179   {
 180     contains_i1_declarations = 0 ;
 181     while ( fgets( inln, INLINELEN, ROUT ) != NULL ) {
 182       remove_nl ( inln ) ;
 183       /* find first non space */
 184       for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; }
 185       /* change multiple spaces to single space */
 186       for ( q = p, q1 = q , prev = *p ; *q ; q++ )
 187          { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
 188       strcpy( inln, p ) ;
 189       for ( i = 0 ; i < 11 ; i++ ) {
 190         strcpy( t[i] , "" ) ;
 191         get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ;
 192       }
 193       if ( COMPARE2( "contains_i1_declarations", t[0] ) ) {
 194         contains_i1_declarations = 1 ;
 195       } else if ( COMPARE2( "sourcefile" , t[0] ) ) {
 196         strcpy ( sourcefile , t[1] ) ;
 197       } else if ( COMPARE2( "arg" , t[0] ) ) {
 198         nargs_rout ++ ;
 199         if ( COMPARE2( t[3] , vname ) && ! COMPARE2( t[9] , "registry" ) ) {
 200           argn = atoi( t[1] ) ;
 201           printf("%3d. <b>%s</b> is dummy arg %d of %s (%s);\n", recursion_level+1, vname, argn+1, rout, sourcefile ) ;
 202           found_var = 1 ;
 203           fclose( ROUT ) ;
 204           sprintf(fname,"%s/calls", DBDIR ) ;
 205           strcpy( rout2, rout ) ;
 206           if (( CALLERS = fopen( fname , "r" )) == NULL ) return ;
 207           while ( fgets( inln2, INLINELEN, CALLERS ) != NULL ) {
 208             for ( i = 0 ; i < 11 ; i++ ) {
 209               strcpy( u[i] , "" ) ;
 210               get_token_n( inln2, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ;
 211             }
 212             if ( COMPARE2( u[2], rout2 ) ) {
 213               strcpy( rout , u[0] ) ;
 214               sprintf( fname, "%s/%s", DBDIR, rout ) ;
 215               if (( ROUT = fopen( fname, "r" )) == NULL ) return ;
 216               strcpy ( sourcefile_caller, "" ) ;
 217               callno = 1 ;
 218               more_calls = 0 ;
 219               while ( fgets( inln3, INLINELEN, ROUT ) != NULL ) {
 220                 for ( i = 0 ; i < 11 ; i++ ) {
 221                   strcpy( v[i] , "" ) ;
 222                   get_token_n( inln3, " ", i , v[i] ) ; remove_nl(v[i]) ; lower_case_str( v[i] ) ;
 223                 }
 224                 if        ( COMPARE2( v[0] , "sourcefile" ) ) {
 225                   strcpy( sourcefile_caller, v[1] ) ;
 226                 } else if ( COMPARE2( v[0] , "actarg") && ( COMPARE2( v[4] , rout2 ) && atoi( v[1] ) == argn )) {
 227                   if ( callno == 1 || sw_all ) {
 228                     printf("     corresponding actual arg is <b>%s</b>, arg number %d in call %d by %s (%s).<br>\n",
 229                               v[6],argn,callno,rout2,sourcefile_caller) ;
 230                      /* RECURSION */
 231                     wrfvar ( v[6], rout, recursion_level+1 ) ;
 232                   } else if ( callno >= 2 ) {
 233                     more_calls = callno ;
 234                   }
 235                   callno++ ;
 236                 }
 237               }
 238               fclose( ROUT ) ;
 239               if ( more_calls > 1 && recursion_level == 0 ) {
 240                 printf("  there are %d more calls to %s from %s.  Try 'wrfvar %s %s all' to see all.\n", more_calls, rout2, rout, vname, rout2 ) ;
 241               }
 242             }
 243           }
 244           fclose( CALLERS ) ;
 245         } else if ( COMPARE2( t[3] , vname ) && COMPARE2( t[9] , "registry" ) ) {
 246           /* RECURSION */
 247           sprintf(tmp, "grid%%s", vname ) ;
 248           wrfvar ( vname, "registry", recursion_level+1 ) ;
 249           found_var = 1 ;
 250         }
 251       }
 252     }
 253   }
 254   if ( found_var == 0 ) {
 255     if ( contains_i1_declarations ) {
 256       /* take a look in the registry for i1 vars that might match */
 257       wrfvar ( vname, "registry_i1", recursion_level ) ;  /* recursion level does not increase here, since we're checking the registry */
 258     } else {
 259       printf("%s is not an argument to %s. May be local or use-associated.\n",vname,rout1 ) ;
 260       printf("%s has %d arguments\n",rout1,nargs_rout) ;
 261       fclose(ROUT) ;
 262       if (( ROUT = fopen( routfile , "r" )) == NULL ) return ;
 263       while ( fgets( inln2, INLINELEN, ROUT ) != NULL ) {
 264         remove_nl( inln2 ) ;
 265         /* find first non space */
 266         for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
 267         /* change multiple spaces to single space */
 268         for ( q = p, q1 = q , prev = *p ; *q ; q++ ) { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
 269         for ( i = 0 ; i < 11 ; i++ ) {
 270           strcpy( r[i] , "" ) ;
 271           get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; lower_case_str( r[i] ) ;
 272         }
 273         if ( COMPARE2( r[0] , "arg" ) ) {
 274           i = atoi(r[1]) + 1 ;
 275           printf("%3d. ",i) ;
 276           printf("%s of type %s intent %s\n",r[3],r[5],r[7]) ;
 277         }
 278       }
 279     fclose( ROUT ) ;
 280     }
 281   }
 282
 283 /* get a list of the routines this guy calls */
 284
 285   if ( recursion_level == 0 ) {
 286     first_time = 1 ;
 287     if (( BBB = fopen( routfile, "r" )) == NULL ) return ;
 288     while ( fgets( inln2, INLINELEN, BBB ) != NULL ) {
 289       remove_nl( inln2 ) ;
 290       /* find first non space */
 291       for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
 292       /* change multiple spaces to single space */
 293       for ( q = p, q1 = q , prev = *p ; *q ; q++ )
 294            { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
 295       for ( i = 0 ; i < 11 ; i++ ) {
 296         strcpy( t[i] , "" ) ;
 297         get_token_n( inln2, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ;
 298       }
 299       if        ( COMPARE2( t[0] , rout1 ) && COMPARE2( t[1] , "calls" ) ) {
 300         strcpy( hamuna , t[2] ) ;
 301       } else if ( COMPARE2( t[0] , "actarg" ) && COMPARE2( t[6] , vname ) ) {
 302         if ( first_time ) {
 303           printf("\n<h4>%s is an actual arg in calls to these routines from %s</h4>\n",vname,rout1) ;
 304           first_time = 0 ;
 305         }
 306         sprintf(fname,"%s/%s",DBDIR,hamuna) ;
 307         if (( ELEF = fopen ( fname , "r" )) == NULL ) continue ;
 308         while ( fgets( inln3, INLINELEN, ELEF ) != NULL ) {
 309           remove_nl( inln3 ) ;
 310           /* find first non space */
 311           for ( p = inln3 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
 312           /* change multiple spaces to single space */
 313           for ( q = p, q1 = q , prev = *p ; *q ; q++ )
 314              { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
 315           for ( i = 0 ; i < 11 ; i++ ) {
 316             strcpy( u[i] , "" ) ;
 317             get_token_n( inln3, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ;
 318           }
 319           if ( COMPARE2( u[0] , "arg" ) && COMPARE2( u[1] , t[1] ) ) {
 320             strcpy( darg , u[3] ) ;
 321             strcpy( dintent , u[7] ) ;
 322             break ;
 323           }
 324         }
 325         fclose( ELEF ) ;
 326         printf("  %s (argument %d ; matching dummy arg is %s with intent %s)\n",hamuna,atoi(t[1])+1,darg,dintent ) ;
 327       }
 328     }
 329     printf("\n") ;
 330     fclose(BBB) ;
 331   }
 332 }
 333
 334
 335
 336 #if 0
 337 #!/bin/perl
 338
 339 $dbdir = "tools/code_dbase" ;
 340
 341 if ( ! opendir( TOOLDIR, "tools") )  {
 342 print "\nMust be in top level WRF directory\n" ;
 343 exit ;
 344 }
 345 closedir TOOLDIR ;
 346
 347 if ( (scalar @ARGV  < 1 || scalar @ARGV > 3)  || (scalar @ARGV == 1 && @ARGV[0] ne "rebuild") )  {
 348 print "usage: wrfvar varname routinename \n" ;
 349 print "       wrfvar rebuild \n" ;
 350 exit ;
 351 }
 352
 353
 354 if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" )
 355 {
 356   print "Building code database ... please wait.\n" ;
 357   system( "cd tools/CodeBase ; make" ) ;
 358   $rc = system( "tools/build_codebase" ) ;
 359
 360   if ( ($rc >> 8) == 99 ) { exit ; }
 361   system( "ln -sf tools/wrfvar ." ) ;
 362   system( "ln -sf tools/subinfo ." ) ;
 363
 364   if ( $ARGV[0] eq "rebuild" ) { exit ; }
 365 }
 366
 367
 368 $vname = lc $ARGV[0] ;
 369 $vname1 = $vname ;
 370 $rout1 = lc $ARGV[1] ;
 371 $recursion_level = $ARGV[2] ;
 372 $rout = $rout1 ;
 373 #print $vname,"\n" ;
 374 #print $rout,"\n" ;
 375
 376 $spc = "`" ;
 377 $vv = $vname ;
 378 $vv =~ s/\(.*// ;
 379 #print $vv,"\n" ;
 380 if ( substr($vv,0,5)  eq "grid%" ) {
 381     open REGISTRY, "< Registry/Registry" or die "cannot open Registry/Registry" ;
 382     while ( <REGISTRY> ) {
 383
 384       $line = $_ ;
 385       $line =~ s/#.*// ;
 386       next if ( $line eq "" ) ;
 387       $line =~ s/[ \t][ \t]*/ /g ;
 388       $line = lc $line ;
 389       # fill in the blanks in quote delimited strings then remove
 390       # the quotes so we can split on white space
 391
 392       $inquote = 0 ;
 393       $newline = "" ;
 394       for ( $i = 0 ; $i < length($line) ; $i++ )
 395       {
 396         $ccc = substr($line,$i,1) ;
 397         if    ( ! $inquote && $ccc eq '"' ) { $inquote = 1 ; }
 398         elsif (   $inquote && $ccc eq '"' ) { $inquote = 0 ; }
 399         if ( $ccc eq " " && $inquote ) { $newline = $newline.$spc ; }
 400         else                           { $newline = $newline.$ccc ; }
 401       }
 402       $line = $newline ;
 403       $line =~ s/\"//g ;
 404
 405       @r = split ( ' ',$line ) ;
 406       if ( ($r[0] eq state ) ) {
 407         if (( substr($r[4],0,4) eq "dyn_" &&
 408               substr($r[4],4,length($r[4])-4)."_" eq substr($vv,5,length($r[4])-4)."_" &&
 409               substr($vv,5+length($r[4])-4+1,length($r[2]))) eq $r[2] ) {
 410
 411           $r[9] =~ s/`/ /g ;
 412           $r[9] = uc $r[9] ;
 413           $r[10] =~ s/`/ /g ;
 414           $r[10] = uc $r[10] ;
 415           print "**  Registry Definition: <class> $r[0] <type> $r[1] <varname> ", uc $r[2]," <decription> \"$r[9]\" <units> \"$r[10]\"\n"
 416         }
 417       }
 418     }
 419     close REGISTRY ;
 420     exit ;
 421 }
 422
 423 $routfile = $dbdir."/".$rout ;
 424 open ROUT, "< $routfile" or die "can not open $routfile" ;
 425
 426 $sourcefile = "" ;
 427 $found_var = 0 ;
 428 $nargs_rout = 0 ;
 429 while ( <ROUT> )
 430 {
 431   s/^  *// ;
 432   s/  */ /g ;
 433   @t = split ' ' ;
 434   if ( $t[0] eq "sourcefile" ) {
 435     $sourcefile = $t[1] ;
 436   } elsif ( $t[0] eq "arg" ) {
 437     $nargs_rout++ ;
 438     if ( $t[3] eq $vname && $t[9] ne "registry" ) {
 439       $argn = $t[1] ;
 440       print "  ",uc $vname," is dummy argument $argn of $rout ($sourcefile)\n"  ;
 441       $found_var = 1 ;
 442       close ROUT ;
 443       system( "sort -u $dbdir/calls > /tmp/wrfvar-sort ; /bin/mv /tmp/wrfvar-sort $dbdir/calls" ) ;
 444       open CALLERS, "< $dbdir/calls" ;
 445       $rout2 = $rout ;
 446       while ( <CALLERS> ) {
 447         @u = split ' ' ;
 448         if ( $u[2] eq $rout2 )
 449         {
 450           $rout = $u[0] ;
 451           $routfile = $dbdir."/".$rout ;
 452           open ROUT, "< $routfile" or die "can not open $routfile" ;
 453           $sourcefile_caller = "" ;
 454           $callno = 1 ;
 455           while ( <ROUT> ) {
 456             @v = split ' ' ;
 457             if ( $v[0] eq "sourcefile" ) {
 458               $sourcefile_caller = $v[1] ;
 459             } elsif ( $v[0] eq 'actarg' && $v[4] eq $rout2 && $v[1] eq $argn ) {
 460               print ucfirst $rout2," call $callno by $rout ($sourcefile_caller) with actual argument $argn: ",uc $v[6],"\n" ;
 461               $callno++ ;
 462               $vname = $v[6] ;
 463               ############## RECURSION ##############
 464               @sysargs = ( "tools/wrfvar" , $v[6], $rout, $recursion_level+1 )  ;
 465               system( @sysargs ) ;
 466             }
 467           }
 468           close ( ROUT ) ;
 469         }
 470       }
 471       close ( CALLERS ) ;
 472     } elsif ( $t[3] eq $vname && $t[9] eq "registry" ) {
 473       @sysargs = ( "tools/wrfvar" , "grid%".$vname, "registry", $recursion_level+1 ) ;
 474       ############## RECURSION ##############
 475       system( @sysargs ) ;
 476       $found_var = 1 ;
 477     }
 478   }
 479 }
 480
 481 if ( $found_var == 0 ) {
 482   print uc $vname , " is not an argument to ${rout1}.  May be local or use-associated.\n" ;
 483   print ucfirst $rout1," has $nargs_rout arguments.\n" ;
 484   close ROUT ;
 485   open ROUT, "< $routfile" or die "can not open $routfile" ;
 486   while ( <ROUT> )
 487   {
 488     s/^  *// ;
 489     s/  */ /g ;
 490     @t = split ' ' ;
 491     if ( $t[0] eq "arg" ) {
 492       $i = $t[1] + 1 ;
 493       printf("%3d. ",$i) ;
 494       print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ;
 495     }
 496   }
 497   close ROUT ;
 498 }
 499
 500 # get a list of the routines this guy calls
 501
 502 if ( $recursion_level == 0 ) {
 503 $first_time = 1 ;
 504 open BBB, "< $dbdir/$rout1" or die " cannot open $dbdir/$rout1" ;
 505 while ( <BBB> ) {
 506   @t = split ' ' ;
 507   if      ( $t[0] eq "$rout1" && $t[1] eq calls ) {
 508      $hamuna = $t[2] ;
 509   } elsif ( $t[0] eq "actarg" && $t[6] eq $vname1 ) {
 510      if ( $first_time == 1 ) {
 511        print "\n",uc $vname1," is an actual argument in calls to these routines from ",uc $rout1," :\n" ;
 512        $first_time = 0 ;
 513      }
 514      open ELEF,"< $dbdir/$hamuna" or die "cannot open $dbdir/$hamuna"  ;
 515      while ( <ELEF> ) {
 516        @u = split ' ' ;
 517        if ( $u[0] eq arg && $u[1] eq $t[1] ) {
 518           $darg = $u[3] ;
 519           $dintent = $u[7] ;
 520        }
 521      }
 522      close ELEF ;
 523      print "  ", $hamuna," (argument ",$t[1]+1," ; matching dummy arg is ",uc $darg," with intent ",uc $dintent,") \n" ;
 524   }
 525 }
 526 print "\n" ;
 527 close BBB ;
 528 }
 529 exit ;
 530
 531 #endif
 532