#!/bin/perl $dbdir = "tools/code_dbase" ; if ( ! opendir( TOOLDIR, "tools") ) { print "\nMust be in top level WRF directory\n" ; exit ; } closedir TOOLDIR ; $gofast=0 ; if ( ( scalar @ARGV < 1 ) || ( scalar @ARGV > 2 ) ) { print "usage: subinfo routinename \n" ; print " subinfo rebuild \n" ; exit ; } if ( ( scalar @ARGV == 2 ) ) { $gofast = 1 ; } # don't bother with links for argument lists if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" ) { print "Building code database ... please wait.\n" ; system( "cd tools/CodeBase ; make" ) ; open P, "tools/build_codebase |&" ; while (

) { print ; } close P ; system( "ln -sf tools/subinfo ." ) ; system( "ln -sf tools/wrfvar ." ) ; if ( $ARGV[0] eq "rebuild" ) { exit ; } } close XXX ; $rout1 = lc $ARGV[0] ; $rout = $rout1 ; #print $vname,"\n" ; #print $rout,"\n" ; $routfile = $dbdir."/".$rout ; if ( ! ( open( ROUT, "< $routfile" )) ) { print "$rout is not a known subprogram. \n" ; open P, "/bin/ls -1 $dbdir/\*$rout\* | " ; print "Perhaps you mean:\n" ; while (

) { s/.*\/// ; if ( substr( $_, 0, 3 ) eq "lm_" ) { next ; } if ( $_ =~ "not found" ) { break ; } print " $_" ; } exit ; } #open ROUT, "< $routfile" or { print "$rout is not a known subprogram. Perhaps you mean:\n" ; } # system( "/bin/ls -1 $dbdir/\*$rout\*" ) ; # die ; while ( ) { @t = split ' ' ; if ( $t[0] eq sourcefile ) { $sourcefile = $t[1] ; } if ( $t[0] eq subprogram ) { if ( $t[1] eq "function" ) { $subprog = $t[2]." ".$t[1] ; } else { $subprog = $t[1] ; } } } close ROUT ; print "\n" ; print " ",ucfirst $subprog," : ",uc $rout1," \n" ; print "\n" ; print "

",ucfirst $subprog," : ",uc $rout1,"

\n" ; # see if there is a 'big-f' file... $refer_to = $sourcefile ; $tail = substr( $sourcefile, length( $sourcefile ) - 2 ) ; if ( "$tail" eq ".f" ) { $refer_to = substr( $sourcefile, 0, length( $sourcefile ) - 2 ) . ".F" ; if ( ! ( open( EXISTNCE, "< $refer_to" )) ) { $refer_to = $sourcefile ; } else { close EXISTNCE ; } } #print " Defined in: $refer_to

\n" ; # have it point to the wrf code browser instead $rout1_uc = uc $rout1 ; print " Defined in: $refer_to

\n" ; if ( open (DESC, "< ${routfile}_descrip" ) ) { print " Description:

\n" ; while ( ) { print ; } print "

\n" ; close DESC ; } print " Called by :

\n" ; print "

\n" ;
@sysargs = ( "tools/subinfo_calls", 0, "$rout" ) ;
open BBB , "tools/subinfo_calls 0 $rout | " ;
while (  ) { print ; }
close BBB ;
print "
\n" ; $first=1 ; $use_entry = 0 ; open ROUT, "< $routfile" or die "can not open $routfile" ; while ( ) { @t = split ' ' ; if ( $t[0] eq "use" ) { if ( $first == 1 ) { print " Uses:

\n

\n" ;
      $use_entry = 1 ;
      $first = 0 ;
    }
    printf("  %-30s    ",uc $t[1] ) ;
    open P,"/bin/ls */*.F | grep -w $t[1] |" ;
    while( 
 ) {
      chop ;
#      printf("(%s)\n", $_, $_ ) ;
      printf("(%s)\n", $_, uc $t[1], $_ ) ;
    }
    close P ;
  }
}
if ( $use_entry == 1 ) { print "
\n" ; } close ROUT ; print " Arguments:

\n" ; print "

\n" ;

open ROUT, "< $routfile" or die "can not open $routfile" ;
$i = 1 ;
while (  ) {
  @t = split ' ' ; 
  if ( $t[0] eq arg && $t[9] eq dummyarg ) {
    printf("%3d.",$i++) ;
    $vfile = "$dbdir/vv_" . $rout1 . "_" . $t[3] . ".html" ;
    if ( $gofast == 0 ) {
      system ( "echo '
' > $vfile ; tools/wrfvar $t[3] $rout1 >> $vfile ; echo '
' >> $vfile"  ) ;
    }
    $intent = "INTENT( ".uc $t[7]." )" ;
    if ( $t[11] ne "" ) {
       $dims = "DIMENSION( ".$t[11]." )" ;
       $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
       printf(" %-12s :: %-8s, %-16s, %s\n",$vfile,$t[3], uc $t[5], $intent, $dims ) ;
    } else {
       $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
       printf(" %-12s :: %-8s, %-16s\n",$vfile,$t[3], uc $t[5], $intent ) ;
    }
  }
}
close ROUT ;
print "
\n" ; $first = 1 ; open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ; while ( ) { @t = split ' ' ; 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) && (substr($t[2],0,4) ne "get_") ) { if ( $first == 1 ) { print "",uc $rout," calls :

\n" ; # print "

\n" ;
       print "\n" ;
       $first = 2 ;
     }
     open C ,"< $dbdir/$t[2]" ;
     while (  ) {
       @u = split ' ' ;
       if ( $u[0] eq sourcefile ) { $sf = $u[1] ; break ; }
     }
     close C ;
     # see if there is a 'big-f' file...
     $refer_to = $sf ;
     $tail =  substr( $sf, length( $sf ) - 2 ) ;
     if ( "$tail" eq ".f" ) {
        $refer_to = substr( $sf, 0, length( $sf ) - 2 ) . ".F" ;
        if ( ! ( open( EXISTNCE, "< $refer_to" )) ) {
           $refer_to = $sf ;
        }
        else { close EXISTNCE ; }
     }
     $sf = $refer_to ;
     printf("\n",$t[2], $t[2],$sf,$sf) ;
   }
}
if ( $first == 2 ) {
  print "
%30s(%s)
\n" ;
}



print "\n" ;

exit

#if ( $found_var == 0 ) {
#  print uc $vname , "is not an argument to ${rout1}.  May be local or use-associated.\n" ;
#  print ucfirst $rout1," has $nargs_rout arguments.\n" ;
#  close ROUT ;
#  open ROUT, "< $routfile" or die "can not open $routfile" ;
#  while (  )
#  {
#    s/^  *// ;
#    s/  */ /g ;
#    @t = split ' ' ;
#    if ( $t[0] eq "arg" ) {
#      $i = $t[1] + 1 ;
#      printf("%3d. ",$i) ;
#      print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ;
#    }
#  }
#  close ROUT ;
#}