source: lmdz_wrf/trunk/WRFV3/tools/CodeBase/wrfvar.c @ 1577

Last change on this file since 1577 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: 18.2 KB
Line 
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
17int sw_all  = 0 ;
18
19
20main( 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
57wrfvar ( 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 ) ;
134fprintf(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
341if ( ! opendir( TOOLDIR, "tools") )  {
342print "\nMust be in top level WRF directory\n" ;
343exit ;
344}
345closedir TOOLDIR ;
346
347if ( (scalar @ARGV  < 1 || scalar @ARGV > 3)  || (scalar @ARGV == 1 && @ARGV[0] ne "rebuild") )  {
348print "usage: wrfvar varname routinename \n" ;
349print "       wrfvar rebuild \n" ;
350exit ;
351}
352
353
354if ( ! 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" ;
380if ( 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 ;
424open ROUT, "< $routfile" or die "can not open $routfile" ;
425
426$sourcefile = "" ;
427$found_var = 0 ;
428$nargs_rout = 0 ;
429while ( <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
481if ( $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
502if ( $recursion_level == 0 ) {
503$first_time = 1 ;
504open BBB, "< $dbdir/$rout1" or die " cannot open $dbdir/$rout1" ;
505while ( <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}
526print "\n" ;
527close BBB ;
528}
529exit ;
530
531#endif
532
Note: See TracBrowser for help on using the repository browser.