forked from CESM-Development/cime
-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
917827d
commit 74d7c47
Showing
1 changed file
with
387 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,387 @@ | ||
| #!/usr/bin/env perl | ||
| use strict; | ||
| my $outfile; | ||
| # Beginning with F90, Fortran has strict typing of variables based on "TKR" | ||
| # (type, kind, and rank). In many cases we want to write subroutines that | ||
| # provide the same functionality for different variable types and ranks. In | ||
| # order to do this without cut-and-paste duplication of code, we create a | ||
| # template file with the extension ".F90.in", which can be parsed by this script | ||
| # to generate F90 code for all of the desired specific types. | ||
| # | ||
| # Keywords are delimited by curly brackets: {} | ||
| # | ||
| # {TYPE} and {DIMS} are used to generate the specific subroutine names from the | ||
| # generic template | ||
| # {TYPE} : Variable type name; implemented types are character, 4 or 8 byte real, | ||
| # and 4 or 8 byte integer. | ||
| # allowed values: text, real, double, int, long, logical | ||
| # default values: text, real, double, int | ||
| # {VTYPE} : Used to generate variable declarations to match the specific type. | ||
| # if {TYPE}=double then {VTYPE} is "real(r8)" | ||
| # {ITYPE}, {ITYPENAME} : Used to generate CPP statements for the specific type. | ||
| # {MPITYPE} : Used to generate MPI types corresponding to the specific type. | ||
| # | ||
| # {DIMS} : Rank of arrays, "0" for scalar. | ||
| # allowed values: 0-7 | ||
| # default values : 0-5 | ||
| # {DIMSTR} : Generates the parenthesis and colons used for a variable | ||
| # declaration of {DIMS} dimensions. | ||
| # if {DIMS}=3 then {DIMSTR} is (:,:,:) | ||
| # {REPEAT} : Repeats an expression for each number from 1 to {DIMS}, with each | ||
| # iteration separated by commas. | ||
| # {REPEAT: foo(#, bar)} | ||
| # expands to this: | ||
| # foo(1, bar), foo(2, bar), foo(3, bar), ... | ||
|
|
||
| # defaults | ||
| my @types = qw(text real double int); | ||
| my $vtype = {'text' => 'character(len=*)', | ||
| 'real' => 'real(r4)', | ||
| 'double' => 'real(r8)', | ||
| 'int' => 'integer(i4)', | ||
| 'long' => 'integer(i8)', | ||
| 'logical' => 'logical' }; | ||
| my $itype = {'text' => 100, | ||
| 'real' => 101, | ||
| 'double' => 102, | ||
| 'int' => 103, | ||
| 'long' => 104, | ||
| 'logical' => 105}; | ||
| my $itypename = {'text' => 'TYPETEXT', | ||
| 'real' => 'TYPEREAL', | ||
| 'double' => 'TYPEDOUBLE', | ||
| 'int' => 'TYPEINT', | ||
| 'long' => 'TYPELONG', | ||
| 'logical' => 'TYPELOGICAL'}; | ||
| my $mpitype = {'text' => 'MPI_CHARACTER', | ||
| 'real' => 'MPI_REAL4', | ||
| 'double' => 'MPI_REAL8', | ||
| 'int' => 'MPI_INTEGER'}; | ||
| # Netcdf C datatypes | ||
| my $nctype = {'text' => 'text', | ||
| 'real' => 'float', | ||
| 'double' => 'double', | ||
| 'int' => 'int'}; | ||
| # C interoperability types | ||
| my $ctype = {'text' => 'character(C_CHAR)', | ||
| 'real' => 'real(C_FLOAT)', | ||
| 'double' => 'real(C_DOUBLE)', | ||
| 'int' => 'integer(C_INT)'}; | ||
|
|
||
|
|
||
|
|
||
| my @dims =(0..5); | ||
|
|
||
| my $write_dtypes = "no"; | ||
| # begin | ||
|
|
||
| foreach(@ARGV){ | ||
| my $infile = $_; | ||
| usage() unless($infile =~ /(.*.F90).in/); | ||
| $outfile = $1; | ||
| open(F,"$infile") || die "$0 Could not open $infile to read"; | ||
| my @parsetext; | ||
| my $cnt=0; | ||
| foreach(<F>){ | ||
| $cnt++; | ||
| if(/^\s*contains/i){ | ||
| push(@parsetext,"# $cnt \"$infile\"\n"); | ||
| } | ||
| if(/^\s*interface/i){ | ||
| push(@parsetext,"# $cnt \"$infile\"\n"); | ||
| } | ||
| if(/^[^!]*subroutine/i){ | ||
| push(@parsetext,"# $cnt \"$infile\"\n"); | ||
| } | ||
| if(/^[^!]*function/i){ | ||
| push(@parsetext,"# $cnt \"$infile\"\n"); | ||
| } | ||
|
|
||
| push(@parsetext,$_); | ||
| } | ||
|
|
||
| close(F); | ||
|
|
||
| my $end; | ||
| my $contains=0; | ||
| my $in_type_block=0; | ||
| my @unit; | ||
| my $unitcnt=0; | ||
| my $date = localtime(); | ||
| my $preamble = | ||
| "!=================================================== | ||
| ! DO NOT EDIT THIS FILE, it was generated using $0 | ||
| ! Any changes you make to this file may be lost | ||
| !===================================================\n"; | ||
| my @output ; | ||
| push(@output,$preamble); | ||
|
|
||
| my $line; | ||
| my $dimmodifier; | ||
| my $typemodifier; | ||
| my $itypeflag; | ||
| my $block; | ||
| my $block_type; | ||
| my $cppunit; | ||
| foreach $line (@parsetext){ | ||
| # skip parser comments | ||
| next if($line =~ /\s*!pl/); | ||
|
|
||
| $itypeflag=1 if($line =~ /{ITYPE}/); | ||
| $itypeflag=1 if($line =~ /TYPETEXT/); | ||
| $itypeflag=1 if($line =~ /TYPEREAL/); | ||
| $itypeflag=1 if($line =~ /TYPEDOUBLE/); | ||
| $itypeflag=1 if($line =~ /TYPEINT/); | ||
| $itypeflag=1 if($line =~ /TYPELONG/); | ||
|
|
||
|
|
||
| if($contains==0){ | ||
| if($line=~/\s*!\s*DIMS\s+[\d,]+!*/){ | ||
| $dimmodifier=$line; | ||
| next; | ||
| } | ||
| if($line=~/\s*!\s*TYPE\s+[^!]+!*$/){ | ||
| $typemodifier=$line; | ||
| next; | ||
| } | ||
| if ((defined $typemodifier or defined $dimmodifier) | ||
| and not defined $block and $line=~/^\s*#[^{]*$/) { | ||
| push(@output, $line); | ||
| next; | ||
| } | ||
| # Figure out the bounds of a type statement. | ||
| # Type blocks start with "type," "type foo" or "type::" but not | ||
| # "type(". | ||
| $in_type_block=1 if($line=~/^\s*type\s*[,:[:alpha:]]/i); | ||
| $in_type_block=0 if($line=~/^\s*end\s*type/i); | ||
| if(not defined $block) { | ||
| if ($line=~/^\s*type[^[:alnum:]_].*(\{TYPE\}|\{DIMS\})/i or | ||
| $line=~/^[^!]*(function|subroutine).*(\{TYPE\}|\{DIMS\})/i) { | ||
| $block=$line; | ||
| next; | ||
| } | ||
| if ($line=~/^\s*interface.*(\{TYPE\}|\{DIMS\})/i) { | ||
| $block_type="interface"; | ||
| $block=$line; | ||
| next; | ||
| } | ||
| } | ||
| if(not defined $block_type and | ||
| ($line=~/^\s*end\s+type\s+.*(\{TYPE\}|\{DIMS\})/i or | ||
| $line=~/^\s*end\s+(function|subroutine)\s+.*(\{TYPE\}|\{DIMS\})/i)){ | ||
|
|
||
| $line = $block.$line; | ||
| undef $block; | ||
| } | ||
| if ($line=~/^\s*end\s*interface/i and | ||
| defined $block) { | ||
| $line = $block.$line; | ||
| undef $block; | ||
| undef $block_type; | ||
| } | ||
| if(defined $block){ | ||
| $block = $block.$line; | ||
| next; | ||
| } | ||
| if(defined $dimmodifier){ | ||
| $line = $dimmodifier.$line; | ||
| undef $dimmodifier; | ||
| } | ||
| if(defined $typemodifier){ | ||
| $line = $typemodifier.$line; | ||
| undef $typemodifier; | ||
| } | ||
|
|
||
| push(@output, buildout($line)); | ||
| if(($line =~ /^\s*contains\s*!*/i && ! $in_type_block) or | ||
| ($line =~ /^\s*!\s*Not a module/i)){ | ||
| $contains=1; | ||
| next; | ||
| } | ||
| } | ||
| if($line=~/^\s*end module\s*/){ | ||
| $end = $line; | ||
| last; | ||
| } | ||
|
|
||
| if($contains==1){ | ||
| # first parse into functions or subroutines | ||
| if($cppunit || !(defined($unit[$unitcnt]))){ | ||
| # Make cpp lines and blanks between routines units. | ||
| if($line =~ /^\s*\#(?!\s[[:digit:]]+)/ || $line =~/^\s*$/ || $line=~/^\s*!(?!\s*(TYPE|DIMS))/){ | ||
| push(@{$unit[$unitcnt]},$line); | ||
| $cppunit=1; | ||
| next; | ||
| } else { | ||
| $cppunit=0; | ||
| $unitcnt++; | ||
| } | ||
| } | ||
|
|
||
|
|
||
| push(@{$unit[$unitcnt]},$line); | ||
| if ($line=~/^\s*interface/i) { | ||
| $block_type="interface"; | ||
| $block=$line; | ||
| } | ||
| if ($line=~/^\s*end\s*interface/i) { | ||
| undef $block_type; | ||
| undef $block; | ||
| } | ||
| unless(defined $block){ | ||
| if($line =~ /\s*end function/i or $line =~ /\s*end subroutine/i){ | ||
| $unitcnt++; | ||
| } | ||
| } | ||
| } | ||
| } | ||
| my $i; | ||
|
|
||
|
|
||
| for($i=0;$i<$unitcnt;$i++){ | ||
| if(defined($unit[$i])){ | ||
| my $func = join('',@{$unit[$i]}); | ||
| push(@output, buildout($func)); | ||
| } | ||
| } | ||
| push(@output,@{$unit[$#unit]}) if($unitcnt==$#unit); | ||
| push(@output, $end); | ||
| if($itypeflag==1){ | ||
| my $str; | ||
| $str.="#include \"dtypes.h\"\n"; | ||
| $write_dtypes = "yes"; | ||
| print $str; | ||
| } | ||
| print @output; | ||
| writedtypes() if(!(-e "dtypes.h") && $write_dtypes == "yes"); | ||
|
|
||
|
|
||
| } | ||
|
|
||
|
|
||
| sub usage{ | ||
| die("$0 Expected input filename of the form .*.F90.in"); | ||
| } | ||
|
|
||
| sub build_repeatstr{ | ||
| my($dims) = @_; | ||
| # Create regex to repeat expression DIMS times. | ||
| my $repeatstr; | ||
| for(my $i=1;$i<=$dims;$i++){ | ||
| $repeatstr .="\$\{1\}$i\$\{2\},&\n"; | ||
| } | ||
| if(defined $repeatstr){ | ||
| $repeatstr="\"$repeatstr"; | ||
| chop $repeatstr; | ||
| chop $repeatstr; | ||
| chop $repeatstr; | ||
| $repeatstr.="\""; | ||
| }else{ | ||
| $repeatstr=''; | ||
| } | ||
| } | ||
|
|
||
| sub writedtypes{ | ||
| open(F,">dtypes.h"); | ||
| print F | ||
| "#define TYPETEXT 100 | ||
| #define TYPEREAL 101 | ||
| #define TYPEDOUBLE 102 | ||
| #define TYPEINT 103 | ||
| #define TYPELONG 104 | ||
| #define TYPELOGICAL 105 | ||
| "; | ||
| close(F); | ||
| } | ||
|
|
||
| sub buildout{ | ||
| my ($func) = @_; | ||
|
|
||
| my $outstr; | ||
| my(@ldims, @ltypes); | ||
|
|
||
| if($func=~/\s*!\s*DIMS\s+([\d,]+)\s*/){ | ||
| @ldims = split(/,/,$1); | ||
| }else{ | ||
| @ldims = @dims; | ||
| } | ||
| if($func=~/\s*!\s*TYPE\s+([^!\s]+)\s*/){ | ||
| @ltypes = split(/,/,$1); | ||
| # print ">$func<>@ltypes<\n"; | ||
| }else{ | ||
| @ltypes = @types; | ||
| } | ||
|
|
||
|
|
||
| if(($func =~ /{TYPE}/ && $func =~ /{DIMS}/) ){ | ||
| my ($type, $dims); | ||
| foreach $type (@ltypes){ | ||
| foreach $dims (@ldims){ | ||
| my $dimstr; | ||
| for(my $i=1;$i<=$dims;$i++){ | ||
| $dimstr .=':,'; | ||
| } | ||
| if(defined $dimstr){ | ||
| $dimstr="($dimstr"; | ||
| chop $dimstr; | ||
| $dimstr.=')'; | ||
| }else{ | ||
| $dimstr=''; | ||
| } | ||
|
|
||
| my $repeatstr = build_repeatstr($dims); | ||
|
|
||
| my $str = $func; | ||
| $str =~ s/{TYPE}/$type/g; | ||
| $str =~ s/{VTYPE}/$vtype->{$type}/g; | ||
| $str =~ s/{ITYPE}/$itype->{$type}/g; | ||
| $str =~ s/{MPITYPE}/$mpitype->{$type}/g; | ||
| $str =~ s/{NCTYPE}/$nctype->{$type}/g; | ||
| $str =~ s/{CTYPE}/$ctype->{$type}/g; | ||
| $str =~ s/{DIMS}/$dims/g; | ||
| $str =~ s/{DIMSTR}/$dimstr/g; | ||
| $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; | ||
| $outstr .= $str; | ||
| } | ||
| } | ||
| }elsif($func =~ /{DIMS}/){ | ||
| my $dims; | ||
| foreach $dims (@ldims){ | ||
| my $dimstr; | ||
| for(my $i=1;$i<=$dims;$i++){ | ||
| $dimstr .=':,'; | ||
| } | ||
| if(defined $dimstr){ | ||
| $dimstr="($dimstr"; | ||
| chop $dimstr; | ||
| $dimstr.=')'; | ||
| }else{ | ||
| $dimstr=''; | ||
| } | ||
|
|
||
| my $repeatstr = build_repeatstr($dims); | ||
|
|
||
| my $str = $func; | ||
| $str =~ s/{DIMS}/$dims/g; | ||
| $str =~ s/{DIMSTR}/$dimstr/g; | ||
| $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; | ||
| $outstr .= $str; | ||
| } | ||
| }elsif($func =~ /{TYPE}/){ | ||
| my ($type); | ||
| foreach $type (@ltypes){ | ||
| my $str = $func; | ||
| $str =~ s/{TYPE}/$type/g; | ||
| $str =~ s/{VTYPE}/$vtype->{$type}/g; | ||
| $str =~ s/{ITYPE}/$itype->{$type}/g; | ||
| $str =~ s/{MPITYPE}/$mpitype->{$type}/g; | ||
| $str =~ s/{NCTYPE}/$nctype->{$type}/g; | ||
| $str =~ s/{CTYPE}/$ctype->{$type}/g; | ||
| $outstr.=$str; | ||
| } | ||
| }else{ | ||
| $outstr=$func; | ||
| } | ||
|
|
||
| return $outstr; | ||
| } |