namelist.pm

CCSM Research Tools: Community Atmosphere Model (CAM)

#
#	namelist.pm			Erik Kluzek
#
#	Perl module to deal with FORTRAN namelists.
#
#------------------------------------------------------------------------
#
#	Description of methods:
#
#	new ----------------------- Constructor
#	change -------------------- Interactively change values in the namelist
#	checkstring --------------- Check that a string namelist item is handled correctly.
#	print --------------------- Print namelist to screen.
#	Write --------------------- Write the namelist out.
#	convert_case -------------- Convert the keys to lowercase.
#	parse --------------------- Parse a namelist file into a Perl associative array.
#
#	$Id: namelist.pm,v 1.1.6.1 2002/05/13 17:21:27 eaton Exp $
#
use strict;
#use diagnostics;
use Cwd;

package namelist;

# Some data to make global within this package, but local to inside it
#
# Perl expression to match a fortran variable
#
$namelist::varmatch = "[A-Za-z_]+[A-Za-z0-9_%()]*";    # % for derived types, () for arrays
#
# Perl pattern to match the value for a fortran constant
#
# Match for logical data
$namelist::vallogical = "\\.[Tt][Rr][Uu][Ee]\\.|\\.[Ff][Aa][Ll][Ss][Ee]\\.";
# Match for integer data
$namelist::valint = "[+-]?[0-9]+";
# Match for real data
# "_" are for f90 precision specification
$namelist::valreal = "$namelist::valint\\.?[0-9]*[Ee]?[0-9+-]*_?[0-9a-z_]*";
# Match for string data
# One problem with below is strings that have \" or \' in them
$namelist::valstring = '\'[^\']+\'|"[^"]+"';
# Match for complex data
$namelist::valcomplex = "\\($namelist::valreal,$namelist::valreal\\)";
# Match for all valid data-types: integer, real, complex, logical, or string data
$namelist::valmatch = 
"$namelist::vallogical|$namelist::valstring|$namelist::valreal|$namelist::valint|$namelist::valcomplex";
# Same as above when a match isn't required
$namelist::nrvalmatch = $namelist::valmatch. "||";

#
# This script takes the %main::CCMEXP associative array and stores the keys in
# Lower case to the following lowercase copies. It uses the values passed in
# and sets needed default values based on configuration variables. Then it writes out
# a namelist according to the corresponding resultant associative array.
#

sub new {
#
# Constructor: usage: my $nl = namelist->new( "CCMEXP", "nl.initial", %main::CCMEXP );
#
  my $class = shift;
  my $name  = shift;
  my $file  = shift;
  my $NLref = shift;
  my $printlev = shift;

  my $self  = {};
  if ( ! defined($name) ) {
    die "ERROR:: name not given to namelist constructor\n";
  }
  if ( ! defined($file) ) {
    die "ERROR:: filename not given to namelist constructor\n";
  }
  if ( ! defined($NLref) || $NLref !~ /HASH/ ) {
    die "ERROR:: reference to namelist associative array not given to namelist constructor\n";
  }
  $self->{'FILENAME'} = $file;                    # Filename of output namelist
  $self->{'NLREF'}    = $NLref;                   # Reference to namelist
  $self->{'NAME'}     = $name;                    # the name of the namelist
  $self->{'printlev'} = $printlev;
  $self->{'VAR'}      = undef;                    # Variable name when parsing
  $self->{'VALUE'}    = undef;                    # Variable value when parsing
  bless( $self, $class );
  return( $self );
}

#============================================================================

sub change {
#
# Make changes to the namelist
#
  my $self = shift;

  my $ref = $self->{'NLREF'};
  my $name = $self->{'NAME'};
  print "Here is the $name namelist:\n";
  $self->print;
  print "Do you want to add or change any settings? (y/n):";
  $_ = <>; 
  if ( /[yY][Ee]*[sS]*/ ) {
    print "Enter changes as: key = value (return to finish)\n";
    print "(Be sure and put \' around string values)\n";
    my $match = "^\\s*($namelist::varmatch)\\s*=\\s*($namelist::valmatch";
    $match = $match . ")[\\s,]*(.*?\$)";
    while( defined($_ = <> ) && (/./) ) {
      if ( /$match/ ) {
        $$ref{$1} = $2;
      } else {
        print "Warning:: bad input: enter as: key = value :: key and value should conform to f90 rules\n";
      }
    }
    print "Ok, here is the new $name namelist:\n";
    $self->print;
  }
}

#============================================================================

sub checkstring {
#
# Check that a string namelist item is handled correctly
#
  my $self = shift;
  my $item = shift;

  my $EXPNLref = $self->{'NLREF'};
  my %EXPNL = %$EXPNLref;
  my $name = $EXPNL{$item};
  if ( $name !~ /\'(.+)\'/ ) {
    die "$item needs \' around the value";
  }
}

#============================================================================

sub split_namelist_value {
#
# Return a namelist value split up if longer than 70 characters
#
  my $self = shift;
  my $value = shift;

  if ( length($value) > 70 ) {
    my $originalvalue = $value;
    my $expect = "value";
    my @list;
    while ( $value =~ /./ ) { 
      $self->parse_next( \$value, \$expect ) ;
      push( @list, $self->{VALUE} );
      $expect = "value";
    }
    my $numberonline = ( 70*($#list+1) ) / length($originalvalue);
    my $i = 0;
    $value = shift @list;
    foreach my $item ( @list ) {
      $value = $value . ", $item";
      if ( ++$i >= $numberonline ) {
        $value = $value . "\n         ";
        $i = 0;
      }
    }
  }
  return( $value );
}

#============================================================================

sub print {
#
# Print the namelist out
#
  my $self = shift;

  my $ref = $self->{'NLREF'};
  my $key;
  my %namelist = %$ref;
  foreach $key ( sort( keys(%namelist) ) ) {
    if ( defined($namelist{$key}) ) {
      my $value = $self->split_namelist_value( $namelist{$key} );
      print " $key = $value\n";
    }
  }
}

#============================================================================

sub Write {
#
# Write out the namelist based on values set in the associative
# arrays
#
  my $self = shift;
  my $append = shift;

  my $ref = $self->{'NLREF'};
  my %namelist = %$ref;
  my $name = $self->{'NAME'};
  my $file = $self->{'FILENAME'};
  if ( defined($append) && $append =~ /Append/i ) {
    open( OUT, ">>$file" ) || die "Can not open namelist file: $file";
  } else {
    if ( -f $file ) { unlink( $file ); }
    open( OUT, ">$file" ) || die "Can not open namelist file: $file";
  }
  print OUT "&$name\n";
  my $key;
  foreach $key ( sort( keys(%namelist) ) ) {
    if ( defined($namelist{$key}) ) {
      my $value = $self->split_namelist_value( $namelist{$key} );
      print OUT " $key\t\t= $value\n";
    }
  }
  print OUT "/\n";
  close( OUT );
}

#============================================================================

sub convert_case {
#
# Convert the case of the keys in the main associative arrays to lowercase.
# Also terminate if there are two keys with the same name but different case.
#
  my $self = shift;

  my $class = ref($self);
  my $nm = "$class\:\:convert_case";

  my $ref = $self->{'NLREF'};
  my $key;
  foreach $key ( keys(%$ref) ) {
    if ( defined($$ref{$key}) ) {
      my $lckey = $key;
      $lckey =~ tr/[A-Z]/[a-z]/;
      my $value = $$ref{$key};
      if ( $key ne $lckey && defined($$ref{$lckey}) ) {
        print "$lckey already defined\n";
        die "$nm: Fix your namelist so that two definitions of $lckey do not exist";
      }
      $$ref{$key}   = undef;
      $$ref{$lckey} = $value;
    }
  }
}

#============================================================================

sub parse {
#
# Parse the namelist from a file
#
  my $self = shift;
  my $filename = shift;

  my $class = ref($self);
  my $nm = "$class\:\:parse";

  my $name = $self->{'NAME'};
  if ( ! defined( $filename ) ) {
    die "ERROR($nm): Namelist filename not passed to parse method\n";
  }
  open( NAMELIST, "<$filename") || die "ERROR($nm): Can not open namelist: $filename\n";
  print "Parse namelist: $name from file: $filename\n" if ($self->{'printlev'}>2);
  #
  # Find the designator for this namelist
  #
  my $found = undef;
  my $line;
  while ( defined($_ = <NAMELIST>) && (/./)  ) {
    if ( /[\$\&]$name(.*?)$/i ) {
      $line = $1;
      $found = 1;
      last;
    }
  }
  if ( ! defined($found) ) {
    print "WARNING($nm): did not find the correct namelist: $name in file: $filename\n" if ($self->{'printlev'}>2);
    return;
  }
  my $expect = "variable";
  goto LINE;
  #
  # Loop over each line in the namelist
  #
NEXT: while ( defined($line = <NAMELIST>) && (/./)  ) {
    #
    # Loop over each item in each line
    #
LINE: while ( defined($line) && ($line =~ /./) ) {
      $self->parse_next( \$line, \$expect );
      if ( $expect eq "end" ) {
        last LINE;
      } 
    }
    if ( $expect eq "end" ) { last; }
  }
  close( NAMELIST );
  $self->convert_case;
}

#============================================================================

sub setkeypair {
#
# Set the keyword pair
#
  my $self = shift;

  if ( defined( $self->{'VAR'} ) ) {
    my $ref = $self->{'NLREF'};
    my $var = $self->{'VAR'};
    my $val = $self->{'VALUE'};
    if ( ! defined($val) ) {
      die "ERROR:: Value not defined for variable: $var\n";
    }
    $$ref{$var} = $val;
    $self->{'VAR'}   = undef;
    $self->{'VALUE'} = undef;
  }
}

#============================================================================

sub parse_next {
#
# Parse the next item in the line
# parse_next( \$line, \$expect )
#
  my $self = shift;
  my $line = shift;
  my $expect = shift;

  my $class = ref($self);
  my $nm = "$class\:\:parse_next";

  $_ = $$line;
  # Blank line, return and continue
  if ( /^\s*$/ ) {
    $$line = undef;
    return;
  }
  #
  # Switch based on what type of item you expect
  #
  SWITCH: {
    # Expect a variable
    (($$expect eq "variable") || ($$expect eq "varorvalue")) && do {
       # End-designator (F90 form "/" and non-standard F77 forms (&end) )
       if ( /^\s*\// || /^\s*[\$\&]end/i ) {
         $$line = undef;
         $self->setkeypair;
         $$expect = "end";
         return;
       }
       # variable
       if ( /^\s*,?\s*($namelist::varmatch)(.*?)$/ ) {
         $$line = $2;
         $$expect = "=";
         $self->setkeypair;
         $self->{'VAR'} = $1;
       } elsif ( $$expect ne "varorvalue" ) {
         die "ERROR($nm): expect a variable instead got: $_\n";
       # value
       } elsif ( $$expect eq "varorvalue"
         &&   /^\s*([\s,]*)($namelist::nrvalmatch)([\s,]*)(.*?)$/ ) {
         $$line = $4;
         $$expect = "varorvalue";
         $self->{'VALUE'} = $self->{'VALUE'} . ",$2";
         # Comments, only can follow a value
         if ( $$line =~ /^([\s,])*![^!]*$/ ) {
           $$line = undef;
         }
       } else {
         die "ERROR($nm): expect a value or variable instead got: $_\n";
       }
       last SWITCH;
    };
    # Expect a "="
    ($$expect eq "=") && do {
       if ( /^\s*=(.*?)$/ ) {
         $$line = $1;
         $$expect = "value";
       } else {
         die "ERROR($nm): expect a = instead got: $_\n";
       }
       last SWITCH;
    };
    # Expect a value
    ($$expect eq "value") && do {
       # value
       if ( /^\s*(${namelist::valmatch})([\s,]*)(.*?)$/ ) {
         $$line = $3;
         $$expect = "varorvalue";
         $self->{'VALUE'} = "$1";
         # FORTRAN only allows comments after values
         if ( $$line =~ /^\s*![^!]*$/ ) {
           $$line = undef;
         }
       } else {
         die "ERROR($nm): expect a value instead got: $_\n";
       }
       last SWITCH;
    };
    # default
    die "ERROR($nm): Bad value to expect: $$expect\n";
  }
}

#============================================================================

# Quoting should be done in the Write method rather
# than when string values are added to the namelist hash.
# But the namelist variable type isn't known in the Write method.
sub quote_string {
    my $str = shift;
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    unless ($str =~ /^['"]/) {        #"'
        $str = "\'$str\'";
    }
    return $str;
}

#============================================================================

1   # to make use or require happy