source: lmdz_wrf/WRFV3/tools/subinfo @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

  • Property svn:executable set to *
File size: 6.0 KB
Line 
1#!/bin/perl
2
3$dbdir = "tools/code_dbase" ;
4
5if ( ! opendir( TOOLDIR, "tools") )  {
6  print "\nMust be in top level WRF directory\n" ;
7  exit ;
8}
9closedir TOOLDIR ;
10
11$gofast=0 ;
12if ( ( scalar @ARGV  < 1 ) || ( scalar @ARGV > 2 ) )  {
13  print "usage: subinfo routinename \n" ;
14  print "       subinfo rebuild \n" ;
15  exit ;
16}
17if ( ( scalar @ARGV == 2 ) ) { $gofast = 1 ; }  # don't bother with links for argument lists
18
19if ( ! 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}
28close 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
38if ( ! ( 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
55while ( <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}
68close ROUT ;
69
70print "<html>\n" ;
71print "<title> ",ucfirst $subprog," : ",uc $rout1," </title>\n" ;
72print "<body>\n" ;
73print "<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 ) ;
78if ( "$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 ;
89print "<b> Defined in: </b> <a href=\"../../../wrfbrowser/html_code/${refer_to}.html#$rout1_uc\"> $refer_to </a> <p> <p>\n" ;
90
91if ( 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
101print "<b> Called by : </b> <p> <p>\n" ;
102print "<pre>\n" ;
103@sysargs = ( "tools/subinfo_calls", 0, "$rout" ) ;
104open BBB , "tools/subinfo_calls 0 $rout | " ;
105while ( <BBB> ) { print ; }
106close BBB ;
107print "</pre>\n" ;
108
109$first=1 ;
110$use_entry = 0 ;
111open ROUT, "< $routfile" or die "can not open $routfile" ;
112while ( <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}
130if ( $use_entry == 1 ) { print "</pre>\n" ; }
131close ROUT ;
132
133print "<b> Arguments: </b> <p> <p>\n" ;
134print "<pre>\n" ;
135
136open ROUT, "< $routfile" or die "can not open $routfile" ;
137$i = 1 ;
138while ( <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}
157close ROUT ;
158print "</pre>\n" ;
159
160$first = 1 ;
161open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ;
162while ( <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}
192if ( $first == 2 ) {
193  print "</table>\n" ;
194}
195
196
197
198print "</html>\n" ;
199
200exit
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
Note: See TracBrowser for help on using the repository browser.