tools/subinfo

   1 #!/bin/perl
   2
   3 $dbdir = "tools/code_dbase" ;
   4
   5 if ( ! opendir( TOOLDIR, "tools") )  {
   6   print "\nMust be in top level WRF directory\n" ;
   7   exit ;
   8 }
   9 closedir TOOLDIR ;
  10
  11 $gofast=0 ;
  12 if ( ( scalar @ARGV  < 1 ) || ( scalar @ARGV > 2 ) )  {
  13   print "usage: subinfo routinename \n" ;
  14   print "       subinfo rebuild \n" ;
  15   exit ;
  16 }
  17 if ( ( scalar @ARGV == 2 ) ) { $gofast = 1 ; }  # don't bother with links for argument lists
  18
  19 if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" )
  20 {
  21   print "Building code database ... please wait.\n" ;
  22   system( "cd tools/CodeBase ; make" ) ;
  23   open P, "tools/build_codebase |&" ; while (<P>) { print ; } close P ;
  24   system( "ln -sf tools/subinfo ." ) ;
  25   system( "ln -sf tools/wrfvar ." ) ;
  26   if ( $ARGV[0] eq "rebuild" ) { exit ; }
  27 }
  28 close XXX ;
  29
  30
  31 $rout1 = lc $ARGV[0] ;
  32 $rout = $rout1 ;
  33 #print $vname,"\n" ;
  34 #print $rout,"\n" ;
  35
  36 $routfile = $dbdir."/".$rout ;
  37
  38 if ( ! ( open( ROUT, "< $routfile" )) ) {
  39   print "$rout is not a known subprogram. \n" ;
  40   open P, "/bin/ls -1 $dbdir/\*$rout\* | " ;
  41   print "Perhaps you mean:\n" ;
  42   while (<P>) {
  43     s/.*\/// ;
  44     if ( substr( $_, 0, 3 ) eq "lm_" ) { next ; }
  45     if ( $_ =~ "not found" ) { break ; }
  46     print "  $_" ;
  47   }
  48   exit ;
  49 }
  50
  51 #open ROUT, "< $routfile" or { print "$rout is not a known subprogram. Perhaps you mean:\n" ; }
  52 #  system( "/bin/ls -1 $dbdir/\*$rout\*" ) ;
  53 #  die ;
  54
  55 while ( <ROUT> ) {
  56   @t = split ' ' ;
  57   if ( $t[0] eq sourcefile ) {
  58     $sourcefile = $t[1] ;
  59   }
  60   if ( $t[0] eq subprogram ) {
  61     if ( $t[1] eq "function" ) {
  62       $subprog = $t[2]." ".$t[1] ;
  63     } else {
  64       $subprog = $t[1] ;
  65     }
  66   }
  67 }
  68 close ROUT ;
  69
  70 print "<html>\n" ;
  71 print "<title> ",ucfirst $subprog," : ",uc $rout1," </title>\n" ;
  72 print "<body>\n" ;
  73 print "<h1> ",ucfirst $subprog," : ",uc $rout1," </h1> \n" ;
  74
  75 # see if there is a 'big-f' file...
  76 $refer_to = $sourcefile ;
  77 $tail =  substr( $sourcefile, length( $sourcefile ) - 2 ) ;
  78 if ( "$tail" eq ".f" ) {
  79    $refer_to = substr( $sourcefile, 0, length( $sourcefile ) - 2 ) . ".F" ;
  80    if ( ! ( open( EXISTNCE, "< $refer_to" )) ) {
  81       $refer_to = $sourcefile ;
  82    }
  83    else { close EXISTNCE ; }
  84 }
  85
  86 #print "<b> Defined in: </b> <a href=\"../../$refer_to\"> $refer_to </a> <p> <p>\n" ;
  87 # have it point to the wrf code browser instead
  88 $rout1_uc = uc $rout1 ;
  89 print "<b> Defined in: </b> <a href=\"../../../wrfbrowser/html_code/${refer_to}.html#$rout1_uc\"> $refer_to </a> <p> <p>\n" ;
  90
  91 if ( open (DESC, "< ${routfile}_descrip" ) ) {
  92   print "<b> Description: </b><p>\n" ;
  93   while ( <DESC> ) {
  94     print ;
  95   }
  96   print "<p>\n" ;
  97   close DESC ;
  98 }
  99
 100
 101 print "<b> Called by : </b> <p> <p>\n" ;
 102 print "<pre>\n" ;
 103 @sysargs = ( "tools/subinfo_calls", 0, "$rout" ) ;
 104 open BBB , "tools/subinfo_calls 0 $rout | " ;
 105 while ( <BBB> ) { print ; }
 106 close BBB ;
 107 print "</pre>\n" ;
 108
 109 $first=1 ;
 110 $use_entry = 0 ;
 111 open ROUT, "< $routfile" or die "can not open $routfile" ;
 112 while ( <ROUT> ) {
 113   @t = split ' ' ;
 114   if ( $t[0] eq "use" ) {
 115     if ( $first == 1 ) {
 116       print "<b> Uses: </b> <p> <p>\n<pre>\n" ;
 117       $use_entry = 1 ;
 118       $first = 0 ;
 119     }
 120     printf("  %-30s    ",uc $t[1] ) ;
 121     open P,"/bin/ls */*.F | grep -w $t[1] |" ;
 122     while( <P> ) {
 123       chop ;
 124 #      printf("(<a href=\"../../%s\">%s</a>)\n", $_, $_ ) ;
 125       printf("(<a href=\"../../../wrfbrowser/html_code/%s.html#%s\">%s</a>)\n", $_, uc $t[1], $_ ) ;
 126     }
 127     close P ;
 128   }
 129 }
 130 if ( $use_entry == 1 ) { print "</pre>\n" ; }
 131 close ROUT ;
 132
 133 print "<b> Arguments: </b> <p> <p>\n" ;
 134 print "<pre>\n" ;
 135
 136 open ROUT, "< $routfile" or die "can not open $routfile" ;
 137 $i = 1 ;
 138 while ( <ROUT> ) {
 139   @t = split ' ' ;
 140   if ( $t[0] eq arg && $t[9] eq dummyarg ) {
 141     printf("%3d.",$i++) ;
 142     $vfile = "$dbdir/vv_" . $rout1 . "_" . $t[3] . ".html" ;
 143     if ( $gofast == 0 ) {
 144       system ( "echo '<html><pre>' > $vfile ; tools/wrfvar $t[3] $rout1 >> $vfile ; echo '</pre></html>' >> $vfile"  ) ;
 145     }
 146     $intent = "INTENT( ".uc $t[7]." )" ;
 147     if ( $t[11] ne "" ) {
 148        $dims = "DIMENSION( ".$t[11]." )" ;
 149        $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
 150        printf(" <a href=\"%s\">%-12s</a> :: %-8s, %-16s, %s\n",$vfile,$t[3], uc $t[5], $intent, $dims ) ;
 151     } else {
 152        $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
 153        printf(" <a href=\"%s\">%-12s</a> :: %-8s, %-16s\n",$vfile,$t[3], uc $t[5], $intent ) ;
 154     }
 155   }
 156 }
 157 close ROUT ;
 158 print "</pre>\n" ;
 159
 160 $first = 1 ;
 161 open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ;
 162 while ( <CALLEES> ) {
 163    @t = split ' ' ;
 164    if ( $t[0] eq lc $rout && $t[1] eq calls && ! ($t[2] =~ add_msg) && !($t[2] =~ reset_msgs) && !($t[2] =~ stencil) && !($t[2] =~ wrf_debug)
 165         && (substr($t[2],0,4) ne "get_") )  {
 166      if ( $first == 1 ) {
 167        print "<b>",uc $rout," calls : </b> <p> <p>\n" ;
 168 #       print "<pre>\n" ;
 169        print "<table>\n" ;
 170        $first = 2 ;
 171      }
 172      open C ,"< $dbdir/$t[2]" ;
 173      while ( <C> ) {
 174        @u = split ' ' ;
 175        if ( $u[0] eq sourcefile ) { $sf = $u[1] ; break ; }
 176      }
 177      close C ;
 178      # see if there is a 'big-f' file...
 179      $refer_to = $sf ;
 180      $tail =  substr( $sf, length( $sf ) - 2 ) ;
 181      if ( "$tail" eq ".f" ) {
 182         $refer_to = substr( $sf, 0, length( $sf ) - 2 ) . ".F" ;
 183         if ( ! ( open( EXISTNCE, "< $refer_to" )) ) {
 184            $refer_to = $sf ;
 185         }
 186         else { close EXISTNCE ; }
 187      }
 188      $sf = $refer_to ;
 189      printf("<tr><td><a href=\"%s\.html\">%30s</a></td><td>(<a href=\"../../%s\">%s</a>)</td></tr>\n",$t[2], $t[2],$sf,$sf) ;
 190    }
 191 }
 192 if ( $first == 2 ) {
 193   print "</table>\n" ;
 194 }
 195
 196
 197
 198 print "</html>\n" ;
 199
 200 exit
 201
 202 #if ( $found_var == 0 ) {
 203 #  print uc $vname , "is not an argument to ${rout1}.  May be local or use-associated.\n" ;
 204 #  print ucfirst $rout1," has $nargs_rout arguments.\n" ;
 205 #  close ROUT ;
 206 #  open ROUT, "< $routfile" or die "can not open $routfile" ;
 207 #  while ( <ROUT> )
 208 #  {
 209 #    s/^  *// ;
 210 #    s/  */ /g ;
 211 #    @t = split ' ' ;
 212 #    if ( $t[0] eq "arg" ) {
 213 #      $i = $t[1] + 1 ;
 214 #      printf("%3d. ",$i) ;
 215 #      print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ;
 216 #    }
 217 #  }
 218 #  close ROUT ;
 219 #}
 220
 221
 222
 223