#!/usr/bin/perl -w ######################################################################## # Replace update directives with cpp directives # Update directives found in an "offical" deck (a file with .dk or .cdk # suffix) will be replaced with cpp directives. The only update directives # that are allowed in source files are COMDECK, DECK, CALL, IF and ENDIF. # These will be replaced as follows # %COMDECK and %DECK replaced by a comment line # %CALL replaced by #include # %IF replaced by one of #ifdef, #ifndef or #if # %ENDIF replaced by #endif # # In addition, blocks of lines that begin with one of the strings $COM$, # $CSP$, $CSL$ or $CSN$ will be replaced by preprocessor conditional # blocks. This is done under control of the command line option # --[no]tracer_cond (on by default). Note that line numbers will change # when this option is in force. # # A list of preprocessor tokens used by the output file will be placed # in a file when invoking the command line option --ppdefs=fname. # These tokens will be defined or not based on the gcm version # together with other assumtions. It is up to the user to verify # that these values are correct and change them if they are not. # # Larry Solheim Jul 19,2006 ######################################################################## require 5; use File::Basename; use Getopt::Long; use Cwd qw(cwd abs_path); use Text::Tabs; # Declare global variables use vars qw($Runame $new_suffix $out_suffix $choose_suffix $cccmode $remove_deck_cards $tracer_cond_blocks $param_replace_with_token $param_replace_with_value %defs %trac_defs @dir_list %param %defs_in $verbose $with_mpi $with_coupled %parmsub $modver ); use vars qw( $cppdefs_file $sizes_file $stamp ); # Define a local variable to indicate the root dir of the CCRN source tree my $CCRNSRC = ""; if ( $ENV{CCRNSRC} ) { # Define CCRNSRC if it is defined in the current environment # The official UVic CCRNSRC source tree is out of date # However, a subdir named $CCRNSRC/sv08src does contain regularly updated source # This dir only exists at UVic so it should be safe to use it if it exists if ( -d "$ENV{CCRNSRC}/sv08src" ) { $CCRNSRC = "$ENV{CCRNSRC}/sv08src"; } elsif ( -d "$ENV{CCRNSRC}" ) { $CCRNSRC = "$ENV{CCRNSRC}"; } else { die "CCRNSRC=$ENV{CCRNSRC} is not a directory\n"; } # Follow any links $CCRNSRC = readlink $CCRNSRC if -l $CCRNSRC; # Ensure this is an absolute pathname $CCRNSRC = abs_path( $CCRNSRC ); } else { warn "CCRNSRC is not defined in this environment.\n"; } # suffix_list contains allowable source file name suffixes @src_suffix = (q(\.f), q(\.F), q(\.dk), q(\.cdk), q(\.f90), q(\.f95), q(\.F90), q(\.F95)); @inc_suffix = (q(\.h), q(\.H), q(\.inc), q(\.fh)); push @suffix_list,(@src_suffix,@inc_suffix); # define a unique stamp for file name id etc chomp($stamp = `date "+%Y%j"$$`); # $out_dir is the name of a directory into which output files will be placed $out_dir = ""; # $new_suffix will be appended to file names found on %CALL update # directive lines when they are converted to cpp #include directives # If $out_suffix is defined and not null, $new_suffix will be assigned # the value of $out_suffix $new_suffix = '.h'; $out_suffix = ''; # If $choose_suffix is true then the subroutine replace_update_directives # will pick a suffix for "CALLed" files based on whether the file is a complete # fortran subroutine or just a code fragment. If $choose_suffix is false # then a common suffix will be used for all included files $choose_suffix = 1; # $cccmode flags the use of .dk and .cdk suffixes on "CALL"ed include # files. If $cccmode=0 then .F and .h will be used in place of .dk and .cdk $cccmode = 0; # $remove_deck_cards flags replacing %DECK and/or %COMDECK directives # with a comment line $remove_deck_cards = 1; # $tracer_cond_blocks flags the replacement of blocks of lines beginning # with one of the strings $COM$, $CSP$, $CSL$ or $CSN$ with preprocessor # conditional blocks. # NOTE: This will change the number of lines in the output files $tracer_cond_blocks = 1; # $param_replace_with_token flags replacing $...$ parameters with tokens that are # assigned values via "#DEFINE token value" cpp directives. # In this case the user will need to edit the output source file to define the # appropriate set of tokens prior to compiling $param_replace_with_token = 1; # $param_replace_with_value flags replacing $...$ parameters with values detemined # from a user input file $param_replace_with_value = 0; # $overwrite flags overwriting any existing output files $overwrite = 0; $usr_set_overwrite = 0; # $add_defs_to_file flags prepending to each output file a list of # all the preprocessor tokens found in that file $add_defs_to_file = 1; # If defined, $defs_fname is the name that will be created containing # tokens used in any/all of the output files $defs_fname = ''; # $show_fnames flags the display, on stdout, of input filename == output # filename pairs, 1 per line. This info may then be used by other scripts. $show_fnames = 0; # with_mpi is a boolean flag used to determine if a compiler command line # suitable for using MPI will be added to the output makefile my $with_mpi = 0; # with_coupled is a boolean flag used to determine if a makefile suitable # for compiling the coupled model will be created my $with_coupled = 0; chomp($Runame = `basename $0`); # verbose controls the amount of info written to stdout $verbose = 0; # quiet flags running silently $quiet = 0; # modver identifies the version of the gcm whose source tree # will be searched for files if DIR_LIST is not set in the # environment or on the command line $modver = "gcm16"; # DIR_LIST will be a colon separated list of dirs to be searched # for files. The environment variable, if set, will be overriden # via the --dir_list command line option $DIR_LIST = $ENV{DIR_LIST}; $DIR_LIST ||= $ENV{SPATH}; # descend_dir_tree flags the use of all sub directories found below # those dirs specified in DIR_LIST (see below) $descend_dir_tree = 0; # Flist will contain all non-option command line args # which should be file names my @Flist = (); # $expand_dirs flags the replacement of dir names found on the command # line with a list of regular files found in that directory. $expand_dirs = 1; # out_prefix will be prepended to output files $out_prefix = ''; # if defined and not null $out_file will be the name of the output file $out_file = ''; # misc variables my ($name, $path, $suffix); # Define a usage function $Usage = sub { my ($msg)=@_; if ($msg) {print "${Runame}: $msg\n"}; print < \&$Usage, "verbose" => sub {$verbose++}, "quiet" => \$quiet, "dir_list=s" => \$DIR_LIST, "out_file=s" => \$out_file, "out_dir=s" => \$out_dir, "add_ppdefs!" => \$add_defs_to_file, "ppdefs=s" => \$defs_fname, "descend!" => \$descend_dir_tree, "expand_dirs!" => \$expand_dirs, "overwrite!" => sub {$overwrite=$_[1]; $usr_set_overwrite=1}, "show_fnames!" => \$show_fnames, "tracer_cond!" => \$tracer_cond_blocks, "cccmode!" => \$cccmode, "mpi!" => \$with_mpi, "coupled!" => \$with_coupled, "prefix_out=s" => \$out_prefix, "suffix_out=s" => \$out_suffix, "remove_deck_cards!" => \$remove_deck_cards, "<>" => sub {push @NonOpt,$_[0]}) or die "Error on command line. Stopped"; # Process non option command line args foreach (@NonOpt) { next unless $_; if (/=/) { # This is a variable assignment of the form "var=val" # Strip quotes, if any and assign $var and $val s/^\s*"(.*)"\s*$/$1/; s/^\s*'(.*)'\s*$/$1/; my ($var,$val) = /^\s*(.*?)=(.*)/; # Strip leading or trailing whitespace from the value $val =~ s/^\s*(.*?)\s*$/$1/; # Strip quotes from the value, if any $val =~ s/^\s*"(.*)"\s*$/$1/; $val =~ s/^\s*'(.*)'\s*$/$1/; # Require a non NULL value die "Missing value for $_\n" unless $val; # Check for valid parameter names my $found = 0; foreach my $parm (@cmdl_params) { if ( $parm eq $var ) { $found = 1; last; } } unless ($found) { Usage(1,"Invalid command line parameter --> $var <--"); } # Add variable defs found on the command line to the usrvar hash if ( $var eq "verbose" ) { # Treat these variable values as a single string, allowing white space within # There will be only one value allowed for this variable which will be # overwritten by subsequent defs for the same variable $usrvar{$var} = $val; } else { # Multiple variable assignments for the same variable will be added to a # list of values for that variable. # Each individual assignment will be split on whitespace and added # as a separate entry in the list of values. $val =~ s/^\s*(.*?)\s*$/$1/; push @{$usrvar{$var}}, split(/\s+/,$val); } next; } # Any remaining command line args should be file names push @Flist, $_; } unless (scalar(@Flist)) { &$Usage("At least one file name is required on the command line") } if ($quiet) {$verbose = -1} # Set forced overwrite of output file if the user has specified an output # file name on the command line but has not set $overwrite explicitly if ( not $usr_set_overwrite ) { $overwrite = 1 if $out_file; } # Determine the gcm model version if ( $usrvar{modver} ) { # Only the first element of this array is significant, all others are ignored $modver = @{$usrvar{modver}}[0]; if ( scalar(@{$usrvar{modver}})>1 ) { warn "Multiple values for modver found on command line. --> @{$usrvar{modver}} <--\n"; warn "Using modver = $modver\n"; } die "** EE ** up2cpp: Invalid value for modver = $modver\n" unless -d "$CCRNSRC/source/lsmod/agcm/$modver"; } # Set the name of a user supplied file containing cpp defines my $cppdefs_file = ""; if ( $usrvar{cppdefs} ) { # Only the first element of this array is significant, all others are ignored $cppdefs_file = @{$usrvar{cppdefs}}[0]; if ( scalar(@{$usrvar{cppdefs}})>1 ) { warn "Multiple values for cppdefs found on command line. --> @{$usrvar{cppdefs}} <--\n"; warn "Using cppdefs = $cppdefs_file\n"; } die "cppdefs file ",$cppdefs_file," is missing or empty\n" unless -s $cppdefs_file; # Ensure this is an absolute pathname $cppdefs_file = abs_path( $cppdefs_file ); } # Set the name of a user supplied file containing replacement values for # "$" delimited text strings that may be embedded in source files my $sizes_file = ""; if ( $usrvar{sizes} ) { # Only the first element of this array is significant, all others are ignored $sizes_file = @{$usrvar{sizes}}[0]; if ( scalar(@{$usrvar{sizes}})>1 ) { warn "Multiple values for sizes found on command line. --> @{$usrvar{sizes}} <--\n"; warn "Using sizes = $sizes_file\n"; } die "sizes file ",$sizes_file," is missing or empty\n" unless -s $sizes_file; # Ensure this is an absolute pathname $sizes_file = abs_path( $sizes_file ); # When the user supplies a sizes file then replace "$" delimited text strings # with values read from the user input sizes file. # The default is to replace these delimited strings with cpp tokens $param_replace_with_token = 0; $param_replace_with_value = 1; } # Set the name of a user supplied file containing a model job string my $model_job_file = ""; if ( $usrvar{model_job} ) { # Only the first element of this array is significant, all others are ignored $model_job_file = @{$usrvar{model_job}}[0]; if ( scalar(@{$usrvar{model_job}})>1 ) { warn "Multiple values for model_job found on command line. --> @{$usrvar{model_job}} <--\n"; warn "Using model_job = $model_job_file\n"; } die "model_job file ",$model_job_file," is missing or empty\n" unless -s $model_job_file; # Ensure this is an absolute pathname $model_job_file = abs_path( $model_job_file ); } # Define the param hash if ( $usrvar{sizes} ) { # Assign keys in the param hash from values in the user supplied file sizes def_param_using_sizes($sizes_file) or die "Error defining param hash"; } elsif ( $model_job_file ) { # Use info in this file to create cppdefs_file and/or sizes_file if they # were not specified by the user # This implies that this section of code must always come after that which # defines $cppdefs_file and $sizes_file from command line values model_job_to_cpp_sizes( $model_job_file ); # Make cppdefs_file absolute if it was created by model_job_to_cpp_sizes $cppdefs_file = abs_path( $cppdefs_file ) if $cppdefs_file; if ( $sizes_file ) { # Assign keys in the param hash from values in the newly created sizes file def_param_using_sizes($sizes_file) or die "Error defining param hash from $sizes_file"; # Remove the temporary sizes file unlink $sizes_file or die "Unable to remove $sizes_file. Stopped"; # When the user supplies a parmsub file then replace "$" delimited text strings # with values read from the sizes file created here. $param_replace_with_token = 0; $param_replace_with_value = 1; } #xxx # Read the first part of the model job string into memory #xxx # Stop reading at the first update section or the end of the #xxx # first job in the string, whichever comes first #xxx # For a "normal" model job string this will include the entire parmsub #xxx # section as well as any lines prior to the Model_Input here document #xxx my $fsrc = ''; #xxx my $found_update_section = 0; #xxx open (FILE, "<$model_job_file") || die "$!"; #xxx while () { #xxx # Ignore any lines that would start a here document #xxx next if /^cat[\s><]+\w+[\s><]+/; #xxx # Expand tabs as each line is read #xxx $fsrc .= expand($_); #xxx # Only read, at most, the first job from this file #xxx last if /^# *end_of_job\s*$/; #xxx # Stop at the beginning of the first update section #xxx if ( /^###[#\s]*update\s+/ ) { #xxx $found_update_section = 1; #xxx last; #xxx } #xxx } #xxx close FILE; #xxx #xxx warn "** WW ** No update sections were found in $model_job_file. #xxx This may not be a model job string.\n" unless $found_update_section; #xxx #xxx # Extract all shell variables found in this script and assign them to parmsub #xxx my ($parmsub_ref, $script, $CPP_I) = shvals( $fsrc ); #xxx die "Unable to read any variable defs from $model_job_file.\n" unless $parmsub_ref; #xxx %parmsub = %{$parmsub_ref}; #xxx undef $parmsub_ref; #xxx #xxx unless ( $cppdefs_file ) { #xxx # If the user has not supplied a cppdefs file then create one #xxx # using the CPP_I section found in the user supplied model_job_file #xxx if ( $CPP_I ) { #xxx # Don't bother unless CPP_I is present in the model_job_file #xxx $cppdefs_file = $parmsub{runid} ? "CPP_I_$parmsub{runid}": "CPP_I_$stamp"; #xxx open( CPPDEFS, ">$cppdefs_file") or die "$!"; #xxx print CPPDEFS "$CPP_I\n"; #xxx close(CPPDEFS); #xxx # Now make cppdefs_file absolute #xxx $cppdefs_file = abs_path( $cppdefs_file ); #xxx } #xxx } #xxx #xxx unless ( $sizes_file ) { #xxx # Create a sizes file from info in this model_job file #xxx # This requires 2 programs to be on the users path #xxx # gcmparm_input #xxx # gcmparm #xxx # If either of these are missing one of the following system calls will fail #xxx #xxx # Create a disk file containing the parmsub section #xxx # with any CPP_I section removed #xxx my $parmsub_tmp = "parmsub_$stamp"; #xxx open( PARMTMP, ">$parmsub_tmp") or die "$!"; #xxx print PARMTMP "$script\n"; #xxx close(PARMTMP); #xxx #xxx # This command will create a file named gcmparmin_tmp #xxx my $gcmparmin_tmp = "gcmparmin_$stamp"; #xxx syscmd( "gcmparm_input $parmsub_tmp outfile=$gcmparmin_tmp" ); #xxx #xxx # Remove the temporary parmsub_tmp file #xxx unlink $parmsub_tmp or die "Unable to remove $parmsub_tmp. Stopped"; #xxx #xxx # This command will use gcmparmin_tmp to create the sizes file #xxx my $sizes_file = $parmsub{runid} ? "sizes_$parmsub{runid}": "sizes_$stamp"; #xxx syscmd( "gcmparm $sizes_file < $gcmparmin_tmp" ); #xxx #xxx # Remove the temporary gcmparmin_tmp file #xxx unlink $gcmparmin_tmp or die "Unable to remove $gcmparmin_tmp. Stopped"; #xxx #xxx # Add a value for NRFP to the sizes file #xxx my $NRFP = $parmsub{NRFP} ? $parmsub{NRFP} : 1; #xxx syscmd( "echo \"NRFP = $NRFP\" >> $sizes_file" ); #xxx #xxx # Assign keys in the param hash from values in the newly created sizes file #xxx def_param_using_sizes($sizes_file) or die "Error defining param hash from $sizes_file"; #xxx #xxx # Remove the temporary sizes file #xxx unlink $sizes_file or die "Unable to remove $sizes_file. Stopped"; #xxx #xxx # When the user supplies a parmsub file then replace "$" delimited text strings #xxx # with values read from the sizes file created here. #xxx $param_replace_with_token = 0; #xxx $param_replace_with_value = 1; #xxx } } else { # The default is to replace "$" delimited strings with cpp tokens # In this case the user must define these tokens manually $param_replace_with_token = 1; $param_replace_with_value = 0; # Assign default values to keys in the param hash # def_param_using_default({VERBOSE=>1}) or die "Error defining param hash"; } # Take the definition of DIR_LIST from the command line first, # the environment second, the env variable CCRNSRC third and # if all else fails set it to the current working dir. unless ($DIR_LIST) { if ($CCRNSRC) { $DIR_LIST = "$CCRNSRC"; } else { chomp($DIR_LIST = `pwd`); }; }; if ($verbose > 10) {print "DIR_LIST = $DIR_LIST\n"}; unless ($DIR_LIST) {&$Usage("DIR_LIST is undefined")}; # Define a list of directories to be scanned for source files @dir_list = (); if ("$DIR_LIST" eq "$CCRNSRC") { # Always look in subdirectories when using the official source $descend_dir_tree = 1; push @dir_list, "$CCRNSRC/source/lsmod/agcm/$modver", "$CCRNSRC/source/lssub/model/agcm/$modver", "$CCRNSRC/source/lssub/comm", "$CCRNSRC/source/lssub/diag", "$CCRNSRC/source/lspgm"; } else { @dir_list = split ':',$DIR_LIST; }; @dir_list2 = (); chomp(my $cwd = `pwd`); foreach (@dir_list) { # ensure $_ is a full path name if ("$_" =~ /^\.\//) {substr($_,0,1) = $cwd}; if ($verbose > 10) {print "dir = $_\n"}; unless (-d $_) { print "${Runame}: $_ is not a dir ...ignored\n"; next; }; if ($descend_dir_tree) { # Get a list of all dirs in the dir tree at or below those currently # in dir_list, excluding any named RCS or CVS. push @dir_list2, `find $_ -follow -type d ! -name RCS ! -name CVS 2>/dev/null`; } else { push @dir_list2, $_; }; }; @dir_list = @dir_list2; chomp @dir_list; undef @dir_list2; # prepend the current working directory to dir_list if is is not already there # unless (grep /^$cwd$/, @dir_list) {unshift @dir_list, $cwd}; # ensure a trailing slash on all dirs in dir_list foreach (@dir_list) {$_ .= '/' unless $_ =~ m'/$'} if ($verbose > 3) {print "dir_list= \n",join "\n",@dir_list,"\n"} # Define a hash to be use to determine whether or not files are from # a directory that was specified on the command line foreach (@Flist) {$fromdir{$_} = 0} if ($expand_dirs) { # Make a pass through Flist to: # 1) Expand any directories found to a list of all files in that dir # 2) Expand to full pathnames, regular files found in any dir in dir_list L1: foreach my $fname (@Flist) { next unless $fname; if (-f "$fname") { # This is a regular file if ($verbose > 0) { print "$fname is a regular file in ",`pwd`; } push @Flist2, $fname; $fromdir{$fname} = 0; next; } my @files=(); if (-d "$fname") { # This is a directory if ($verbose > 0) { print "$fname is a directory: ",`pwd`; } # append the list of files in this dir to Flist2 unless (opendir DIR, $fname) { die "*** ERROR *** Cannot open directory $fname\n"; } @files = grep !/^\.\.?$/, readdir DIR; closedir DIR; foreach (@files) { substr($_,0,0) = "$fname/"; my ($dname, $dpath, $dsuffix) = fileparse("$fname", @suffix_list); # set fromdir to the directory name $fromdir{$_} = "$dname$dsuffix"; } push @Flist2, grep( -f $_, @files); next; } # $fname is neither absolute nor relative to cwd ...look for it in dir_list foreach my $dir (@dir_list) { my $path = "$dir$fname"; if (-f "$path") { # This is a regular file if ($verbose > 0) { print "$fname is a regular file in $path\n"; } push @Flist2, "$path"; $fromdir{$path} = 0; next L1; } # Compare each subdir in the current $dir path with $fname # If a match is found then add the list of files in that dir to Flist my $d = ''; foreach (split '/', $dir) { $d .= "$_/"; if ("$_" eq "$fname") { if ($verbose > 0) { print "$fname is a directory: $d\n"; } unless (opendir DIR, $d) { die "*** ERROR *** Cannot open directory $d\n"; }; @files = grep !/^\.\.?$/, readdir DIR; closedir DIR; foreach (@files) { substr($_,0,0) = "$d"; my $dd = substr($d,0,-1); my ($dname, $dpath, $dsuffix) = fileparse("$dd", @suffix_list); # set fromdir to the directory name $fromdir{$_} = "$dname$dsuffix"; } push @Flist2, grep( -f $_, @files); next L1; } } } } @Flist = @Flist2; undef @Flist2; die "No valid file names were found on the command line\n" unless (scalar @Flist); if ($verbose > 0) { print "Input file list with directories expanded:\n",join("\n",@Flist),"\n"; } } # strip leading and trailing whitespace from out_dir $out_dir =~ s/^\s*//; $out_dir =~ s/\s*$//; # Create the directory $out_dir if ($out_dir) { die "Output dir $out_dir exists. Use --overwrite to force an overwrite\n" if (-e "$out_dir" and not $overwrite); unless (-e "$out_dir") { mkdir("$out_dir",0755) or die "Unable to create dir $out_dir: $!\n"; } } my $fcount = 0; foreach my $fname (@Flist) { $fcount++; next unless $fname; unless (-f "$fname") { # $fname is neither absolute nor relative to cwd ...look for it in dir_list foreach my $dir (@dir_list) { next unless (-f "$dir$fname"); # prepend $dir to the filename and exit inner loop substr($fname,0,0) = $dir; last; }; }; unless (-f $fname) { print "up2cpp: ** WW ** Unable to find regular file $fname\n"; next; }; # remove any existing keys from the defs hash undef %defs; # replace update directives with cpp directives if ($verbose > -1) {print "Processing $fname\n"}; ($cppsrc, $has_directives) = replace_update_directives($fname); unless ($cppsrc) { warn "** WW ** Empty string returned from replace_update_directives\n"; next; } # define the output file name ($name, $path, $suffix) = fileparse("$fname", @suffix_list); unless ($suffix) { warn "up2cpp: ** WW ** Unexpected suffix on file name $name\n"; } my $oname = ''; if ($cccmode) { $oname = "$out_prefix$name$suffix"; } else { if ($has_directives) { $oname = "$out_prefix$name$new_suffix"; } else { $oname = "$out_prefix$name$suffix"; } } if ($fcount == 1) { # override oname with out_file if out_file was input on the command line $oname = $out_file if $out_file; } if ($fromdir{$fname}) { # This file was found in a dir specified on the command line if ($verbose > 1) { print "$fname is put into dir $fromdir{$fname}\n"; } # prepend the dir name to $oname substr($oname,0,0) = "$fromdir{$fname}/"; } # prepend the output directory name to $oname # Note that this is not done if $out_dir is null substr($oname,0,0) = "$out_dir/" if $out_dir; if ($fromdir{$fname}) { # ensure this dir exists my $subdir = $fromdir{$fname}; substr($subdir,0,0) = "$out_dir/" if $out_dir; unless (-d "$subdir") { mkdir("$subdir",0755) or die "Unable to create dir $subdir: $!\n"; } } if (-s "$oname" and not $overwrite) { die "*** ERROR *** ${Runame}: Output file $oname exists\n"; } if ($show_fnames) { print "$fname == $oname\n"; } if (open(FSRC, ">$oname")) { # print FSRC '#include "'.$defs_fname.'"'."\n"; if ( $cppdefs_file ) { # If the user has supplied the name of an include file # then prepend the include to the top of this file print FSRC "#include \"$cppdefs_file\"\n"; } if ( $with_mpi or $with_coupled ) { # The user requires with_MPI_ defined # Check if this file contains any cpp tokens named with_MPI_ foreach (sort keys %defs) { # Make the search case insensiteve my $token = lc($_); next unless $token eq "with_mpi_"; # A cpp token named "with_MPI_" was identified in the current file # Define this at the top of the file so that with_MPI_ related code will be included print FSRC "#define $_\n"; } } if ( $with_coupled ) { # The user requires with_COUPLED_ defined # Check if this file contains any cpp tokens named with_COUPLED_ foreach (sort keys %defs) { # Make the search case insensiteve my $token = lc($_); next unless $token eq "with_coupled_"; # A cpp token named "with_COUPLED_" was identified in the current file # Define this at the top of the file so that with_COUPLED_ related code will be included print FSRC "#define $_\n"; } } if ( $param_replace_with_value ) { # The user has supplied a file containing parameter values # Use these values to replace "$" delimited parameters found # in this source file $cppsrc = replace_ddelim( $cppsrc, $fname ); if ($tracer_cond_blocks) { # Blocks of lines that begin with the strings $COM$, $CSL$, $CSP$ and $CSN$ # were replaced with preprocessor conditional blocks in replace_update_directives # Prepend defines for these conditional blocks, consistent with the user input # parameter values foreach (sort keys %trac_defs) { # trac_def should contain one or more of the keys: COM, CSL, CSP, CSN # If any of these parameter values are only whitespace then parmsub would # have replaced the $...$ strings with space (ie not a comment) and so # they should be defined (true) print FSRC "#define $_\n" if $param{"\L$_"} =~ /^\s+$/; } } } foreach (sort keys %defs) { $all_defs{$_} = $defs{$_} unless exists $all_defs{$_}; if ($add_defs_to_file) { print FSRC "!!--- NEW: #define $_\n"; } } print FSRC "$cppsrc"; close(FSRC); if ($verbose > -1) {print "Created $oname\n"}; } else { print "*** ERROR *** ${Runame}:\n"; die " Cannot open output file $oname\n Stopped"; } } if ($defs_fname) { # Create an include file to define preprocessor tokens used # by the code in the output file if (open(DEFS, ">$defs_fname")) { # The defs hash is defined in replace_update_directives and contains a # key for each quantity used in an ifdef preprocessor directive. # The value of the key will be true (1) if the quantity is to be defined # and false (0) if the quantity is to be undefined. These values are # guesses based on the gcm version, assuming spectral advection. foreach (sort keys %all_defs) { print DEFS "!! #define $_\n"; # if ($all_defs{$_}) { # print DEFS "#define $_\n"; # } else { # print DEFS "C #define $_\n"; # } }; close(DEFS); if ($verbose > -1) {print "Created $defs_fname\n"}; } else { print "*** ERROR *** ${Runame}: "; die "Cannot open defs file $defs_fname\n"; }; }; exit 0; ######################################################## ##################### End of main ###################### ######################################################## sub syscmd { use strict; my $cmd = shift; my $show_stdout = shift; die "Missing system command string\n" unless $cmd; if ( $verbose > 1 ) { print "syscmd: $cmd\n"; } chomp(my @sh_out = `$cmd 2>&1`); my $sh_err = $?; if ( $show_stdout or $sh_err ) { foreach (@sh_out) {print "$_\n"} } if ($sh_err) { die "** EE ** Problem executing\n $cmd\n"; } # Return command stdout in array context, otherwise return command status return wantarray ? @sh_out : $sh_err; } sub replace_update_directives { use strict; my $fname = shift; my $OPTS = shift; my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; if ($verbose>1) {print "${Runame}::replace_update_directives fname=$fname\n"}; my $fsrc = ''; if (open(FSRC, "<$fname")) { while () {$fsrc .= $_}; close(FSRC); } else { warn "up2cpp: ** WW ** Cannot open file $fname\n"; return (); }; unless ($fsrc) { warn "up2cpp: ** WW ** Empty file $fname\n"; return (); }; my ($GCMmajor_ver) = $modver =~ /^gcm(.*)[A-Za-z]*$/; $GCMmajor_ver = $GCMmajor_ver + 0; my $has_directives = 0; unless ($out_suffix) { # If this is a fortran program or subroutine then it should have the # suffix '.F' whereas if this is a code snippet then it should have # the suffix '.h' if (source_isfprog($fsrc)) { # this is a complete fortran program, subroutine etc. $new_suffix = '.F'; } else { # assume this is a code snippet $new_suffix = '.h'; }; } else { # When $out_suffix is defined use that value for $new_suffix $new_suffix = $out_suffix; }; if ($verbose > 10) {print "new_suffix=$new_suffix\n"}; if ($remove_deck_cards) { # replace %DECK and %COMDECK directives with comment lines $fsrc =~ s/^[%*]DECK\s.*$/C/mig and $has_directives=1; $fsrc =~ s/^[%*]COMDECK\s.*$/C/mig and $has_directives=1; }; # This function will return the replacement # for %CALL update directive lines my $inc = sub { my $s=shift; # the "CALLed" file name is input $s =~ tr /A-Z/a-z/; # ensure lower case # Attempt to make the suffix of the include file the same as # the suffix of that file if it were output from up2cpp # If the include file cannot be found then do not add a suffix my $new_sfx = ''; my $fn = "$s"; my $found = 0; my @sfx_list = (q(.cdk),q(.dk)); foreach my $sfx (@sfx_list) { last if $found; $fn = "$s$sfx"; if (-f $fn) { # fn is a relative path $found = 1; } else { foreach my $dir (@dir_list) { next unless (-f "$dir$fn"); # prepend $dir to the filename and exit inner loop substr($fn,0,0) = $dir; $found = 1; last; } } } if ($found) { if ($choose_suffix) { my $dksrc = ''; if (open(DKSRC, "<$fn")) { while () {$dksrc .= $_}; close(DKSRC); } else { warn "${Runame}: ** WW ** Cannot open include file $fn\n"; } unless ($dksrc) { warn "${Runame}: ** WW ** Empty include file $fn\n"; } if (source_isfprog($dksrc)) { # this is a complete fortran program, subroutine etc. if ($cccmode) { $new_sfx = '.dk'; } else { $new_sfx = '.F'; } } else { # assume this is a code snippet if ($cccmode) { $new_sfx = '.cdk'; } else { $new_sfx = '.h'; } } } else { # use the same suffix for all include files if ($cccmode) { $new_sfx = '.cdk'; } else { $new_sfx = '.h'; } } if ($verbose > 10) {print "fn=$fn new_sfx=$new_sfx\n"}; } else { warn "${Runame}: ** WW ** Include file $s was not found\n"; } $s .= "$new_sfx"; # append a predetermined suffix return '#include "'.$s.'"'; # output a cpp include directive }; # replace update %CALL directives with cpp #include directives $fsrc =~ s/^[%*]CALL\s*([^\s]*)\s*$/&$inc($1)/meig and $has_directives=1; # This function will return the replacement # for %IF update directive lines my $ifcond = sub { my $up_cond = shift; my @clist = split /\s*,\s*/,$up_cond; my $ret; if (scalar(@clist) == 2) { # there is only 1 condition ...use #ifdef or #indef # Replace the token name in "%IF DEF,token" with "with_token_" to avoid defining # MPI as a cpp token name when "use MPI" is compiled (this will cause problems # since the string "MPI" will be replaced by null string when "#define MPI" is # also present) # Note: recent agcm versions will use only 2 token names in %IF update # directives, namely "MPI" and "COUPLED" my $tokname = "with_$clist[1]_"; $defs{$tokname} = 0; if ($clist[0] =~ /^\s*DEF/i) {$ret = "#ifdef $tokname"} elsif ($clist[0] =~ /^\s*-DEF/i) {$ret = "#ifndef $tokname"} else { die "${Runame}: Illegal update directive: %IF $up_cond found in file $fname\n"; } } else { my $cond = ''; foreach (@clist) { SWITCH: { /^\s*DEF/i && do {$cond .= 'defined '; last SWITCH}; /^\s*-DEF/i && do {$cond .= '!defined '; last SWITCH}; /^\s*AND/i && do {$cond .= ' && '; last SWITCH}; /^\s*OR/i && do {$cond .= ' || '; last SWITCH}; # Replace the token name in "%IF DEF,token" with "_token_" to avoid defining # MPI as a cpp token name when "use MPI" is compiled (this will cause problems # since the string "MPI" will be replaced by null string when "#define MPI" is # also present) # Note: recent agcm versions will use only 2 token names in %IF update # directives, namely "MPI" and "COUPLED" my $tokname = "with_${_}_"; $cond .= $tokname; $defs{$tokname} = 0; } } $ret = "#if $cond"; } return "$ret"; }; # replace %IF and %ENDIF update directives $fsrc =~ s/^[%*]IF\s*([^\s]*)\s*$/&$ifcond($1)/meig and $has_directives=1; $fsrc =~ s/^[%*]ENDIF.*$/#endif/mig and $has_directives=1; # This function will return a replacement for blocks of lines that begin # with strings of the form $...$. These are tracer related lines that # should be included when NTRAC>0 and certain other conditions hold (are # there advected tracers, is it semi-lag or spectral advection). # These conditions are as follows # $COM$ include when NTRAC>0 # $CSP$ include when NTRAC>0 and there are advected tracers, spectral # $CSL$ include when NTRAC>0 and there are advected tracers, semi-lag # $CSN$ include when NTRAC>0 and (there are advected tracers, semi-lag # or there are no non-advected tracers) my $trdef = sub { my $blk= join '',shift; # a block of lines containing $...$ is input my ($cid) = $blk =~ /^\$(...)\$/mig; $defs{$cid} = 0; # Keep track of tokens specific to these tracer conditional blocks $trac_defs{$cid} = 1; if ($GCMmajor_ver >= 15) { if ($cid =~ /^COM$/i) {$defs{$cid} = 1}; if ($cid =~ /^CSP$/i) {$defs{$cid} = 1}; }; if ($verbose > 10) {print "BLOCK: $cid$blk"}; $blk =~ s/^\$(...)\$/ /mig; my $ret = "\n#ifdef $cid$blk#endif\n"; if ($verbose > 10) {print "return:\n$ret\n"}; return "$ret"; }; if ($tracer_cond_blocks) { # replace blocks of lines that begin with the strings $COM$, $CSL$, # $CSP$ and $CSN$ with preprocessor conditional blocks $fsrc =~ s/((\n\$COM\$[^\n]*)+\n)/&$trdef($1)/seig and $has_directives=1; $fsrc =~ s/((\n\$CSL\$[^\n]*)+\n)/&$trdef($1)/seig and $has_directives=1; $fsrc =~ s/((\n\$CSP\$[^\n]*)+\n)/&$trdef($1)/seig and $has_directives=1; $fsrc =~ s/((\n\$CSN\$[^\n]*)+\n)/&$trdef($1)/seig and $has_directives=1; } if ($param_replace_with_token) { # Replace strings of the form $...$ with tokens of the form _PAR_... $fsrc = replace_ddelim( $fsrc, $fname ); } # ensure a trailing newline $fsrc =~ s/\s*$/\n/s; return ($fsrc, $has_directives); }; sub source_isfprog { # Make a guess as to whether or not the input string is a complete # fortran program by checking for a valid fortran end statement. use strict; my $bare_fsrc = shift; my $OPTS = shift; my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; # the return value isfprog will be set true or false my $isfprog = 0; # create a copy of the src without comment lines or update directives $bare_fsrc =~ s/^[cCdD].*//mg; # remove fortran comment lines $bare_fsrc =~ s/^\s*[!%#*].*//mg; # remove update directives $bare_fsrc =~ s/\s*$/\n/s; # strip trailing blank lines # grab the last line of the bare source my ($last_line) = $bare_fsrc =~ /\n([^\n]*)$/s; $last_line =~ s/!.*$//mg; # strip any ! delimited comments # look for a valid fortran end statment my $kwrd = '(block|function|module|program|subroutine)'; if ($last_line =~ /^(\s*end\s*$|\s*end\s*$kwrd)/i) { # this is a valid fortran end statement $isfprog = 1; } else { $isfprog = 0; } if ($verbose > 0) { print "${Runame}::source_isfprog last_line:\n$last_line\n"; print "${Runame}::source_isfprog isfprog=$isfprog\n"; } return ($isfprog); } sub def_param_using_default { use strict; my $OPTS = shift; my $ret = 1; my $verbose = 0; if (defined $OPTS->{VERBOSE}) {$verbose = $OPTS->{VERBOSE}}; # $param_file, if defined, is the name of a file containing # parameter definitions. This file is assumed to be shell script, # in particular, the parmsub section of a job string. my $param_file = ''; $param_file = $OPTS->{PARAM_FILE} if defined $OPTS->{PARAM_FILE}; # Define default values for standard parameters # ilev = number of model levels $param{ilev} = $ENV{ilev}; $param{ilev} ||= 35; # levs = number of moisture levels $param{levs} = $ENV{levs}; $param{levs} ||= $param{ilev}; # ntrac = number of tracers in model $param{ntrac} = $ENV{ntrac}; $param{ntrac} ||= 17; # itraca = number of advected tracers. if negative, the tracers are # being advected semi-lagrangian instead of spectral, and # various dimension statements are commented out or activated # in either case depending on the choice ($csp$ or $csl$). # As well, the remainder of ntrac and ntraca=abs(itraca), # defined as ntracn, is calculated and used to define # or comment out various arrays ($csn$). $param{itraca} = $ENV{itraca}; $param{itraca} ||= 7; # ioztyp = switch for input ozone distribution # (ioztyp=1 => old japanese dataset with levoz=37, # ioztyp=2 => new amip2 dataset with levoz=59, # ioztyp=3 => Fortuin and Kelder/HALOE dataset with levoz=28) $param{ioztyp} = $ENV{ioztyp}; $param{ioztyp} ||= 2; # nnode_a = number of MPI tasks used in the atm (mpi for nnode_a>1). $param{nnode_a} = $ENV{nnode_a}; $param{nnode_a} ||= 1; # various parameters used in variable dimension (suffix .vd) code # bij and bijv are the length of the IDAT io buffer $param{bij} = $ENV{bij}; $param{bij} ||= 522728; $param{bijv} = $ENV{bijv}; $param{bijv} ||= 522728; # bijp10v is the length of the IDAT io buffer + IBUF $param{bijp10v} = $ENV{bijp10v}; $param{bijp10v} ||= 522728; # lbij is length of workspace (e.g. in levrev) $param{lbij} = $ENV{lbij}; $param{lbij} ||= 522728; # v is the maximum number of vertical levels $param{v} = $ENV{v}; $param{v} ||= 100; if ($verbose > 10) { # print all defined parameters and their values, at this point foreach (sort keys %param) {print "$_=$param{$_}\n"}; } # read param_file first, if it exists, so that command line parameter defs # will override parameter defs found in this file if ($param_file) { unless (-s $param_file) { die "Parameter definition file $param_file is missing or empty\n"; } # Source $param_file in a shell then extract variable definitions # Get the current environment my %curr_env; # Set IFS explicitly since it will usually contain a newline # which will confuse the following loop because it expects # the var=val to be on a single line. chomp(my @sh_env = `IFS=' '; set`); die "*** ERROR *** executing shell set command\n" if $?; foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; # ensure a lower case parameter name # Parameter names should be case insensitive since # they are typically found in fortran programs # $var =~ tr /A-Z/a-z/; # do not add this var to the curr_env if # it was previously defined for $param next if exists $param{$var}; $curr_env{$var} = $val; } # Now get the environment including param_file variables and add # variables to the $param hash that were defined in $param_file # but did not exist in the current default environment. @sh_env = (); chomp(@sh_env = `IFS=' '; . $param_file >/dev/null; set`); die "*** ERROR *** executing script in $param_file\n" if $?; foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; # ensure a lower case parameter name # Parameter names should be case insensitive since # they are typically found in fortran programs # $var =~ tr /A-Z/a-z/; next if exists $curr_env{$var}; $val =~ s/^'(.*)'$/$1/; # strip single quote delimiters $val =~ s/^\s*(.*)\s*$/$1/; # strip leading/trailing white space if ($verbose > 0) { if (exists $param{$var}) { if (defined $param{$var}) { unless ($param{$var} eq $val) { print "Parameter $var found in $param_file was previously defined\n"; print "The default value of $param{$var} will be replaced by $val\n"; } } } } $param{$var} = $val; if ($verbose > 5) {print "${param_file}: ${var}=$val\n"} } } # Set defaults for horizontal resolution # Note that any of these parameters that are already # assigned will retain their value. # lmt = spectral truncation wavenumber # nlat = number of gaussian latitudes on the physics grid # lonsl = number of longitudes on the physics grid # nlatd = number of gaussian latitudes on the dynamics grid # lonsld = number of longitudes on the dynamics grid # lon = number of grid points per slice for physics calculation. # lond = number of grid points per slice for dynamics calculation. $param{lmt} ||= 63; if ($param{lmt} == 31) { $param{nlat} ||= 32; $param{lonsl} ||= 64; $param{nlatd} ||= 48; $param{lonsld} ||= 96; } elsif ($param{lmt} == 47) { $param{nlat} ||= 48; $param{lonsl} ||= 96; $param{nlatd} ||= 72; $param{lonsld} ||= 144; } elsif ($param{lmt} == 63) { $param{nlat} ||= 64; $param{lonsl} ||= 128; $param{nlatd} ||= 96; $param{lonsld} ||= 192; } else { # If any of these parameters are not yet defined assign t63 values warn "***WARNING*** lmt=$param{lmt} is not supported.\n"; $param{lmt} ||= 63; $param{nlat} ||= 64; $param{lonsl} ||= 128; $param{nlatd} ||= 96; $param{lonsld} ||= 192; } $param{lon} ||= $param{lonsl}; $param{lond} ||= $param{lonsld}; # Set derived parameter values, dependent on values defined above # number of mpi nodes $param{nnode_a} = 1 if $param{nnode_a} < 1; # number of advected and non-advected tracers $param{ntrac} = 0 if $param{ntrac} < 0; $param{ntraca} = ($param{itraca}>0 ) ? $param{itraca} : 0; $param{ntracn} = ($param{itraca}>=0) ? $param{ntrac}-$param{ntraca} : 0; # ozone levels if ($param{ioztyp} == 1) { $param{levoz}=37; } elsif ($param{ioztyp} == 2) { $param{levoz}=59; } elsif ($param{ioztyp} == 3) { $param{levoz}=28; } else { die "*** ERROR *** IOZTYP=$param{ioztyp} is out of range\n Stopped"; } # DERIVED RUN-TIME CONFIGURATION PARAMETERS BASED ON INPUT. # "NTASK" REFERS TO THE RESULTING NUMBER OF ITTERATIONS IN THE # LATITUDE LOOP ON EACH NODE, BASED ON NUMBER OF NODES AND # SPECIFIED CHUNK SIZE (FOR EACH OF PHYSICS,DYNAMICS). # THE ABOVE APPLIES TO BOTH THE DYNAMICS (SUBSCRIPT "D") AND # PHYSICS (SUBSCRIPT "P") GRIDS. my $x = int((0+$param{lon})/(0+$param{lonsl})); my $nlatj = ($x>1) ? $x : 1; $x = int((0+$param{lond})/(0+$param{lonsld})); my $nlatjd = ($x>1) ? $x : 1; my $ilgsl = $param{lonsl} + 2; my $ilgsld = $param{lonsld} + 2; my $ilg_tp = $ilgsl * $nlatj + 1; my $ilg_td = $ilgsld * $nlatjd + 1; # VALUES FOR ILG,ILGD ARE DEPENDENT ON WHETHER WE ARE RUNNING # WITH SUB-LATITUDES PER TASK OR NOT. IF NO SUBLATITUDES, THE # CODE CAN BE MORE EFFICIENT RUNNING WITH JUST ONE OPENMP LOOP # FOR EACH OF THE PHYSICS/DYNAMICS; TO DO SO, HOWEVER, REQUIRES # CHANGING THE DEFINITION OF ILG TO BE CONSISTENT WITH ILG_TP # AND SIMILARILY FOR DYNAMICS. $param{i} = ($param{lon} >= $param{lonsl}) ? $ilg_tp : $param{lon} +1; $param{d} = ($param{lond} >= $param{lonsld}) ? $ilg_td : $param{lond}+1; # Level and spectral space sizes $param{l} = $param{ilev}; $param{s} = $param{levs}; $param{lmtotal} = $param{lmt} + 1; # Conditional comment cards # Upper case COM, CSL, CSP and CSN are switches (either 0 or 1) # Lower case com, csl, csp and csn are the values inserted in place # of $COM$, $CSL$, $CSP$ and $CSN$ in the source code. $defs_in{COM} = 0; $defs_in{CSL} = 0; $defs_in{CSP} = 0; $defs_in{CSN} = 0; if ($param{ntrac} == 0) { $param{com} = "C ***"; $param{csl} = "C ***"; $param{csp} = "C ***"; $param{csn} = "C ***"; } else { $defs_in{COM} = 1; $param{com} = " "; if ($param{itraca} > 0) { $defs_in{CSL} = 0; $defs_in{CSP} = 1; $param{csl} = "C ***"; $param{csp} = " "; } elsif ($param{itraca} < 0) { $defs_in{CSL} = 1; $defs_in{CSP} = 0; $param{csl} = " "; $param{csp} = "C ***"; } else { $defs_in{CSL} = 0; $defs_in{CSP} = 0; $param{csl} = "C ***"; $param{csp} = "C ***"; } if ($param{itraca} < 0 or $param{ntracn} == 0) { $defs_in{CSN} = 0; $param{csn} = "C ***"; } else { $defs_in{CSN} = 1; $param{csn} = " "; } } if ($verbose > 1) { # print all defined parameters and their values foreach (sort keys %param) {print "$_=$param{$_}\n"}; } if ($ret) { return wantarray ? ($ret) : $ret; } else { return wantarray ? () : undef; } } sub shvals { # Given a file containing valid shell script (except possibly containing a # CPP_I section) return a hash of all variable definitions found in that script. use strict; my $script_in = shift; my $read_verbatim = shift; my $strip_quotes = shift; my %VAR; $read_verbatim = 0 unless defined $read_verbatim; $strip_quotes = 1 unless defined $strip_quotes; # Remove any CPP_I section from this script # The input string without any CPP_I section is returned in $script my ($CPP_I, $script) = rip_cpp_i($script_in); # Remove reference to any "sourced" external files found in this script $script =~ s/(^|\n|;)\s*\.\s+\w+/$1/g; if ($read_verbatim) { # Do not source input but read var=val definitions verbatim. # This may be useful when the input is not a shell script or it # is undesireable to execute it as a shell script. my @defs; foreach (split /\n/, $script) { next if /^\s*#/; # ignore comment lines next unless /=/; # ignore lines without any parameter defs s/^([^#]*).*/$1/; # strip trailing comments # values are backtic delimited my $bt = q@`[^`]*`@; # values are single quote delimited my $sq = q@'[^']*'@; # values are double quote delimited my $dq = q@"[^"]*"@; # values are terminated by a semi colon or white space my $sw = q@[^\s;]*?(?=[\s;])@; # null values my $nv = '\s*;'; push @defs, /\b(\w+=(?:$bt|$sq|$dq|$sw|$nv))/g; } foreach (@defs) { my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; $val =~ s/^\s+//; # strip leading white space from value $val =~ s/\s+$//; # strip trailing white space from value $val =~ s/^"(.*)"$/$1/; # strip double quotes from value $val =~ s/^'(.*)'$/$1/; # strip single quotes from value # add or replace this variable in the param hash $VAR{$var} = $val; } } else { # Source input in a shell then extract variable definitions # Get the current environment # Set IFS explicitly since it will usually contain a newline # which will confuse the following loop because it expects # the var=val to be on a single line. chomp(my @sh_env = `IFS=' '; set`); die "*** ERROR *** executing shell set command\n" if $?; my %curr_env; foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; # do not add this var to the curr_env if # it was previously defined for $VAR next if exists $VAR{$var}; $curr_env{$var} = $val; } # Create a temporary file containing a preprocessed # version of the input script chomp(my $script_file = `echo "shvar_script_$$"`); if (open(SH_SCRIPT, ">$script_file")) { foreach (split /\n/,$script) { # Retain the shebang line, if any, # and throw away all comment lines unless (/^\s*#!/) {next if /^\s*#/} # ignore lines that source scripts via ". script" next if /(^\s*|;\s*|\s)\.\s/; print SH_SCRIPT "$_\n"; } close(SH_SCRIPT); if ($verbose > 5) {print "Created $script_file\n"}; } else { die "shvals: Cannot open file $script_file for output.\n Stopped"; } if ($verbose > 10) { print "PREPROCESSED SCRIPT: $script_file\n"; print `cat $script_file`; } # Now get the environment including the input script variables and # add variables to the $VAR hash that were defined in the input # script but did not exist in the current default environment. @sh_env = (); chomp(@sh_env = `IFS=' '; . $script_file >/dev/null 2>&1; set`); die "*** ERROR *** executing script in $script_file\n" if $?; my $rc = 0xffff & system(('rm','-f',"$script_file")); if ($rc != 0) {die "*** ERROR *** rm ${script_file}: $!\n"}; foreach (@sh_env) { # reformat as a hash my ($var,$val) = split '=',$_,2; $var =~ s/^\s+//; # strip leading white space from variable $var =~ s/\s+$//; # strip trailing white space from variable next unless $var; next if exists $curr_env{$var}; if ($verbose > 0) { if (exists $VAR{$var}) { if (defined $VAR{$var}) { unless ($VAR{$var} eq $val) { print "Parameter $var found in script was previously defined\n"; print "The previous value ($VAR{$var}) will be replaced by $val\n"; } } } } if ($strip_quotes) { # Remove single quotes added by the shell $val =~ s/^\s*'(.*?)'\s*$/$1/; } $VAR{$var} = $val; if ($verbose > 5) {print "shvals: ${var}=$val\n"} } } if ( $verbose > 10 ) { foreach (sort keys %VAR) { print "shvals: $_ = $VAR{$_}\n"; } } return wantarray ? (\%VAR, $script, $CPP_I) : \%VAR; } sub rip_cpp_i { # Extract any CPP_I definition that may appear in this job # Return 2 strings: # 1) the CPP_I section # 2) the input job string with the CPP_I section removed use strict; use Text::Balanced qw(extract_tagged); my $job = shift; # Define a set of regexes that will match the first and last lines # of the CPP_I section as well as any text found in the input job # string that is before the first line of the CPP_I section my $start_cpp = qr/(?:^|\n)[ \t]*## *CPP_I_START *\n/si; my $stop_cpp = qr/[ \t]*## *CPP_I_END *\n/si; my $pfx = qr/.*?(?=(?:^|\n)[ \t]*## *CPP_I_START)/si; if ($verbose > 10) { print "start_cpp = $start_cpp\n"; print "stop_cpp = $stop_cpp\n"; print " pfx = $pfx\n"; } my @cpp_i = extract_tagged($job,$start_cpp,$stop_cpp,$pfx); print "extract_tagged: ",$@,"\n" if scalar($@); my $CPP_I = $cpp_i[4]; if ($verbose > 1 and $CPP_I) {print "CPP_I section:\n$CPP_I\n"} print "CPP_I is missing from the parmsub section\n" unless $CPP_I; my $job_out = $cpp_i[2] . "\n" . $cpp_i[1] . "\n"; if ($verbose > 10) { use Data::Dumper 'Dumper'; print Dumper [ @cpp_i ]; } return wantarray ? ($CPP_I, $job_out) : $CPP_I; } #xxx sub ccc_parse { #xxx use strict; #xxx my $file = shift; #xxx my $string = shift; #xxx my $OPTS = shift; #xxx # Split the input job string into sections. #xxx # #xxx # An array of hashes is returned with each element containing #xxx # information about 1 section of the job string. #xxx #xxx # The string is first divided into jobs delimited at the end #xxx # by "#end_of_job". Each of these jobs is then divided into sections #xxx # by first separating out (possibly nested) here documents, then by #xxx # identifying parmsub, condef and update sections. #xxx #xxx my $verbose = 0; #xxx $verbose = $OPTS->{VERBOSE} if defined $OPTS->{VERBOSE}; #xxx #xxx # remove_cpp_i is a boolean flag to indicate whether or not we remove #xxx # the cpp_I section (if any) from wherever it appears in the job string #xxx my $remove_cpp_i = 0; #xxx $remove_cpp_i = $OPTS->{REMOVE_CPP_I} if defined $OPTS->{REMOVE_CPP_I}; #xxx #xxx # $parent is the name of the section surrounding the current job. #xxx # It could be this job or a file. #xxx my $parent = "file::$file"; #xxx # $parent = $OPTS->{PARENT} if defined $OPTS->{PARENT}; #xxx #xxx # $level indicates the depth into the tree, staring from level 0. #xxx my $level = 0; #xxx # $level = 1 + $OPTS->{LEVEL} if defined $OPTS->{LEVEL}; #xxx #xxx # $with_here_delim determines whether the body of the here document #xxx # is written to the output hash with or without the initial #xxx # "cat ...>>..." line and final document end delimiter line. #xxx my $with_here_delim = 0; #xxx $with_here_delim = $OPTS->{WITH_HERE_DELIM} #xxx if defined $OPTS->{WITH_HERE_DELIM}; #xxx #xxx my @OUT = (); #xxx #xxx # Split the input string into jobs delimited at the end by lines that #xxx # start with "#end_of_job" (space is optional around the "#") #xxx foreach (split(/^\s*#\s*end_of_job/mi, $string)) { #xxx my $curr_job = $_; #xxx # replace comment lines with empty lines #xxx $curr_job =~ s/^\s*#.*$//mg; #xxx # remove all white space #xxx $curr_job =~ s/\s//sg; #xxx # If nothing is left then ignore this job #xxx next unless $curr_job; #xxx # strip trailing white space and replace the "#end_of_job" delimiter #xxx s/\s+$/\n/s; #xxx my $job = "$_\n#end_of_job\n"; #xxx my $jobname = "job::main"; #xxx #xxx if ($remove_cpp_i) { #xxx # Remove any CPP_I section that may appear in this job #xxx my ($CPP_I, $xjob) = rip_cpp_i($job); #xxx $job = $xjob; #xxx undef $xjob; #xxx } #xxx #xxx # Define hash elements #xxx my $sec = {}; #xxx $sec->{name} = $jobname; #xxx $sec->{type} = /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = ''; #xxx $sec->{level} = $level; #xxx $sec->{body} = $job; #xxx $sec->{child} = ''; #xxx #xxx # Check this job for the presence of here documents #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$jobname, #xxx LEVEL=>$level, WITH_HERE_DELIM=>$with_here_delim}; #xxx my @HEREDOCS = split_here_doc($job, $subOPTS); #xxx if (scalar(@HEREDOCS) > 1) { #xxx # If any here documents are found in this job (scalar(@HEREDOCS) > 1) #xxx # then add the array of hashes returned from split_here_doc as a #xxx # child of the current job. #xxx $sec->{child} = [ @HEREDOCS ]; #xxx if ($verbose > 5) {print "CHILD:\n@HEREDOCS\n"}; #xxx } else { #xxx # If there were no here documents in this job then split it #xxx # into sections with rip_job_sections #xxx my @SECTIONS = rip_job_sections($job, $subOPTS); #xxx # Add the child if anything at all (scalar(@SECTIONS) > 0) #xxx # is returned from rip_job_sections #xxx if (scalar(@SECTIONS) > 0) { #xxx $sec->{child} = [ @SECTIONS ]; #xxx if ($verbose > 5) {print "CHILD:\n@SECTIONS\n"} #xxx } #xxx } #xxx push @OUT, $sec; #xxx } #xxx #xxx return @OUT; #xxx } #xxx #xxx sub split_here_doc { #xxx use strict; #xxx my $job = shift; #xxx my $OPTS = shift; #xxx # Split the input string into sections delimited by the #xxx # beginning and end of any here documents. #xxx # #xxx # An array of hashes is returned with each element containing #xxx # information about 1 section of the input string. A section is #xxx # either part of a here document or a part of the string that #xxx # is outside of any here document. #xxx #xxx my $verbose = 0; #xxx $verbose = $OPTS->{VERBOSE} if defined $OPTS->{VERBOSE}; #xxx #xxx # $parent is the name of the section surrounding the current #xxx # here document. It could be another here document or a job. #xxx # By default it is the name of the calling routine #xxx my ($package, $file, $line, $parent) = caller(1); #xxx $parent = $OPTS->{PARENT} if defined $OPTS->{PARENT}; #xxx #xxx # $level indicates the depth into the tree, staring from level 0. #xxx my $level = 0; #xxx $level = 1 + $OPTS->{LEVEL} if defined $OPTS->{LEVEL}; #xxx #xxx # $with_here_delim determines whether the body of the here document #xxx # is written to the output hash with or without the enclosing #xxx # first "cat ...>>..." line and document end delimiters. #xxx my $with_here_delim = 0; #xxx $with_here_delim = $OPTS->{WITH_HERE_DELIM} #xxx if defined $OPTS->{WITH_HERE_DELIM}; #xxx #xxx my $nested = 0; #xxx $nested = $OPTS->{NESTED} if defined $OPTS->{NESTED}; #xxx #xxx my @OUT = (); #xxx my $end_cat = ''; #xxx my $section = ''; #xxx my $here_file_name = $parent; #xxx # Define a regex that will match a possibly quoted file name #xxx my $exrex = q!(`[^`]*`|'[^']*'|"[^"]*"|[\w\.\$/-]+)!; #xxx # loop through the input string line by line #xxx foreach my $line (split '\n', $job) { #xxx unless ($end_cat and $line =~ /^\s*cat([\s><]|\d[><]|&>|$)/) { #xxx if (my ($ecat) = $line =~ m!^\s*cat.*<<\s*('[^']*'|"[^"]*"|[\w\.\$/-]+)!) { #xxx $ecat =~ s/^'(.*)'$/$1/; #xxx $ecat =~ s/^"(.*)"$/$1/; #xxx # Top of a here doc #xxx unless ($section =~ /^\s*$/) { #xxx # Append the previous section to the output array #xxx # but only if it contains non white space #xxx my $sec = {}; #xxx $sec->{name} = $parent; #xxx ($sec->{type}) = $parent =~ /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = $end_cat; #xxx $sec->{level} = $level; #xxx $sec->{body} = $section; #xxx $sec->{child} = ''; #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$here_file_name, #xxx LEVEL=>$level}; #xxx my @SECTIONS = rip_job_sections($section, $subOPTS); #xxx # Add the child if anything at all (scalar(@SECTIONS) > 0) #xxx # is returned from rip_job_sections #xxx if (scalar(@SECTIONS) > 0) { #xxx $sec->{child} = [ @SECTIONS ]; #xxx if ($verbose > 5) {print "CHILD:\n@SECTIONS\n"} #xxx } #xxx push @OUT, $sec; #xxx } #xxx # Reinitialize current values #xxx $end_cat = $ecat; #xxx if ($with_here_delim) { #xxx $section = "$line\n"; #xxx } else { #xxx $section = ''; #xxx } #xxx # Incorporate the output file name into the name of this here doc #xxx ($here_file_name) = $line =~ m!^\s*cat.*>\s*$exrex!; #xxx $here_file_name =~ s/^'(.*)'$/$1/ if $here_file_name; #xxx $here_file_name =~ s/^"(.*)"$/$1/ if $here_file_name; #xxx $here_file_name = 'STDIN' unless $line =~ />/; #xxx $here_file_name = 'heredoc::' . $here_file_name; #xxx if ($verbose > 5) { #xxx print "$line\n"; #xxx print " here_file_name=$here_file_name"; #xxx print " end_cat=$end_cat"; #xxx print " parent=$parent\n"; #xxx } #xxx next; #xxx } #xxx } #xxx if ($end_cat and $line =~ /^$end_cat/) { #xxx # end of here document #xxx if ($with_here_delim) { #xxx $section .= "$line\n"; #xxx } #xxx unless ($section =~ /^\s*$/) { #xxx # Append the previous section to the output array #xxx # but only if it contains non white space #xxx my $hdoc = $section; #xxx # strip the first "cat ..." line and the #xxx # end delimiter from the here document #xxx my $sec = {}; #xxx $sec->{name} = $here_file_name; #xxx ($sec->{type}) = $here_file_name =~ /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = $end_cat; #xxx $sec->{level} = $level; #xxx $sec->{body} = $section; #xxx $sec->{child} = ''; #xxx # Ensure that the first "cat ..." line and the document end #xxx # delimiter are stripped from the body of the here doc. #xxx $hdoc =~ s/^\s*cat[^\n]*\n//s; #xxx $hdoc =~ s/\n$end_cat[^\n]*$//s; #xxx if ($nested) { #xxx # If any nested here documents are found (scalar(@HEREDOCS) > 1) #xxx # then add the array of hashes returned from split_here_doc as a #xxx # child of the current here document. #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$here_file_name, #xxx LEVEL=>$level, WITH_HERE_DELIM=>$with_here_delim}; #xxx my @HEREDOCS = split_here_doc($hdoc, $subOPTS); #xxx if (scalar(@HEREDOCS) > 1) { #xxx $sec->{child} = [ @HEREDOCS ]; #xxx if ($verbose > 5) {print "CHILD:\n@HEREDOCS\n"} #xxx } else { #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$here_file_name, #xxx LEVEL=>$level}; #xxx my @SECTIONS = rip_job_sections($hdoc, $subOPTS); #xxx # Add the child if anything at all (scalar(@SECTIONS) > 0) #xxx # is returned from rip_job_sections #xxx if (scalar(@SECTIONS) > 0) { #xxx $sec->{child} = [ @SECTIONS ]; #xxx if ($verbose > 5) {print "CHILD:\n@SECTIONS\n"} #xxx } else { #xxx $sec->{child} = ''; #xxx } #xxx } #xxx } else { #xxx # Do not extract nested here documents #xxx # Split $hdoc into sections the begin with a line the form /^ *###.*$regex/ #xxx # where $regex is one of gcmparm, parmsub, condef, update.*script, #xxx # update.*model, update.*sub, update.*ocean or update.*ocean.*sub #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$here_file_name, #xxx LEVEL=>$level}; #xxx my @SECTIONS = rip_job_sections($hdoc, $subOPTS); #xxx # Add the child if anything at all (scalar(@SECTIONS) > 0) #xxx # is returned from rip_job_sections #xxx if (scalar(@SECTIONS) > 0) { #xxx $sec->{child} = [ @SECTIONS ]; #xxx if ($verbose > 5) {print "CHILD:\n@SECTIONS\n"} #xxx } #xxx } #xxx push @OUT, $sec; #xxx } #xxx # Initialize current values #xxx $end_cat = ''; #xxx $section = ''; #xxx $here_file_name = "$parent"; #xxx next; #xxx } #xxx $section .= "$line\n"; #xxx } #xxx #xxx if ($end_cat) { #xxx # The string finished with a open here document #xxx die "Syntax error in job string. Incomplete here document.\n Stopped"; #xxx } #xxx #xxx if ($section) { #xxx unless ($section =~ /^\s*$/) { #xxx # Append the previous section to the output array #xxx # but only if it contains non white space #xxx my $sec = {}; #xxx $sec->{name} = $here_file_name; #xxx ($sec->{type}) = $here_file_name =~ /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = $end_cat; #xxx $sec->{level} = $level; #xxx $sec->{body} = $section; #xxx $sec->{child} = ''; #xxx my $subOPTS = {VERBOSE=>$verbose, PARENT=>$here_file_name, #xxx LEVEL=>$level}; #xxx my @SECTIONS = rip_job_sections($section, $subOPTS); #xxx # Add the child if anything at all (scalar(@SECTIONS) > 0) #xxx # is returned from rip_job_sections #xxx if (scalar(@SECTIONS) > 0) { #xxx $sec->{child} = [ @SECTIONS ]; #xxx if ($verbose > 5) {print "CHILD:\n@SECTIONS\n"} #xxx } #xxx push @OUT, $sec; #xxx } #xxx } #xxx #xxx return @OUT; #xxx } #xxx #xxx sub rip_job_sections { #xxx use strict; #xxx my $string = shift; #xxx my $OPTS = shift; #xxx # Split the input string into sections that begin with a line #xxx # of the form /^ *###.*$regex/ and end with either one of these header #xxx # lines or a line of the form /^ *end_of_data *$/ or /^ *# *end_of_job *$/. #xxx # Here regex is one of gcmparm, parmsub, condef, update.*script, #xxx # update.*model, update.*sub, update.*ocean or update.*ocean.*sub #xxx # #xxx # An array of hashes is returned with each element containing #xxx # information about 1 section of the job string. #xxx #xxx my $verbose = 0; #xxx $verbose = $OPTS->{VERBOSE} if defined $OPTS->{VERBOSE}; #xxx #xxx # $parent is the name of the section surrounding the current #xxx # here document. It could be another here document or a job. #xxx # By default it is the name of the calling routine #xxx my ($package, $file, $line, $parent) = caller(1); #xxx $parent = $OPTS->{PARENT} if defined $OPTS->{PARENT}; #xxx #xxx # $level indicates the depth into the tree, staring from level 0. #xxx my $level = 0; #xxx $level = 1 + $OPTS->{LEVEL} if defined $OPTS->{LEVEL}; #xxx #xxx # $with_parmsub determines whether gcmparm, parmsub and condef will #xxx # be returned as individual sections or returned as a single section. #xxx my $with_parmsub = 0; #xxx $with_parmsub = $OPTS->{WITH_PARMSUB} if defined $OPTS->{WITH_PARMSUB}; #xxx #xxx # $with_updates determines whether all update sections will be #xxx # returned as individual sections or returned as a single section. #xxx my $with_update = 1; #xxx $with_update = $OPTS->{WITH_UPDATE} if defined $OPTS->{WITH_UPDATE}; #xxx #xxx # first_sec is a boolean flag to identify the first non-update section #xxx my $first_sec=1; #xxx #xxx my @OUT = (); #xxx my $section_name = "sec::shell"; #xxx my $section = ''; #xxx foreach (split /\n/, $string) { #xxx my $sname = ''; #xxx if ($with_parmsub) { #xxx if (($sname) = /^\s*###.*(gcmparm)/i or #xxx ($sname) = /^\s*###.*(parmsub)/i or #xxx ($sname) = /^\s*###.*(condef)/i) {my $xxx=0} #xxx } #xxx if ($with_update and not $sname) { #xxx if (($sname) = /^\s*###.*(update.*script)/i or #xxx ($sname) = /^\s*###.*(update.*model)/i or #xxx ($sname) = /^\s*###.*(update.*sub)/i or #xxx ($sname) = /^\s*###.*(update.*ocean)/i or #xxx ($sname) = /^\s*###.*(update.*ocean.*sub)/i) {my $xxx=0} #xxx } #xxx if ($sname) { #xxx # Do not return a section containing only white space #xxx unless ($section =~ /^\s*$/) { #xxx my $sec = {}; #xxx $sec->{name} = $section_name; #xxx if ($first_sec) { #xxx $first_sec = 0; #xxx if ($section_name !~ /^.*?::\s*update/ and #xxx $section !~ /^\s*end_of_data/si) { #xxx $sec->{name} = "${section_name}-param" #xxx } #xxx } #xxx ($sec->{type}) = $section_name =~ /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = ''; #xxx $sec->{level} = $level; #xxx $sec->{body} = $section; #xxx $sec->{child} = ''; #xxx push @OUT, $sec; #xxx } #xxx #xxx # Reinitialize section variables #xxx $section_name = "sec::$sname"; #xxx $section = "$_\n"; #xxx } else { #xxx $section .= "$_\n"; #xxx } #xxx } #xxx if ($section) { #xxx # Do not return a section containing only white space #xxx unless ($section =~ /^\s*$/) { #xxx my $sec = {}; #xxx $sec->{name} = $section_name; #xxx if ($first_sec) { #xxx $first_sec = 0; #xxx if ($section_name !~ /^.*?::\s*update/ and #xxx $section !~ /^\s*end_of_data/si) { #xxx $sec->{name} = "${section_name}-param" #xxx } #xxx } #xxx ($sec->{type}) = $section_name =~ /^.*?::\s*(\w+)/; #xxx $sec->{parent} = $parent; #xxx $sec->{delimiter} = ''; #xxx $sec->{level} = $level; #xxx $sec->{body} = $section; #xxx $sec->{child} = ''; #xxx push @OUT, $sec; #xxx } #xxx } #xxx #xxx return @OUT; #xxx } #xxx #xxx sub print_jobs { #xxx use strict; #xxx my $JOBS = shift; #xxx my $OPTS = shift; #xxx #xxx my $verbose = 0; #xxx $verbose = $OPTS->{VERBOSE} if defined $OPTS->{VERBOSE}; #xxx #xxx my $prefix = '- '; #xxx $prefix = $OPTS->{PREFIX} if defined $OPTS->{PREFIX}; #xxx #xxx my $lines = 10; #xxx $lines = $OPTS->{LINES} if defined $OPTS->{LINES}; #xxx #xxx use vars q($first_prefix); #xxx $first_prefix = $prefix unless $first_prefix; #xxx #xxx foreach my $job (@$JOBS) { #xxx print "\n${prefix}","="x80,"\n"; #xxx printf "${prefix} NAME: %s\n",$job->{name} ? $job->{name} : ""; #xxx printf "${prefix} TYPE: %s\n",$job->{type} ? $job->{type} : ""; #xxx printf "${prefix} PARENT: %s\n",$job->{parent} ? $job->{parent} : ""; #xxx printf "${prefix} LEVEL: %s\n",$job->{level} ? $job->{level} : ""; #xxx printf "${prefix}DELIMITER: %s\n",$job->{delimiter} ? $job->{delimiter} : ""; #xxx if ($job->{child}) { #xxx print_jobs($job->{child}, {PREFIX => "$prefix$first_prefix", LINES => $lines}); #xxx } elsif ($lines > 0) { #xxx printf "${prefix} BODY:\n"; #xxx if ($job->{body}) { #xxx my $k = 0; #xxx foreach (split '\n',$job->{body}) { #xxx $k++; #xxx last if $k > $lines; #xxx print "$_\n"; #xxx } #xxx } #xxx } elsif ($lines < 0) { #xxx # Print all lines in the body #xxx printf "${prefix} BODY:\n%s\n",$job->{level} ? $job->{level} : "";; #xxx } #xxx } #xxx } sub model_job_to_cpp_sizes { # Read a model job string to extract parmsub info and the CPP_I section # This info is used to create cppdefs_file and/or sizes_file if they do not # already exists. # As a side effect the parmsub hash is defined and will contain all parmsub # parameters that were defined in the input model job string use strict; my $model_job_file = shift; # Read the first part of the model job string into memory # Stop reading at the first update section or the end of the # first job in the string, whichever comes first # For a "normal" model job string this will include the entire parmsub # section as well as any lines prior to the Model_Input here document my $fsrc = ''; my $found_update_section = 0; open (FILE, "<$model_job_file") || die "$!"; while () { # Ignore any lines that would start a here document next if /^cat[\s><]+\w+[\s><]+/; # Expand tabs as each line is read $fsrc .= expand($_); # Only read, at most, the first job from this file last if /^# *end_of_job\s*$/; # Stop at the beginning of the first update section if ( /^###[#\s]*update\s+/ ) { $found_update_section = 1; last; } } close FILE; warn "** WW ** No update sections were found in $model_job_file. This may not be a model job string.\n" unless $found_update_section; # Extract all shell variables found in this script and assign them to parmsub # Also return strings containing the input script without the CPP_I section # as well as the CPP_I section alone (if any) my ($parmsub_ref, $script, $CPP_I) = shvals( $fsrc ); die "Unable to read any variable defs from $model_job_file.\n" unless $parmsub_ref; %parmsub = %{$parmsub_ref}; undef $parmsub_ref; unless ( $cppdefs_file ) { # If the user has not supplied a cppdefs file then create one # using the CPP_I section found in the user supplied model_job_file if ( $CPP_I ) { # Don't bother unless CPP_I is present in the model_job_file $cppdefs_file = $parmsub{runid} ? "CPP_I_$parmsub{runid}": "CPP_I_$stamp"; open( CPPDEFS, ">$cppdefs_file") or die "$!"; print CPPDEFS "$CPP_I\n"; close(CPPDEFS); # Now make cppdefs_file absolute # $cppdefs_file = abs_path( $cppdefs_file ); } } unless ( $sizes_file ) { # Create a sizes file from info in this model_job file # This requires 2 programs to be on the users path # gcmparm_input # gcmparm # If either of these are missing one of the following system calls will fail # Create a disk file containing the parmsub section # with any CPP_I section removed my $parmsub_tmp = "parmsub_$stamp"; open( PARMTMP, ">$parmsub_tmp") or die "$!"; print PARMTMP "$script\n"; close(PARMTMP); # This command will create a file named gcmparmin_tmp my $gcmparmin_tmp = "gcmparmin_$stamp"; syscmd( "gcmparm_input $parmsub_tmp outfile=$gcmparmin_tmp" ); # Remove the temporary parmsub_tmp file unlink $parmsub_tmp or die "Unable to remove $parmsub_tmp. Stopped"; # This command will use gcmparmin_tmp to create the sizes file $sizes_file = $parmsub{runid} ? "sizes_$parmsub{runid}": "sizes_$stamp"; syscmd( "gcmparm $sizes_file < $gcmparmin_tmp" ); # Remove the temporary gcmparmin_tmp file unlink $gcmparmin_tmp or die "Unable to remove $gcmparmin_tmp. Stopped"; # Add a value for NRFP to the sizes file my $NRFP = $parmsub{NRFP} ? $parmsub{NRFP} : 1; syscmd( "echo \"NRFP = $NRFP\" >> $sizes_file" ); } return 1; } ########################################################################### #--- BEGIN --- replace embedded "$" delimited text strings from sizes file ########################################################################### sub def_param_using_sizes { use strict; my $sizes_file = shift; die "sizes_file is missing.\n" unless $sizes_file; open(FILE, "<$sizes_file") or die "def_param_using_sizes: ** EE ** Opening ${sizes_file}: $!\n"; while () { my ($par, $val) = split /=/; # Remove leading and trailing white space from the parameter name $par =~ s/^\s*(.*?)\s*$/$1/; # All param keys will be lower case $par = lc($par); # The sizes file may have a trailing comma on each line, if so remove it $val =~ s/,\s*$//; if ( $par eq "com" or $par eq "csl" or $par eq "csp" or $par eq "csn" ) { # These parameter values are all 5 character strings $val = sprintf("%5.5s",$val); } else { # Otherwise remove leading and trailing white space $val =~ s/^\s*(.*?)\s*$/$1/; } die "Missing value for parameter $par found in file $sizes_file.\n" if $val eq ''; $param{$par} = $val; } close(FILE); if ( $verbose > 10 ) { foreach (sort keys %param) { printf "param{%10s} ==>%s<==\n", $_, $param{$_}; } } return 1; } sub rm_comments_from_line { # Remove any '!' delimited comments from a single fortran source line # The input line may not contain any newlines use strict; my $line = shift; # Ensure no newlines exists die "rm_comments_from_line: The input -->\n$line\n<-- contains a newline\n" if $line =~ /\n/; # Store the comment string so that is may be returned, if requested my $comment = ''; # Do nothing unless the line contains a '!' character if ($line =~ /!/) { # Remove '!' delimited comments my $line_in = $line; # remove all single quoted strings on each line $line_in =~ s/'[^']*'//g; # remove all double quoted strings on each line $line_in =~ s/"[^"]*"//g; if ($line_in =~ /!/) { # If there is still a "!" after removing quoted segments then # detemine what part of the line is the comment ($comment) = $line_in =~ /(!.*)$/; # Remove this comment $line =~ s/^(.*)\Q$comment\E$/$1/; } } return wantarray ? ($line, $comment) : $line; } sub replace_ddelim { # Replace any "$" delimited text strings found in the input source # Use one of 2 methods: # 1) Replacement values are found in the global param hash # 2) Replace $...$ with a cpp token named _PAR_... use strict; my $fsrc = shift; my $fname = shift; my $tmpfsrc = ''; my $tokdefs = ''; my %all_par_this_file; foreach my $line (split "\n",$fsrc) { if ($line =~ /^[c#!*%]/i) { # Pass comment and preprocessor lines through unaltered $tmpfsrc .= "$line\n"; next; } # Get a list of all "$" delimited parameters found on this line my @par_name = $line =~ /\$(.+?)\$/g; unless (scalar(@par_name)) { # Do nothing to lines that do not contain "$" delimited parameters $tmpfsrc .= "$line\n"; next; } # Ensure that all "$" delimited parameters found on this line # are defined in the param hash foreach my $par (@par_name) { # param keys are lower case so convert $par to lc before testing warn "** WW ** The \"\$...\$\" delimited parameter $par is not defined \t...found in $fname.\n" unless defined $param{"\L$par"}; # Flag this as a parameter found in the current file $all_par_this_file{$par} = 1; } if ($param_replace_with_token) { # Define a list of tokens to insert as replacements for the $...$ strings my @tokname = map "_PAR_$_", @par_name; # append these defines to the list of token defs foreach (@tokname) { my ($par) = $_ =~ /^_PAR_(.*)$/; $par = "\L$par"; my $val = ''; $val = $param{$par} if defined $param{$par}; $tokdefs .= "!!--- NEW: #define $_ $val\n"; } # replace all parameters in the current line with tokens $line =~ s/\$(.+?)\$/_PAR_$1/gi; } else { # replace all parameters in the current line with values # Note: param keys are lower case so the back substitution is converted to lc # Simply ignore this substitution if the parameter is not defined in %param $line =~ s/\$(.+?)\$/$param{"\L$1"}/g if defined $param{"\L$1"}; } # $comm is a trailing ! delimited comment, if any, on the current line # $fline is the current line with any trailing comment stripped my ($fline, $comm) = rm_comments_from_line($line); if (length($fline) > 72) { # continue lines that have expanded to greater than 72 characters my $part1 = ''; my $part2 = ''; foreach (split '', $fline) { print "part:$_\n"; if ($part2 or (length($part1) + length($_) > 72)) { $part2 .= $_; } else { $part1 .= $_; } } $tmpfsrc .= "$part1\n"; $tmpfsrc .= " & $part2 $comm\n"; } else { # simply append the modified line as is $tmpfsrc .= "$line\n"; } } if ($param_replace_with_token) { # Prepend a comment about any tokens that were inserted in place of $...$ substr($tmpfsrc,0,0) = $tokdefs if $tokdefs; } if ( $verbose > 10 ) { foreach (sort keys %all_par_this_file) { print "Replaced \"\$$_\$\" in $fname\n"; } } return $tmpfsrc; } ########################################################################### #--- END --- replace embedded "$" delimited text strings from sizes file ###########################################################################