diff --git a/Bin/cpp_clean b/Bin/cpp_clean new file mode 100755 index 0000000..c479009 --- /dev/null +++ b/Bin/cpp_clean @@ -0,0 +1,44 @@ +#!/usr/bin/perl +# +# This script is used to clean CPP files. It removes: +# +# 1) Lines with '#' in column 1 (lines inserted by CPP). +# 2) Lines with '!!' in columns 1:2 (double commented lines). +# 3) Lines with '!$!' in columns 1:3 (removes OpenMP directives). +# 4) Blank lines. +# 5) Fixes placement of trailing '&' +# + +my $file = $ARGV[0]; +my $tmp = "tmp.$$"; +open(FILE, "$file"); +open(TMP, ">$tmp") || die "Can't open tmp file"; + +while () { + next if /^#/; + next if /^!!/; + next if /^!\$\!/; + next if /^\s*$/; + $a=rindex($_,"&"); + if(/\&(\ )*$/ && $a!=72){ + $l=length(); + if($a<72){ + $t=($a-1)-72; + $t2=-$t; + $sp=""; + for($i=1;$i<$t2;$i++){ + $sp=$sp . " "; + } + substr($_,-2,-$t-1)="$sp&\n"; + } + if($a>72){ + $t=72-($l); + substr($_,$t,-$t-1) = "&"; + } + } + print TMP; +} +close(FILE); +close(TMP); + +rename($tmp, $file); diff --git a/Bin/sfmakedepend b/Bin/sfmakedepend new file mode 100755 index 0000000..f6fd870 --- /dev/null +++ b/Bin/sfmakedepend @@ -0,0 +1,783 @@ +#!/usr/bin/env perl +# +# svn $Id: sfmakedepend 1012 2009-07-07 20:52:45Z kate $ +####################################################################### +# Copyright (c) 2002-2009 The ROMS/TOMS Group # +# Licensed under a MIT/X style license # +# See License_ROMS.txt # +##################################################### Kate Hedstrom ### +# # +# Fortran 90/77 dependency checker, version 2007b. # +# # +####################################################################### + +use 5.6.0; +use strict; +use File::Basename; +use Getopt::Long; +use Pod::Usage; +use Getopt::Long; +use File::Copy; + +my ($opt_help, $opt_man, $opt_file, @incdirs, @srcdirs, @defines, + $opt_modext, $opt_case, $compiler, $opt_depend, $drop_circ); +our ($cpp, $add_ext, $mod_dir, $libdeps, $longpath, $obj_dir, %defines, + $silent); +our $obj_ext = 'o'; +our $ext = 'f'; + +# Parse the arguments, do the right thing for --help, --man. +Getopt::Long::Configure( "bundling" ); +GetOptions("help" => \$opt_help, "man" => \$opt_man, + "file=s" => \$opt_file, "I=s@" => \@incdirs, + "srcdir=s@" => \@srcdirs, "moddir=s" => \$mod_dir, + "fext=s" => \$ext, "objext=s" => \$obj_ext, + "modext=s" => \$opt_modext, "addext=s" => \$add_ext, + "case=s" => \$opt_case, "compiler=s" => \$compiler, + "depend=s" => \$opt_depend, "cpp" => \$cpp, + "libdeps" => \$libdeps, "drop" => \$drop_circ, + "longpath" => \$longpath, "objdir=s" => \$obj_dir, + "D=s@" => \@defines, "silent" => \$silent ) + or pod2usage("Try '$0 --help' for more information"); +pod2usage(-verbose => 1) if $opt_help; +pod2usage(-verbose => 2) if $opt_man; + +our @suffixes = qw( .c .C .cc .cxx .cpp .f .F .f90 .F90 .f95 .F95 .for); +our @mod_files = (); + +my $mf = 'Makefile'; +if ($opt_file) { + $mf = $opt_file; +} elsif (-f "makefile") { + $mf = 'makefile'; +} +if ( !(-f $mf) && ($mf ne '-')) { + system "touch $mf"; +} + +if (@defines) { + my $foo; + foreach $foo (@defines) { + my($before, $after) = split /=/, $foo; + $defines{$before} = $after; + } +} + +# extension used for compiler's private module information +our $mod_ext = "mod"; +our $depend = "obj"; +our $case = "lower"; +our $obj_dep_flag; +my $ll = 79; # maximum line length in Makefile +my $cray; +my $parasoft; +my $nothing = "\n"; + +# Check the compiler first, then override the compiler-specific defaults +if ($compiler) { + if ($compiler eq "crayold") { + $cray = 1; + $case = "lower"; + $depend = "obj"; + $obj_dep_flag = "-p"; + } elsif ($compiler eq "cray") { + $case = "upper"; + } elsif ($compiler eq "parasoft") { + $parasoft = 1; + $case = "lower"; + $depend = "obj"; + $obj_dep_flag = "-module"; + } elsif ($compiler eq "sgiold") { + $mod_ext = "kmo"; + $case = "upper"; + } elsif ($compiler eq "sgi" or $compiler eq "hp" or + $compiler eq "absoft") { + $case = "upper"; + } elsif ($compiler eq "nag" or $compiler eq "ibm" or + $compiler eq "sun") { + $case = "lower"; + } else { + warn "Unknown compiler: $compiler\n"; + } +} + +$depend = $opt_depend if defined($opt_depend); +if ($depend eq "obj") { + $drop_circ = 1; +} + +$case = $opt_case if defined($opt_case); + +# extension used for compiler's private module information +if ($opt_modext) { + $mod_ext = $opt_modext; +} + +# need to add some more dependencies so the .f file gets created +our $need_f; +if ($cpp and $depend eq "obj") { + $need_f = 1; +} + +my $mystring = '# DO NOT DELETE THIS LINE - used by make depend'; + +# Search for the includes in all the files +my $file; +my %sources; +foreach $file (@ARGV) { + my $filesrc = findsrc($file); + $sources{$file} = new Source_File($file, $filesrc, $filesrc); + $sources{$file}->find_includes(); +} + +# Create new Makefile with new dependencies. + +if ($mf ne "-") { + copy( "$mf", "$mf.old"); + open(MFILE, "$mf.old") || die "can't read Makefile $mf.old: $!\n"; + open(NMFILE, "> $mf") || die "can't write $mf: $!\n"; + select(NMFILE); + + while () { + if (!/$mystring/) { + print; + } else { + last; + } + } + print $mystring, "\n"; +} + +# Now print out include and use dependencies in sorted order. +my $target; +foreach $target (sort keys(%sources)) { + $sources{$target}->print(); +# Hernan hack + print $nothing; +} + +# print out module dependencies +if ( !( $cray || $parasoft) ) { + my $modname; + foreach $modname (sort keys(%main::mod_files)) { + my ($name, $path, $suffix) = fileparse( + $sources{$main::mod_files{$modname}}->{'filepath'}, @suffixes); + my $object = $name . "." . $obj_ext; + if (!( $drop_circ && lc($modname) eq lc($name)) ) { + $object =~ s#^\./##; + print "$modname.$mod_ext: $object\n"; + } + } +} + +# +# End of main +# + +sub findfile { +# Let's see if we can find the included file. Look in current +# directory first, then in directories from -I arguments. + my $file = shift; + my ($found, $i, $filepath); + + $found = 0; + + if ( -f $file ) { + $found = 1; + $file =~ s#^\./##; # convert ./foo.h to foo.h + return $file; + } + foreach $i (0 .. $#incdirs) { + $filepath = $incdirs[$i]."/".$file; + if ( -f $filepath ) { + $found = 1; + $filepath =~ s#^\./##; # convert ./foo.h to foo.h + return $filepath; + } + } + if ( ! $found ) { + $filepath = ""; + } + $filepath; +} +#----------------------------------------------------------------------- +sub findsrc { +# Let's see if we can find the source-file. Look in current +# directory first, then in directories from --srcdir arguments. + my $src = shift; + my($found, $i, $srcpath); + + $found = 0; + + if ( -f $src ) { + $found = 1; + $src =~ s#^\./##; # convert ./foo.h to foo.h + return $src; + } + foreach $i (0 .. $#srcdirs) { + $srcpath = $srcdirs[$i]."/".$src; + if ( -f $srcpath ) { + $found = 1; + $srcpath =~ s#^\./##; # convert ./foo.h to foo.h + return $srcpath; + } + } + if ( ! $found ) { + $srcpath = ""; + } + $srcpath; +} + +################################################################# +package Source_File; + +# hash containing names of included files +my %inc_files = (); +my %flist; + +# Constructor +sub new { + my $type = shift; + my $filename = shift; + my $path = shift; + my $parent = shift; + my $self = {}; + $self->{'Source_File'} = $filename; + $self->{'filepath'} = $path; + $self->{'parent'} = $parent; + $self->{'includes'} = {}; + $self->{'uses'} = {}; + $self->{'modules'} = {}; + bless $self; +} + +sub find_includes { + my $self = shift; + my $file = $self->{'filepath'}; + my $parent = $self->{'parent'}; + my($after, $filepath, $ref, $included, $use, $modname); + local(*FILE); + local($_); + + if (-f $file) { + open(FILE, $file) || $silent || warn "Can't open $file: $!\n"; + } else { + return; + } + while () { + $included = ""; + $use = ""; + # look for Fortran style includes + if (/^\s*include\s*['"]([^"']*)["']/i) { + $included = $1; + $after = $'; + # C preprocessor style includes + } elsif (/^#\s*include\s*["<]([^">]*)[">]/) { + $included = $1; + $after = $'; + # Fortran 90 "use" + } elsif (/^\s*use\s+(\w+)/i) { + # Gavin Salam attempt at dealing with multiple uses on one line + # remove trailing comments (do not take uses after a comment!) + s/\!.*//; + # try and get multiple use commands + my @commands = split(';',$_); + while (my $command = shift @commands) { + if ($command =~ /^\s*use\s+(\w+)/i) { + $use = $1; + # Change the case as needed - compiler dependent. + if ($main::case eq "upper") { + $use = uc($use); + } elsif ($main::case eq "lower") { + $use = lc($use); + } + $self->{'uses'}{$use} = 1; + } + } + # Fortran 90 module + } elsif (/^\s*module\s+(\w+)/i) { + $modname = $1; + if ($main::case eq "upper") { + $modname = uc($modname); + } elsif ($main::case eq "lower") { + $modname = lc($modname); + } + # Skip "module procedure" in interface blocks + next if (lc($modname) eq "procedure"); + + $main::mod_files{$modname} = $parent; + $self->{'modules'}{$modname} = 1; + } + # C preprocessor style includes of a -DROMS_HEADER sort + my $key; + foreach $key (keys(%defines)) { + if (/^#\s*include\s*($key)/) { + $included = $defines{$key}; + $after = $'; + } + } + if ($included) { + # See if we've already searched this file + if ( $inc_files{$included} ) { + $filepath = $inc_files{$included}{'filepath'}; + } else { + $filepath = main::findfile($included); + $ref = new Source_File($included, $filepath, $parent); + $inc_files{$included} = $ref; +# Search included file for includes + $ref->find_includes(); + } + if ( $filepath ) { + $self->{'includes'}{$included} = 1; + } else { + if ($after !~ /bogus/i) { + $silent || warn "Can't find file: $included\n"; + } + } + } + } + close FILE; +} + +sub print_includes { + my $self = shift; + my $target = shift; + my $len_sum = shift; + my $file; + my $len; + + foreach $file (keys %{$self->{'includes'}}) { + if (!$flist{$file}) { + $flist{$file} = 1; + my $ref = $inc_files{$file}; + if ($longpath) { + $len = length($ref->{'filepath'}) + 1; + } else { + $len = length($ref->{'Source_File'}) + 1; + } + if (($len_sum + $len > $ll) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + if ($longpath) { + print " " . $ref->{'filepath'}; + } else { + print " " . $ref->{'Source_File'}; + } + $len_sum += $len; + $len_sum = $ref->print_includes($target, $len_sum); + } + } + $len_sum; +} + +# return list of modules used by included files +sub inc_mods { + my $self = shift; + my($file, $ref, $mod, @sub_list); + my @list = (); + + foreach $mod (keys %{$self->{'uses'}}) { + push(@list, $mod); + } + + foreach $file (keys %{$self->{'includes'}}) { + $ref = $inc_files{$file}; + @sub_list = $ref->inc_mods(); + @list = (@list, @sub_list); + } + @list; +} + +# filenames containing the modules used by file and all its includes +sub find_mods { + my $self = shift; + my($modname, $file); + my @module_files = (); + my @mod_list = (); + +# find modules used by include files + if (%{$self->{'includes'}}) { + foreach $file (keys %{$self->{'includes'}}) { + my $ref = $inc_files{$file}; + my @list = $ref->inc_mods(); + @mod_list = (@mod_list, @list); + } + } + +# add them to the uses list (hash ensures uniqueness) + foreach $modname (@mod_list) { + $self->{'uses'}{$modname} = 1; + } + +# now find the filename that contains the module information + foreach $modname (keys %{$self->{'uses'}}) { + if ($main::depend eq "obj") { + if ($file = $main::mod_files{$modname}) { + my $base = main::basename($file, @main::suffixes); + $file = $base . "." . $main::obj_ext; + push(@module_files, $file); + } elsif ( !$silent ) { + warn "Don't know where module $modname lives.\n"; + } + } else { + if ($main::libdeps or defined($main::mod_files{$modname})) { + $modname .= "." . $main::mod_ext; + push(@module_files, $modname); + } elsif ( !$silent ) { + warn "Couldn't locate source for module $modname\n"; + } + } + } + sort(@module_files); +} + +sub print { + my $self = shift; + my $source = $self->{'Source_File'}; + my $compile_string = "\t" . '$(F90) $(F90FLAGS) -c'; + my($len_sum, $len); + my($base, $object, $modname, $flag, $target, $ftarget); + + $base = main::basename($source, @main::suffixes); + $base = $main::obj_dir . '/' . $base if $main::obj_dir; + $target = $base . "." . $main::obj_ext; + if ($main::cpp) { + $ftarget = $base . "." . $main::ext; + } + + $flag = $main::obj_dep_flag; + +# print out "include" dependencies + %flist = (); + if (%{$self->{'includes'}}) { + $len_sum = length($target) + 1; + if ($main::add_ext) { + print "$base.$main::add_ext "; + $len_sum += length($base) + length($main::add_ext) + 2; + } + print "$target:"; + $self->print_includes($target, $len_sum); + print "\n"; + if ($main::cpp) { + %flist = (); + $len_sum = length($ftarget) + 1; + print "$ftarget:"; + $self->print_includes($ftarget, $len_sum); + print "\n"; + } + } + +# clean out "use" of modules in own file + my $mod; + foreach $mod ( keys %{$self->{'uses'}} ) { + if ( ${$self->{'modules'}}{$mod} ) { + delete ${$self->{'uses'}}{$mod}; + } + } + +# print out "use" dependencies + if (%{$self->{'uses'}} || %{$self->{'includes'}}) { + my @module_files = $self->find_mods(); + $len_sum = 0; + my $file; + foreach $file (@module_files) { + $file = $main::mod_dir . '/' . $file if $main::mod_dir; + if( $len_sum < 1 ) { + $len_sum = length($target) + 1; + print "$target:"; + } + $len = length($file) + 1; + if (($len_sum + $len > $ll) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + $len_sum += $len; + print " " . $file; + } + if ($main::need_f) { + $len = length($ftarget) + 1; + if (($len_sum + $len > $ll) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + print " " . $ftarget if $len_sum; + } + print "\n" if $len_sum; +# extra Cray / Parasoft stuff + if ($flag) { + print $compile_string; + foreach $file (@module_files) { + print $flag . $file; + } + if ($main::cpp) { + print " " . $ftarget . "\n"; + } else { + print " " . $source . "\n"; + } + } + } +} + +__END__ + +sfmakedepend - Fortran Dependency Checker + +=head1 SYNOPSIS + +sfmakedepend [--help] [--man] [--file=file] [-I dir] + [--srcdir dir] [--objdir dir] [--moddir dir] + [--fext ext] [--objext ext] [--modext ext] + [-D TAG=file] [--addext ext] [--case=up|down|asis] + [--compiler=crayold|cray|sgiold|sgi|nag|ibm| + parasoft|hp|absoft|sun] + [--depend=mod|obj] [--cpp] [--libdeps] [--drop] + [--silent] file ... + +=head1 DESCRIPTION + +This is a makedepend script for Fortran, including Fortran 90. +It searches for Fortran style includes, C preprocessor includes, +and module dependencies to the extent that I understand them. + +Your files must have an extension listed in the @suffixes list +in the code. You might also want to modify $compile_string; +the compiler is called $(F90). + +=head1 OPTIONS AND ARGUMENTS + +=over 4 + +=item I<--help> + +Print more details about the arguments. + +=item I<--man> + +Print a full man page. + +=item I<--file file> + +Change the name of the current Makefile (default is Makefile). +Use "--file -" to write to stdout. + +=item I<-I dir> + +Look in alternate directories for the include files. There can be +several "-I dir" options used at once. The current directory is +still searched first. + +=item I<--srcdir dir> + +Look in alternate directories for the source files, much like VPATH. +It can be used multiple times to search in more than one directory. + +=item I<--objdir dir> + +Tells sfmakedepend to prepend objdir to all object references (and +cpp output files if used). This is required if you use a build +directory that isn't your current directory. + +=item I<--moddir dir> + +Tells sfmakedepend to prepend moddir to all module references. This +is required if you use a common module library directory for a +multi-directory project (+moddir= .. option on HP, eg.). + +=item I<--fext> + +This is used with the --cpp switch for compilers +which expect an extension other than .f on source files. For +instance, one might choose to use "--fext f90". + +=item I<--objext ext> + +Tells sfmakedepend what extension to use for object files. The +default is "o", but "obj", for instance, is +appropriate on MS-DOG etc. + +=item I<--modext ext> + +Specifies the extension to use for Fortran 90 module files. The default +extension is "mod" since this seems to be an emerging standard. Let +me know if other compilers use a different filename for the module +information (keep that --compiler option up to date). + +=item I<--D tag=file> + +Tells sfmakedepend to search the source files for lines such as: + + #include MY_CHEESE + +Where MY_CHEESE is set with a -DMY_CHEESE="wensleydale.h". + +=item I<--addext ext> + +Tells sfmakedepend to add targets with extension add_ext to the rules +for object files. For instance, to operate with (f77) ftnchek .prj +files, you could use + +`--addext prj' to get rules like: +foo.prj foo.o: ... + +=item I<--case up|down|asis> + +Controls case of module names when generating module file names. Only +relevant where the module file name is named after the module rather +than after the source file. + +=item I<--compiler=crayold|cray|sgiold|sgi|nag|ibm|parasoft|hp|absoft|sun> + +Controls the type of target compiler, setting the module name and other +options appropriately. The cray option assumes that FFLAGS includes +-e m for creating the .mod file, while crayold refers to the default of +including that information in the object file. + +=item I<--depend=mod|obj> + +Whether to use the module information file or the module object file +in dependencies. + +=item I<--cpp> + +There are times when one might choose to run .F files through cpp and +to keep the .f files (for the debugger or for a custom preprocessor). +In that case, make must be told about the cpp include dependencies of +the .f files. This option will provide those dependencies. + +=item I<--libdeps> + +Generate dependencies on modules for which source code is not +available. Otherwise a warning is issued, but the dependency is not +listed. + +=item I<--longpath> + +Keep the full path to the include files in the dependency. Otherwise, +just print the filename and use VPATH to provide the directory +information. + +=item I<--drop> + +Drop module dependencies (my_mod.mod: my_mod.o). This is also done when +--depend=obj. + +=item I<--silent> + +The default is to warn about unfound files. This option causes those +warnings to not be printed. + +=item I<[file ...]> + +The list of source files to search for dependencies. + +=back + +=head1 EXAMPLE + +Search for include files in /usr/local/include: + + sfmakedepend --cpp --fext=f90 -I /usr/local/include *.F + +Example usage in gnuMakefile: + + SRCDIRS= srcdir1 srcdir2 srcdir3 ... + FSRCS0 := $(foreach DIR, . $(SRCDIRSH),$(wildcard $(DIR)/*.f)) + FSRCS := $(sort $(notdir $(FSRCS0))) + + F_makedepend=sfmakedepend --file - $(addprefix --srcdir ,$(SRCDIRSH)) \ + $(subst -I,-I ,$(Includes)) + depend $(MAKEFILE_INC): + $(F_makedepend) $(FSRCS) >> $(MAKEFILE_INC) + + include $(MAKEFILE_INC) + +=head1 AUTHOR + +Kate Hedstrom (kate@arsc.edu) + First Perl 5 Fortran 90 version November 1994. + +=head1 CONTRIBUTORS + + Dave Love (d.love@dl.ac.uk) + Added the --objext and --addext options (1996). + + Patrick Jessee + Added hp support (1997, now in --compiler option). + + Sergio Gelato (gelato@tac.dk) + Added the --compiler, --depend, --case options, and + --(no)libdeps (1998). + + Tobias Buchal (buchal@ifh.bau-verm.uni-karlsruhe.de) + Added the --srcdir and --file - options (1999). + + Klaus Ramstock (klaus@tdm234.el.utwente.nl) + Added the --moddir option (1999). + + Sandra Schroedter (sandra@fsg-ship.de) + Fix to preserve Makefile links (1999). + + Holger Bauer (bauer@itsm.uni-stuttgart.de) + Added the --drop option (2000). + + Gavin Salam (salam@lpthe.jussieu.fr) + Made it recognize multiple "use"s on one line (2005). + +Others I've doubtless forgotten. + +=cut +# +# NOTES +# This makedepend script is my first attempt at using perl 5 +# objects. Therefore, it may not be the best example of how +# to do this. Also, it requires perl 5 and will die if you +# to use it with an older perl. The latest version is +# available from: +# +# http://www.arsc.edu/~kate/Perl/ +# ftp://ahab.rutgers.edu/pub/perl/sfmakedepend +# +# Fortran 90 introduces some interesting dependencies. Two +# compilers I have access to (NAG f90 and IBM xlf) produce a +# private "mod_name.mod" file if you define "module mod_name" +# in your code. This file is used by the compiler when you +# use the module as a consistency check (type-safe). On the +# other hand, the Cray and Parasoft compilers store the module +# information in the object file and then files which use the +# modules need to be compiled with extra flags pointing to the +# module object files. +# +# This script assumes that all the files using and defining +# modules are in the same directory and are all in the list of +# files to be searched. It seems that the industry has not +# settled on a practical way to deal with a separate modules +# directory, anyway. +# +# I sometimes include non-existent files as a compile time +# consistency check: +# +# #ifndef PLOTS +# #include "must_define_PLOTS" /* bogus include */ +# #endif +# +# This program warns about include files it can't find, but +# not if there is a "bogus" on the same line. +# +# * The f90 module dependencies can confuse some versions of +# make, especially of the System V variety. We use gnu +# make because it has no problems with these dependencies. +# +# BUGS +# It can sometimes produce duplicate dependencies. +# +# It treats C preprocessor includes the same as Fortran +# includes. This can add unnecessary dependencies if you +# use the -s flag and both kinds of includes. +# +# Please let me know if you find any others. +# Kate Hedstrom +# kate@arsc.edu diff --git a/Caribbean/bathy.h b/Caribbean/bathy.h new file mode 100644 index 0000000..94b8024 --- /dev/null +++ b/Caribbean/bathy.h @@ -0,0 +1,36 @@ +#include "gridparam.h" + integer Lm, Mm, Lp, Mp, L2d + parameter ( Lm=L-1 , Mm=M-1 , Lp=L+1, Mp=M+1 ) + parameter ( L2d=Lp*Mp ) +! lcflag tells which color bar to use, 1 - 3 (so far). If negative +! then black outlines are drawn over the color contour regions. + integer lcflag + parameter ( lcflag=-5 ) + real x_v(0:L+2,0:M+2), y_v(0:L+2,0:M+2) + common /xxyys/ x_v, y_v + BIGREAL xp(L,M), yp(L,M), xr(0:L,0:M), yr(0:L,0:M), & + & xu(L,0:M), yu(L,0:M), xv(0:L,M), yv(0:L,M), & + & xl, el + real xmin, ymin, xmax, ymax + common /grdpts/ xp, yp, xr, yr, xu, yu, xv, yv, xl, el, & + & xmin, ymin, xmax, ymax + BIGREAL f(0:L,0:M), h(0:L,0:M) + common /parm/ f, h + BIGREAL pm(0:L,0:M), pn(0:L,0:M), & + & dndx(0:L,0:M), dmde(0:L,0:M) + common /pmpn/ pm, pn, dndx, dmde + BIGREAL lat_psi(L,M), lon_psi(L,M), & + & lat_rho(0:L,0:M), lon_rho(0:L,0:M), & + & lat_u(L,0:M), lon_u(L,0:M), & + & lat_v(0:L,M), lon_v(0:L,M) + common /latlon/ lat_psi, lon_psi, lat_rho, lon_rho, & + & lat_u, lon_u, lat_v, lon_v + BIGREAL mask_rho(0:L,0:M), mask_u(L,0:M), & + & mask_v(0:L,M), mask_psi(L,M) + common /rmask/ mask_rho, mask_u, mask_v, mask_psi + BIGREAL angle(0:L,0:M) + common /angles/ angle + integer*2 depthmin, depthmax + common /hmins/ depthmin, depthmax + logical spherical + common /logic/ spherical diff --git a/Caribbean/coast.h b/Caribbean/coast.h new file mode 100644 index 0000000..d6d0fbf --- /dev/null +++ b/Caribbean/coast.h @@ -0,0 +1,9 @@ + integer IBIG + parameter ( IBIG = 300) + real clat(IBIG), clong(IBIG) + common /coast/ clat, clong +! backward is a logical variable which is true if you read in the +! data in the direction opposite to the direction it should be +! written out for the grid program. + logical backward + parameter ( backward = .false. ) diff --git a/Caribbean/coast.in b/Caribbean/coast.in new file mode 100644 index 0000000..c58b5ff --- /dev/null +++ b/Caribbean/coast.in @@ -0,0 +1,4 @@ + 30. -98. + 9. -98. + 9. -60. + 30. -60. diff --git a/Caribbean/fort.60 b/Caribbean/fort.60 new file mode 100644 index 0000000..2d85d28 --- /dev/null +++ b/Caribbean/fort.60 @@ -0,0 +1,12 @@ + 2 + -2001420.500 3499475.250 + -2001420.500 1004851.062 + 2 + -2001420.500 1004851.062 + 2223800.500 1004851.062 + 2 + 2223800.500 1004851.062 + 2223800.500 3499475.250 + 2 + 2223800.500 3499475.250 + -2001420.500 3499475.250 diff --git a/Caribbean/grid.h b/Caribbean/grid.h new file mode 100644 index 0000000..7097627 --- /dev/null +++ b/Caribbean/grid.h @@ -0,0 +1,75 @@ +#include "griddefs.h" +#include "bathy.h" + integer ITMAX, IBIG + parameter ( ITMAX=8, IBIG=400 ) +! ITMAX is the number of iterations to perform +! IBIG is the largest number of points to be read in for one +! boundary. +! +! original distribution of x,y points is preserved on boundary kb1 +! and kb2: + integer kb1, kb2 + parameter ( kb1 = 1, kb2 = 4 ) + + integer L2, M2, L2big, M2big, nwrk + integer N, N1, N2, N3, N4 + parameter ( L2=2*(L-1), M2=2*(M-1) ) + parameter ( L2big=2*Lm, M2big=2*Mm ) + parameter ( N1=M2, N2=M2+L2, N3=M2+L2+M2, & + & N4=M2+L2+M2+L2, N=N4 ) + integer KK + parameter ( KK = 9 ) + parameter ( nwrk = 2*(KK-2)*(2**(KK+1)) + KK + 10*M2big + & + & 12*L2big + 27 ) + BIGREAL sxi(0:L2big), seta(0:M2big) + common / xiej / sxi, seta + BIGREAL x1spl(IBIG),x2spl(IBIG),x3spl(IBIG),x4spl(IBIG), & + & y1spl(IBIG),y2spl(IBIG),y3spl(IBIG),y4spl(IBIG), & + & s1spl(IBIG),s2spl(IBIG),s3spl(IBIG),s4spl(IBIG), & + & b1spl(IBIG),b2spl(IBIG),b3spl(IBIG),b4spl(IBIG), & + & c1spl(IBIG),c2spl(IBIG),c3spl(IBIG),c4spl(IBIG) + integer nb1pts,nb2pts,nb3pts,nb4pts + common / bdata/ x1spl, x2spl, x3spl, x4spl, & + & y1spl, y2spl, y3spl, y4spl, & + & s1spl, s2spl, s3spl, s4spl, & + & b1spl, b2spl, b3spl, b4spl, & + & c1spl, c2spl, c3spl, c4spl, & + & nb1pts, nb2pts, nb3pts, nb4pts +! The boundary values are read from stdin for edges which have +! rbnd true. For boundaries which are read in, the grid spacing +! is proportional to distance along the boundary if even? is true. +! Otherwise, it is proportional to the spacing of the supplied +! boundary points. + logical rbnd1, rbnd2, rbnd3, rbnd4, & + & even1, even2, even3, even4 + parameter ( rbnd1=.true., rbnd2=.true., & + & rbnd3=.true., rbnd4=.true., & + & even1=.false., even2=.true., & + & even3=.true., even4=.true. ) + +! The following are used when you need to fit a boundary with +! bumps on opposite sides and need to make intermediate partial +! grids. Set pleft1 or pbot1 to true to print out the boundaries +! of a partial left or bottom grid. Set pleft2 or pbot2 to true +! to print out the new left or bottom boundary. Lmiddle or Mmiddle +! gives the position of the interior boundary for the intermediate +! grid. The boundaries are written out to iout1 or iout2. +! +! Don't forget to adjust the evenx flags, kb1 and kb2 accordingly. + logical pleft1, pleft2, pbot1, pbot2 + integer Lmiddle, Mmiddle, iout1, iout2 + parameter ( pleft1=.false., pleft2=.false., & + & pbot1=.false., pbot2=.false., & + & Lmiddle=49, Mmiddle=25, & + & iout1=13, iout2=14 ) + +! These variables are used for writing out a subset of the psi points +! to be used in generating a nested domain. + logical subset + integer Lwest, Least, Msouth, Mnorth, iout3 + parameter ( subset = .false., Lwest = 144, Least = 272, & + & Msouth = 160, Mnorth = 248, iout3 = 15 ) + +! xpots unit numbers + integer ipot1, ipot2, ipot3, ipot4 + parameter ( ipot1=41, ipot2=42, ipot3=43, ipot4=44 ) diff --git a/Caribbean/grid.in b/Caribbean/grid.in new file mode 100644 index 0000000..f58c306 --- /dev/null +++ b/Caribbean/grid.in @@ -0,0 +1,12 @@ +2 + -2001414.25 3499465. + -2001414.25 1004847.94 +2 + -2001414.25 1004847.94 + 2223793.5 1004847.94 +2 + 2223793.5 1004847.94 + 2223793.5 3499465. +2 + 2223793.5 3499465. + -2001414.25 3499465. diff --git a/Caribbean/griddefs.h b/Caribbean/griddefs.h new file mode 100644 index 0000000..6df1a9a --- /dev/null +++ b/Caribbean/griddefs.h @@ -0,0 +1,67 @@ +! define as 1 for ETOPO5 bathymetry +#define ETOPO5 1 +! define as 1 for ETOPO2 bathymetry +#undef ETOPO2 +#undef GEBCO + +! for 64-bit output +#define DBLEPREC 1 + +! to draw coastlines on some plots +#define DRAW_COASTS 1 + +! to keep ellipsoidal terms in Earth's shape +#define ELLIPSOID 1 + +! for averaging bathymetry in gridbox (for EW/NS grids only) +#undef IMG_AVG + +#undef KEEP_SHALLOW + +! for NCAR graphics (3.2 or better) */ +#define PLOTS 1 +! for X windows rather than metafile */ +#undef X_WIN + +#undef SYS_POTS /* unimplimented system calls */ +#undef XPOTS1 /* read ipot1 file */ +#undef XPOTS2 /* read ipot2 file */ +#undef XPOTS3 /* read ipot3 file */ +#undef XPOTS4 /* read ipot4 file */ + +#ifdef cray +#undef DCOMPLEX +#define DBLEPREC 1 /* for 64-bit output */ +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#else +#if DBLEPREC +#define DCOMPLEX 1 /* for compilers which support complex*16 */ +#define SMALLREAL real +#define BIGREAL real*8 +#define BIGCOMPLEX complex*16 +#define FLoaT dfloat +#else +#undef DCOMPLEX +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#endif /* DBLEPREC */ +#endif /* cray */ + +#if DBLEPREC +#define nf_get_var_FLoaT nf_get_var_double +#define nf_get_vara_FLoaT nf_get_vara_double +#define nf_put_att_FLoaT nf_put_att_double +#define nf_put_var_FLoaT nf_put_var_double +#define nf_put_vara_FLoaT nf_put_vara_double +#else +#define nf_get_var_FLoaT nf_get_var_real +#define nf_get_vara_FLoaT nf_get_vara_real +#define nf_put_att_FLoaT nf_put_att_real +#define nf_put_var_FLoaT nf_put_var_real +#define nf_put_vara_FLoaT nf_put_vara_real +#endif /* DBLEPREC */ diff --git a/Caribbean/gridid.h b/Caribbean/gridid.h new file mode 100644 index 0000000..675d613 --- /dev/null +++ b/Caribbean/gridid.h @@ -0,0 +1,6 @@ +! gridid is an 80 character string, the first 40 of which are +! used as a plot label. +! gridfile is the name of the netCDF file produced by the +! grid/sqgrid programs + gridid = 'Gulf of Mexico #1' + gridfile = 'grid_gom.nc' diff --git a/Caribbean/gridparam.h b/Caribbean/gridparam.h new file mode 100644 index 0000000..7987bb2 --- /dev/null +++ b/Caribbean/gridparam.h @@ -0,0 +1,12 @@ + integer L, M + parameter ( L=72 , M=43 ) +! +! mud2 requires that these values satisfy +! +! L = NXL*2**(NSTEP-1)+1 +! M = NYL*2**(NSTEP-1)+1 +! +! where NXL, NYL and NSTEP are integers. Try to have NSTEP as large as +! possible (see mud2 documentation). +! +! subroutine 'factor' now takes care of passing NXL, NYL and NSTEP to mud2. diff --git a/Caribbean/proj.h b/Caribbean/proj.h new file mode 100644 index 0000000..c174c20 --- /dev/null +++ b/Caribbean/proj.h @@ -0,0 +1,9 @@ + character*2 JPRJ, JLTS + real PLAT, PLONG, ROTA, P1, P2, P3, P4, XOFF, YOFF + integer JGRD + parameter ( JPRJ = 'ME', PLAT = 0.000000, & + & PLONG = -80.000000, ROTA = 0.000000, & + & JLTS = 'CO', P1 = 5.000000, & + & P2 = -100.000000, P3 = 33.000000, & + & P4 = -57.000000, JGRD = 10) + parameter ( XOFF = 0., YOFF = 0.) diff --git a/Compilers/AIX-xlf.mk b/Compilers/AIX-xlf.mk new file mode 100644 index 0000000..91ce5d1 --- /dev/null +++ b/Compilers/AIX-xlf.mk @@ -0,0 +1,81 @@ +# +# Include file for IBM xlf95_r Fortran Compiler +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := xlf95_r + FFLAGS := -qsuffix=f=f90 -qmaxmem=-1 -qarch=auto -qtune=auto + CPP := /usr/lib/cpp + CPPFLAGS := -P -DAIX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +ifdef LARGE + FFLAGS += -q64 + ARFLAGS += -X 64 + LDFLAGS += -bmaxdata:0x200000000 + NETCDF_INCDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.0_64/include + NETCDF_LIBDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.0_64/lib +else + LDFLAGS += -bmaxdata:0x70000000 + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib +endif + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + FC := mpxlf95_r +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -qsmp=omp +endif + +ifdef DEBUG + FFLAGS += -g -qfullpath +else + FFLAGS += -O3 -qstrict +endif + +# +# Use full path of compiler. +# + FC := $(shell which ${FC}) + LD := $(FC) + diff --git a/Compilers/CYGWIN-df.mk b/Compilers/CYGWIN-df.mk new file mode 100644 index 0000000..c68c327 --- /dev/null +++ b/Compilers/CYGWIN-df.mk @@ -0,0 +1,91 @@ +# +# Include file for Compaq Visual Fortran compiler on Cygwin +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + + BIN := $(BIN).exe + + FC := df + FFLAGS := /stand:f95 + CPP := /usr/bin/cpp + CPPFLAGS := -P -DCYGWIN + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := /nodefaultlib:libcmt /stack:67108864 + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# These are be specified in Unix form and will be converted as +# necessary to Windows form for Windows-native commands. The default +# values below assume that Cygwin mounts have been defined pointing to +# the NETCDF and ARPACK library locations. +# + +# NETCDF_INCDIR ?= /netcdf-win32/include +# NETCDF_LIBDIR ?= /netcdf-win32/lib + + NETCDF_INCDIR ?= 'C:\\include\\' + NETCDF_LIBDIR ?= 'C:\\lib\\' + + CPPFLAGS += -I$(NETCDF_INCDIR) + NETCDF_LIB := $(NETCDF_LIBDIR)/netcdfs.lib + +ifdef ARPACK + ARPACK_LIBDIR ?= /arpack-win32/lib + ARPACK_LIB := $(ARPACK_LIBDIR)/arpack.lib +endif + +# +# Compiler flags +# + +ifdef DEBUG + FFLAGS += /debug:full /traceback +else + FFLAGS += /fast +endif + +# +# For a Windows compiler, create variables pointing to the Windows +# file names needed when linking. Use of the "=" sign means that +# variables will be evaluated only when needed. +# + + BIN_WIN32 = "$$(cygpath --windows $(BIN))" + LIBS_WIN32 = "$$(cygpath --windows $(NETCDF_LIB))" +ifdef ARPACK + LIBS_WIN32 += "$$(cygpath --windows $(ARPACK_LIB))" +endif + +# +# For a Windows compiler, override the compilation rule +# + +%.o: %.f90 + $(FC) $(FFLAGS) /compile $< /object:$@ + + diff --git a/Compilers/CYGWIN-g95.mk b/Compilers/CYGWIN-g95.mk new file mode 100644 index 0000000..0244eb6 --- /dev/null +++ b/Compilers/CYGWIN-g95.mk @@ -0,0 +1,59 @@ +# +# Include file for GNU g95 on Cygwin +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + + BIN := $(BIN).exe + + FC := g95 + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DCYGWIN + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/include + NETCDF_LIBDIR ?= /usr/local/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef DEBUG + FFLAGS += -g -fbounds-check +else + FFLAGS += -O3 -ffast-math +endif diff --git a/Compilers/Darwin-f90.mk b/Compilers/Darwin-f90.mk new file mode 100644 index 0000000..5c91118 --- /dev/null +++ b/Compilers/Darwin-f90.mk @@ -0,0 +1,64 @@ +# +# Include file for Absoft compiler on Mac (Darwin) +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f90 + FFLAGS := -N11 -YEXT_NAMES=LCS -YEXT_SFX=_ -YCFRL=1 -w + CPP := /usr/bin/cpp + CPPFLAGS := -P -DMAC -traditional + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf -lU77 + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g +else + FFLAGS += -O3 +endif diff --git a/Compilers/Darwin-xlf.mk b/Compilers/Darwin-xlf.mk new file mode 100644 index 0000000..8709e70 --- /dev/null +++ b/Compilers/Darwin-xlf.mk @@ -0,0 +1,67 @@ +# +# Include file for IBM xlf95_r Fortran Compiler on the Macintosh +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := xlf95_r + FFLAGS := -qsuffix=f=f90 -qmaxmem=-1 -qextname + CPP := /usr/bin/cpp + CPPFLAGS := -P -DMAC -traditional + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +# NETCDF_INCDIR ?= /usr/local/include +# NETCDF_LIBDIR ?= /usr/local/lib + NETCDF_INCDIR ?= ${HOME}/include + NETCDF_LIBDIR ?= ${HOME}/lib + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + FC := mpxlf95_r +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -qsmp=omp +endif + +ifdef DEBUG + FFLAGS += -g -qfullpath +else + FFLAGS += -O3 -qstrict +endif diff --git a/Compilers/IRIX64-f90.mk b/Compilers/IRIX64-f90.mk new file mode 100644 index 0000000..9191c4c --- /dev/null +++ b/Compilers/IRIX64-f90.mk @@ -0,0 +1,74 @@ +# +# Include file for IRIX F90 compiler on SGI +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LDR Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f90 + FFLAGS := -mips4 -u -TENV:X=3 + CPP := /usr/lib32/cmplrs/cpp + CPPFLAGS := -P -DSGI + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := touch + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +ifdef LARGE + FFLAGS += -64 + NETCDF_INCDIR ?= $(HOME)/netcdf/include + NETCDF_LIBDIR ?= $(HOME)/netcdf/lib64 +else + FFLAGS += -n32 + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib +endif + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + FFLAGS += -LANG:recursive=on + LDFLAGS += -mp -mp_schedtype=simple + LIBS += -lmpi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -mp -MP:open_mp=ON +endif + +ifdef DEBUG + FFLAGS += -g -C +else + FFLAGS += -O3 -OPT:Olimit=4038 +endif diff --git a/Compilers/Linux-f95.mk b/Compilers/Linux-f95.mk new file mode 100644 index 0000000..4717c05 --- /dev/null +++ b/Compilers/Linux-f95.mk @@ -0,0 +1,77 @@ +# +# Include file for Sun F95 compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f95 + FFLAGS := -native -u + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional + CLEAN := Bin/cpp_clean + LD := $(FC) + LDFLAGS := + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +ifdef LARGE + FFLAGS += -m64 + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib64 +else + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib +endif + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ifdef MPI + PARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(PARPACK_LIBDIR) -lparpack + endif + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + FC := tmf90 + LD := $(FC) + LIBS += -lmpi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -openmp +endif + +ifdef DEBUG + FFLAGS += -g -C +else + FFLAGS += -O3 +endif diff --git a/Compilers/Linux-ftn.mk b/Compilers/Linux-ftn.mk new file mode 100644 index 0000000..41d2491 --- /dev/null +++ b/Compilers/Linux-ftn.mk @@ -0,0 +1,64 @@ +# +# Include file for CRAY FTN cross-compiler with Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := ftn + FFLAGS := -e I -e m + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DCRAYX1 -DCRAY + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := touch + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= $(HOME)/include + NETCDF_LIBDIR ?= $(HOME)/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -G 0 +else + FFLAGS += -O 3,aggress +endif diff --git a/Compilers/Linux-g95.mk b/Compilers/Linux-g95.mk new file mode 100644 index 0000000..db3d4b0 --- /dev/null +++ b/Compilers/Linux-g95.mk @@ -0,0 +1,64 @@ +# +# Include file for GNU G95 compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := g95 + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g -fbounds-check +else + FFLAGS += -O3 -ffast-math +endif diff --git a/Compilers/Linux-gfortran.mk b/Compilers/Linux-gfortran.mk new file mode 100644 index 0000000..9da8506 --- /dev/null +++ b/Compilers/Linux-gfortran.mk @@ -0,0 +1,82 @@ +# +# Include file for GNU G95 compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := gfortran + FFLAGS := -frepack-arrays + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +# NETCDF_INCDIR ?= /usr/local/include +# NETCDF_LIBDIR ?= /usr/local/lib + HDF5_LIBDIR ?= /u1/uaf/kate/lib + NETCDF_INCDIR := /archive/u1/uaf/kate/netcdf/include + NETCDF_LIBDIR := /archive/u1/uaf/kate/netcdf/lib + USE_NETCDF4 := on + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf +ifdef USE_NETCDF4 + LIBS += -L$(HDF5_LIBDIR) -lhdf5_hl -lhdf5 -lz +endif + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + ifdef MPIF90 + FC := mpif90 + LD := $(FC) + else + LIBS += -lfmpi -lmpi + endif +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g -fbounds-check -Wall -Wno-unused-variable -Wno-unused-labels +else + FFLAGS += -O3 -ffast-math +endif + +# Turn off bounds checking for function def_var, as "dimension(*)" +# declarations confuse Gnu Fortran 95 bounds-checking code. + +def_var.o: FFLAGS += -fno-bounds-check diff --git a/Compilers/Linux-ifc.mk b/Compilers/Linux-ifc.mk new file mode 100644 index 0000000..1cdd2ca --- /dev/null +++ b/Compilers/Linux-ifc.mk @@ -0,0 +1,73 @@ +# +# Include file for Intel IFC (version 7.x) compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := ifc + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := -Vaxlib + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /opt/intel/compiler70/ia32/include + NETCDF_LIBDIR ?= /opt/intel/compiler70/ia32/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /opt/intelsoft//ARPACK + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -openmp +endif + +ifdef DEBUG + FFLAGS += -g -CA -CB -CS -CU +else + FFLAGS += -ip -O3 + ifeq ($(CPU),i686) + FFLAGS += -pc80 -xW + endif + ifeq ($(CPU),x86_64) + FFLAGS += -xW + endif +endif + + clean_list += ifc* work.pc* diff --git a/Compilers/Linux-ifort.mk b/Compilers/Linux-ifort.mk new file mode 100644 index 0000000..619c4b3 --- /dev/null +++ b/Compilers/Linux-ifort.mk @@ -0,0 +1,74 @@ +# +# Include file for Intel IFORT (version 8.x) compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := ifort + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := -Vaxlib + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /opt/intel/netcdf/include + NETCDF_LIBDIR ?= /opt/intel/netcdf/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /opt/intelsoft/ARPACK + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI + LIBS += -lfmpi-pgi -lmpi-pgi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -openmp +endif + +ifdef DEBUG + FFLAGS += -g -check bounds +else + FFLAGS += -ip -O3 + ifeq ($(CPU),i686) + FFLAGS += -pc80 -xW + endif + ifeq ($(CPU),x86_64) + FFLAGS += -xW + endif +endif + + clean_list += ifc* work.pc* diff --git a/Compilers/Linux-mpif90.mk b/Compilers/Linux-mpif90.mk new file mode 100644 index 0000000..593dcb7 --- /dev/null +++ b/Compilers/Linux-mpif90.mk @@ -0,0 +1,68 @@ +# +# Include file for MPIF90 compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := mpif90 + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := -Vaxlib + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /opt/intel/netcdf/include + NETCDF_LIBDIR ?= /opt/intel/netcdf/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /opt/intelsoft/ARPACK + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI + LIBS += +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -openmp +endif + +ifdef DEBUG + FFLAGS += -g -check bounds +else + FFLAGS += -O3 +endif + + clean_list += ifc* work.pc* diff --git a/Compilers/Linux-path.mk b/Compilers/Linux-path.mk new file mode 100644 index 0000000..72b4233 --- /dev/null +++ b/Compilers/Linux-path.mk @@ -0,0 +1,65 @@ +# +# Include file for PathScale compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := pathf90 + FFLAGS := -fno-second-underscore + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX -I/usr/include -DpgiFortran + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /opt/netcdf-3.6.0-pathscale/include + NETCDF_LIBDIR ?= /opt/netcdf-3.6.0-pathscale/include + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /opt/pathscalesoft/ARPACK + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI + LIBS += -lfmpi-pgi -lmpi-pgi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g -C +else + FFLAGS += -Ofast +endif diff --git a/Compilers/Linux-pgi.mk b/Compilers/Linux-pgi.mk new file mode 100644 index 0000000..cb2b100 --- /dev/null +++ b/Compilers/Linux-pgi.mk @@ -0,0 +1,67 @@ +# +# Include file for PGI Fortran compiler on Linux +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := pgf90 + FFLAGS := + CPP := /usr/bin/cpp + CPPFLAGS := -P -traditional -DLINUX + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /opt/pgi/netcdf/include + NETCDF_LIBDIR ?= /opt/pgi/netcdf/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /opt/pgisoft/ARPACK + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI + LIBS += -lfmpi-pgi -lmpi-pgi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g +else + FFLAGS += -u -Bstatic -fastsse -Mipa=fast +endif + + clean_list += ifc* work.pc* diff --git a/Compilers/MakeDepend b/Compilers/MakeDepend new file mode 100644 index 0000000..dffcd5e --- /dev/null +++ b/Compilers/MakeDepend @@ -0,0 +1,115 @@ +bathsoap.o: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h +bathsoap.f90: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h + +bathsuds.o: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h +bathsuds.f90: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h + +bathtub.o: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h +bathtub.f90: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h + +coast.o: coast.h proj.h +coast.f90: coast.h proj.h + +grid.o: ncgrid.h griddefs.h gridid.h grid.h bathy.h gridparam.h griddefs.h +grid.f90: ncgrid.h griddefs.h gridid.h grid.h bathy.h gridparam.h griddefs.h + +mapbath.o: griddefs.h +mapbath.f90: griddefs.h + +sphere.o: sphereflags.h ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h +sphere.f90: sphereflags.h ncgrid.h bathy.h gridparam.h griddefs.h gridid.h +sphere.f90: proj.h + +sqgrid.o: ncgrid.h griddefs.h gridid.h grid.h bathy.h gridparam.h griddefs.h +sqgrid.f90: ncgrid.h griddefs.h gridid.h grid.h bathy.h gridparam.h griddefs.h + +tolat.o: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h +tolat.f90: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h proj.h + +blktri.o: griddefs.h +blktri.f90: griddefs.h + +checkdefs.o: ncgrid.h grid.h bathy.h gridparam.h griddefs.h +checkdefs.f90: ncgrid.h grid.h bathy.h gridparam.h griddefs.h + +comf.o: griddefs.h +comf.f90: griddefs.h + +cpsfill.o: griddefs.h +cpsfill.f90: griddefs.h + +def_grid.o: ncgrid.h griddefs.h grid.h bathy.h gridparam.h griddefs.h +def_grid.f90: ncgrid.h griddefs.h grid.h bathy.h gridparam.h griddefs.h + +drawcoast.o: griddefs.h +drawcoast.f90: griddefs.h + +extract.o: griddefs.h +extract.f90: griddefs.h + +genbun.o: griddefs.h +genbun.f90: griddefs.h + +geodesic_dist.o: griddefs.h +geodesic_dist.f90: griddefs.h + +get_date.o: griddefs.h +get_date.f90: griddefs.h + +get_h.o: ncgrid.h bathy.h gridparam.h griddefs.h +get_h.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +get_lat.o: ncgrid.h bathy.h gridparam.h griddefs.h +get_lat.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +get_mn.o: ncgrid.h bathy.h gridparam.h griddefs.h +get_mn.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +get_rmask.o: ncgrid.h bathy.h gridparam.h griddefs.h +get_rmask.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +get_xy.o: ncgrid.h bathy.h gridparam.h griddefs.h +get_xy.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +gnbnaux.o: griddefs.h +gnbnaux.f90: griddefs.h + +opencdf.o: ncgrid.h bathy.h gridparam.h griddefs.h +opencdf.f90: ncgrid.h bathy.h gridparam.h griddefs.h + +ploth.o: bathy.h gridparam.h griddefs.h +ploth.f90: bathy.h gridparam.h griddefs.h + +sepaux.o: griddefs.h +sepaux.f90: griddefs.h + +sepeli.o: griddefs.h +sepeli.f90: griddefs.h + +sepx4.o: griddefs.h +sepx4.f90: griddefs.h + +start_plot.o: griddefs.h +start_plot.f90: griddefs.h + +uv_mask.o: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h +uv_mask.f90: ncgrid.h bathy.h gridparam.h griddefs.h gridid.h + +vminmax.o: griddefs.h +vminmax.f90: griddefs.h + +wrt_all.o: ncgrid.h bathy.h gridparam.h griddefs.h proj.h +wrt_all.f90: ncgrid.h bathy.h gridparam.h griddefs.h proj.h + +wrt_fhmn.o: ncgrid.h bathy.h gridparam.h griddefs.h proj.h +wrt_fhmn.f90: ncgrid.h bathy.h gridparam.h griddefs.h proj.h + +wrt_h.o: ncgrid.h bathy.h gridparam.h griddefs.h proj.h +wrt_h.f90: ncgrid.h bathy.h gridparam.h griddefs.h proj.h + +wrt_lat.o: ncgrid.h bathy.h gridparam.h griddefs.h proj.h +wrt_lat.f90: ncgrid.h bathy.h gridparam.h griddefs.h proj.h + +wrt_mask.o: ncgrid.h bathy.h gridparam.h griddefs.h +wrt_mask.f90: ncgrid.h bathy.h gridparam.h griddefs.h + diff --git a/Compilers/OSF1-f90.mk b/Compilers/OSF1-f90.mk new file mode 100644 index 0000000..3212317 --- /dev/null +++ b/Compilers/OSF1-f90.mk @@ -0,0 +1,69 @@ +# +# Include file for OSF1 F90 compiler on the Alpha +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f90 + FFLAGS := + CPP := /lib/cpp + CPPFLAGS := -P + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI + MPI_INCDIR := /usr/include + MPI_LIBDIR := /usr/lib + LIBS += -L$(MPI_LIBDIR) -lmpi + CPPFLAGS += -I$(MPI_INCDIR) +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -omp +endif + +ifdef DEBUG + FFLAGS += -g +else + FFLAGS += -fast +endif diff --git a/Compilers/SunOS-f95.mk b/Compilers/SunOS-f95.mk new file mode 100644 index 0000000..c551a05 --- /dev/null +++ b/Compilers/SunOS-f95.mk @@ -0,0 +1,74 @@ +# +# Include file for Solaris F95 compiler on SUN +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f95 + FFLAGS := -u -U + CPP := /usr/lib/cpp + CPPFLAGS := -P -DSUN + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + +ifdef LARGE + FFLAGS += -xarch=v9 + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib64 +else + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib +endif + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack_LINUX +endif + +ifdef MPI + CPPFLAGS += -DMPI + FC := tmf90 + LIBS += -lmpi +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP + FFLAGS += -openmp +endif + +ifdef DEBUG + FFLAGS += -g +else + FFLAGS += -O3 +endif + + LIBS += -lnsl diff --git a/Compilers/SunOS-ftn.mk b/Compilers/SunOS-ftn.mk new file mode 100644 index 0000000..448f6ce --- /dev/null +++ b/Compilers/SunOS-ftn.mk @@ -0,0 +1,64 @@ +# +# Include file for CRAY FTN cross-compiler with SUN +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := ftn + FFLAGS := -e I -e m + CPP := $(HOME)/bin/cpp + CPPFLAGS := -P -DCRAYX1 -DCRAY + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -rv + MKDIR := mkdir -p + RM := rm -f + RANLIB := touch + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.1-x1/include + NETCDF_LIBDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.1-x1/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -G 0 +else + FFLAGS += -O 3,aggress +endif diff --git a/Compilers/UNICOS-mk-f90.mk b/Compilers/UNICOS-mk-f90.mk new file mode 100644 index 0000000..de48635 --- /dev/null +++ b/Compilers/UNICOS-mk-f90.mk @@ -0,0 +1,63 @@ +# +# Include file for UNICOS F90 compiler on CRAY +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f90 + FFLAGS := -e I -e m + CPP := /opt/ctl/bin/cpp + CPPFLAGS := -P -N -DCRAY + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := ranlib + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g +else + FFLAGS += -O3 +endif diff --git a/Compilers/UNICOS-mp-ftn.mk b/Compilers/UNICOS-mp-ftn.mk new file mode 100644 index 0000000..121d0c6 --- /dev/null +++ b/Compilers/UNICOS-mp-ftn.mk @@ -0,0 +1,64 @@ +# +# Include file for UNICOS FTN compiler on CRAY X1 +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := ftn + FFLAGS := -e I -e m + CPP := $(HOME)/bin/cpp + CPPFLAGS := -P -DCRAYX1 -DCRAY + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := touch + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.1-x1/include + NETCDF_LIBDIR ?= /usr/local/pkg/netcdf/netcdf-3.5.1-x1/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -G 0 +else + FFLAGS += -O 3,aggress +endif diff --git a/Compilers/UNICOS-sn-f90.mk b/Compilers/UNICOS-sn-f90.mk new file mode 100644 index 0000000..6a41f12 --- /dev/null +++ b/Compilers/UNICOS-sn-f90.mk @@ -0,0 +1,64 @@ +# +# Include file for UNICOS F90 compiler on CRAY T3D +# ----------------------------------------------------------------- +# +# ARPACK_LIBDIR ARPACK libary directory +# FC Name of the fortran compiler to use +# FFLAGS Flags to the fortran compiler +# CPP Name of the C-preprocessor +# CPPFLAGS Flags to the C-preprocessor +# CLEAN Name of cleaning executable after C-preprocessing +# NETCDF_INCDIR NetCDF include directory +# NETCDF_LIBDIR NetCDF libary directory +# LD Program to load the objects into an executable +# LDFLAGS Flags to the loader +# RANLIB Name of ranlib command +# MDEPFLAGS Flags for sfmakedepend (-s if you keep .f files) +# +# First the defaults +# + FC := f90 + FFLAGS := -e Im + CPP := /opt/ctl/bin/cpp + CPPFLAGS := -P -N -DCRAY + CLEAN := Bin/cpp_clean + LD := ncargf90 + LDFLAGS := + AR := ar + ARFLAGS := -r + MKDIR := mkdir -p + RM := rm -f + RANLIB := touch + PERL := perl + TEST := test + + MDEPFLAGS := --cpp --fext=f90 --file=- + +# +# Library locations, can be overridden by environment variables. +# + + NETCDF_INCDIR ?= /usr/local/include + NETCDF_LIBDIR ?= /usr/local/lib + + CPPFLAGS += -I$(NETCDF_INCDIR) + LIBS := -L$(NETCDF_LIBDIR) -lnetcdf + +ifdef ARPACK + ARPACK_LIBDIR ?= /usr/local/lib + LIBS += -L$(ARPACK_LIBDIR) -larpack +endif + +ifdef MPI + CPPFLAGS += -DMPI +endif + +ifdef OpenMP + CPPFLAGS += -D_OPENMP +endif + +ifdef DEBUG + FFLAGS += -g -O 0 -e in -R abcnp +else + FFLAGS += -O3 +endif diff --git a/Drivers/Module.mk b/Drivers/Module.mk new file mode 100644 index 0000000..dbde200 --- /dev/null +++ b/Drivers/Module.mk @@ -0,0 +1,61 @@ +local_sub := Drivers + +local_src := $(wildcard $(local_sub)/*.F) +local_objs := $(subst .F,.o,$(local_src)) +local_objs := $(addprefix $(SCRATCH_DIR)/, $(notdir $(local_objs))) + +sources += $(local_src) + +ifeq ($(OS)-$(strip $(FORT)),CYGWIN-df) +$(COAST): $(libraries) $(SCRATCH_DIR)/coast.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/coast.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(GRID): $(libraries) $(SCRATCH_DIR)/grid.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/grid.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(SQGRID): $(libraries) $(SCRATCH_DIR)/sqgrid.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/sqgrid.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(TOLAT): $(libraries) $(SCRATCH_DIR)/tolat.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/tolat.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(BATHTUB): $(libraries) $(SCRATCH_DIR)/bathtub.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/bathtub.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(BATHSUDS): $(libraries) $(SCRATCH_DIR)/bathsuds.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/bathsuds.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(BATHSOAP): $(libraries) $(SCRATCH_DIR)/bathsoap.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/bathsoap.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +$(SPHERE): $(libraries) $(SCRATCH_DIR)/sphere.o + $(LD) $(FFLAGS) $(SCRATCH_DIR)/sphere.o $(libraries) \ + $(LIBS_WIN32) /exe:$(BIN_WIN32) /link $(LDFLAGS) +else +$(COAST): $(libraries) $(SCRATCH_DIR)/coast.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/coast.o -o $@ \ + $(libraries) $(LIBS) +$(GRID): $(libraries) $(SCRATCH_DIR)/grid.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/grid.o -o $@ \ + $(libraries) $(LIBS) +$(SQGRID): $(libraries) $(SCRATCH_DIR)/sqgrid.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/sqgrid.o -o $@ \ + $(libraries) $(LIBS) +$(TOLAT): $(libraries) $(SCRATCH_DIR)/tolat.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/tolat.o -o $@ \ + $(libraries) $(LIBS) +$(BATHTUB): $(libraries) $(SCRATCH_DIR)/bathtub.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/bathtub.o -o $@ \ + $(libraries) $(LIBS) +$(BATHSUDS): $(libraries) $(SCRATCH_DIR)/bathsuds.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/bathsuds.o -o $@ \ + $(libraries) $(LIBS) +$(BATHSOAP): $(libraries) $(SCRATCH_DIR)/bathsoap.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/bathsoap.o -o $@ \ + $(libraries) $(LIBS) +$(SPHERE): $(libraries) $(SCRATCH_DIR)/sphere.o + $(LD) $(FFLAGS) $(LDFLAGS) $(SCRATCH_DIR)/sphere.o -o $@ \ + $(libraries) $(LIBS) +endif + +$(eval $(compile-rules)) diff --git a/Drivers/bathsoap.F b/Drivers/bathsoap.F new file mode 100644 index 0000000..664019f --- /dev/null +++ b/Drivers/bathsoap.F @@ -0,0 +1,304 @@ + program bathsoap + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! This program reads and writes to the hraw variable in +! the grid netCDF file. +! +! It uses a Shapiro filter to smooth the bathymetry +! ******************************************************************* + +#include "griddefs.h" +#include "bathy.h" +#include "proj.h" +#include "ncgrid.h" + BIGREAL wrk1(L2d), wrk2(L2d) + + logical colour, grover + integer i, j, k, ii, jj, imap, npass + BIGREAL vmin, vmax, rmax, rv + real U1, U2, V1, V2 + BIGREAL udeg, uscale, DTOR, RTOD, & + & REarth, enlarge + parameter ( REarth=6.3708e6 ) + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + +#include "gridid.h" + + call get_xy + call get_mn + call get_h + call get_rmask + +! Plot after each pass of Shapiro filter + + xmin = vmin(xp,L*M) + ymin = vmin(yp,L*M) + xmax = vmax(xp,L*M) + ymax = vmax(yp,L*M) + + el = ymax-ymin + xl = xmax-xmin + +! true for colour fill plots (false gives contours) + colour = .true. + +! true to draw grid over colour plots + grover = .false. + +#if PLOTS + call start_plot +#if DRAW_COASTS +! put things on EZMAP space: + call mapsti('GR',JGRD) + call mapstc('OU','PS') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapint + +! rescale xp, yp, xr, yr (from Roberta Young) + call maptrn((PLAT+.5),PLONG,U2,V2) + call maptrn((PLAT-.5),PLONG,U1,V1) + udeg = sqrt((U2-U1)*(U2-U1) + (V2-V1)*(V2-V1)) + uscale=DTOR*REarth/udeg + write(6,*)' udeg =',udeg + write(6,*)' uscale =',uscale + + do j=1,M + do i=1,L + xp(i,j)=(xp(i,j)-XOFF)/uscale + yp(i,j)=(yp(i,j)-YOFF)/uscale + enddo + enddo + + do j=0,M + do i=0,L + xr(i,j)=(xr(i,j)-XOFF)/uscale + yr(i,j)=(yr(i,j)-YOFF)/uscale + enddo + enddo + +! find minimum x and y locations: + xmin = vmin(xp,L*M) + ymin = vmin(yp,L*M) + xmax = vmax(xp,L*M) + ymax = vmax(yp,L*M) + el = ymax-ymin + xl = xmax-xmin + +! make them larger for the plots + enlarge = 0.03 + xmin = xmin - xl*enlarge + ymin = ymin - el*enlarge + xmax = xmax + xl*enlarge + ymax = ymax + el*enlarge +#endif /* DRAW_COASTS */ + +! set foreground to black, background to white + if (colour) then + call gscr(1,0,1.,1.,1.) + call gscr(1,1,0.,0.,0.) + end if + + imap = 3 + call cpseti('MAP',imap) + call getxxyy + call pcseti('QUALITY',1) +#endif /* PLOTS */ + + print * + print *, 'How many passes of the shapiro filter?' + read *, npass + +#if PLOTS +! call ploth(gridid(1:40),colour,grover) +#endif /* PLOTS */ + + do k=1,npass + call shapiro(h,Lp,Mp,2,wrk1,wrk2,mask_rho) + rmax = 0. + ii = 1 + jj = 1 + do j=1,M-1 + do i=1,L-1 + if (rv(i,j) .gt. rmax) then + rmax = rv(i,j) + ii = i + jj = j + endif + enddo + enddo + print *,k,' rmax = ',rmax,' at (i,j): ',ii,jj + enddo + +! Write the final filtered bathymetry to netCDF file + call wrt_h + +#if PLOTS +! Plot the final bathymetry + call ploth(gridid(1:40),colour,grover) + call end_plot +#endif /* PLOTS */ + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 100 call crash('bathsoap: read or write error', 0) + end + +! ******************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end + +! **************************************************************** + + subroutine shapiro(u,Lp,Mp,N,tmp,tmp2,mask) + integer Lp, Mp, N + BIGREAL u(0:Lp-1,0:Mp-1) + BIGREAL mask(0:Lp-1,0:Mp-1) + BIGREAL tmp(0:Lp-1,0:Mp-1), tmp2(0:Lp-1,0:Mp-1) + +! **************************************************************** + +! Version 1.0 April 27,1988 by Kate Hedstrom + +! **************************************************************** + +! The user must supply two work arrays, tmp and tmp2, dimensioned +! the same as the u array. + +! This subroutine will apply a Shapiro filter of order n (defined +! as twice the order in Shapiro (1970), with N even) to an +! array u. The order of the filter is reduced at the boundaries. +! The size of the u array is 0-L by 0-M. + +! This filter can be used for any rectangular grid. If the grid +! spacing is non-uniform then you have to scale by the grid spacing +! before filtering and scale back after filtering in order to +! conserve the quantity. If conservation is not important then the +! filter can be used as is even for non-uniform spacing. + + integer d, L, M, Lm, Mm, i, j, k + + L = Lp-1 + M = Mp-1 + Lm = Lp-2 + Mm = Mp-2 + + if (mod(N,2).ne.0) then + print *,'N must be even in the shapiro filter' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end if + +! Do the first y pass to initialize the temporary array + + do 100 i=0,L + do 100 j=1,M-1 + tmp(i,j) = 0.25 * (u(i,j-1)*mask(i,j-1) + u(i,j+1)*mask(i,j+1) & + & - 2*u(i,j)*mask(i,j)) * & + & mask(i,j-1) * mask(i,j+1) * mask(i,j) + 100 continue + +! Other passes in the y direction. + + do 120 k=4,N,2 + d = k/2 + do 110 j=d,M-d + do 110 i=0,L + tmp2(i,j) = - 0.25 * (tmp(i,j-1)*mask(i,j-1) & + & + tmp(i,j+1)*mask(i,j+1) & + & - 2*tmp(i,j)*mask(i,j)) * & + & mask(i,j-1) * mask(i,j+1) * mask(i,j) + 110 continue + do 120 j=d,M-d + do 120 i=0,L + tmp(i,j) = tmp2(i,j) + 120 continue + +! Add the changes to u + + do 130 j=1,M-1 + do 130 i=0,L + u(i,j) = u(i,j) + tmp(i,j) + 130 continue + +! Initialize tmp to filter in the x direction. + + do 140 j=0,M + do 140 i=1,L-1 + tmp(i,j) = 0.25 * (u(i-1,j)*mask(i-1,j) + u(i+1,j)*mask(i+1,j) & + & - 2*u(i,j)*mask(i,j)) * & + & mask(i-1,j) * mask(i+1,j) * mask(i,j) + 140 continue + +! Other x passes + + do 160 k=4,N,2 + d = k/2 + do 160 j=0,M + do 150 i=d,L-d + tmp2(i,j) = - 0.25 * (tmp(i-1,j)*mask(i-1,j) & + & + tmp(i+1,j)*mask(i+1,j) & + & - 2*tmp(i,j)*mask(i,j)) * & + & mask(i-1,j) * mask(i+1,j) * mask(i,j) + 150 continue + do 160 i=d,L-d + tmp(i,j) = tmp2(i,j) + 160 continue + +! Add changes to u + + do 170 j=0,M + do 170 i=1,L-1 + u(i,j) = u(i,j) + tmp(i,j) + 170 continue + +! Make edge values like interior + do 180 j=1,Mm + u(0,j) = u(1,j) + u(L,j) = u(Lm,j) + 180 continue + do 190 i=0,L + u(i,0) = u(i,1) + u(i,M) = u(i,Mm) + 190 continue + + return + end + + BIGREAL function rv(i,j) + integer i, j + +! calculate the SPEM r-value +#include "bathy.h" + BIGREAL dhdxx, dhdyy + + dhdxx = abs((h(i,j) - h(i-1,j)) / (h(i,j) + h(i-1,j))) & + & * mask_rho(i,j) * mask_rho(i-1,j) + dhdyy = abs((h(i,j) - h(i,j-1)) / (h(i,j) + h(i,j-1))) & + & * mask_rho(i,j) * mask_rho(i,j-1) + rv = max(dhdxx,dhdyy) + return + end diff --git a/Drivers/bathsuds.F b/Drivers/bathsuds.F new file mode 100644 index 0000000..1e3a921 --- /dev/null +++ b/Drivers/bathsuds.F @@ -0,0 +1,415 @@ +#include "griddefs.h" + program bathsuds + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! bathsuds (Selective User-Defined Smoothing) is a variation on +! bathsoap (Smooth Over All Points) which allows the user to fiddle +! endlessly with a set of weights applied to the Shapiro filter. +! functions rvwgt{x,y} weight the correction term over the Shapiro +! filter (whicyh are usually 1). For example, if repeated sweeps of +! the filter are being used to eliminate isolated steep regions of the +! bathymetry, the rvwgt{x,y} weights can be set to zero over the +! already smooth region to avoid needlessly reducing the domain to a +! flat abyssal plain. +! +! The present set of weights does this by computing Aike's r-value +! and setting the weights to rvwmin where r-value is less than rv0, +! and rvwmax where r-value is greater than rv0 (with a smooth tanh +! transition between the two). rvwmax > 1.0 amounts to a successive +! over-relaxation of the fliter weights. Alternatively, making rvwgt +! simple functions of i,j will apply the filtering to predetermined +! regions of the domain. +! +! There is now a KEEP_SHALLOW option to uplift the shallow areas after +! each pass of the filter. There are tunable parameters to specify +! the shallow depths which are being attempted to be kept - the +! shallower the values you pick, the harder it is to get to a useful +! r-value. With KEEP_SHALLOW defined, you are likely to need many +! more passes of the filter. For instance, a domain in which you +! achieved a reasonable r-value after 20 passes may now require +! several hundred or a thousand passes. Note that you can do +! something similar to keep deep areas deep. This can be useful +! in regions surrounded by a coasts that would otherwise get too +! shallow, such as in the Caribbean. +! +! This program reads and writes to the hraw variable in the +! grid netCDF file. +! +! ******************************************************************* + +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" + BIGREAL wrk1(L2d), wrk2(L2d) + logical colour, grover + integer imap, npasses, i, j, k, ii, jj + BIGREAL vmin, vmax, rv, rmax + real U1, U2, V1, V2 + BIGREAL udeg, uscale, DTOR, RTOD, & + & REarth, enlarge + parameter ( REarth=6.3708e6 ) + integer np, Lm2, Mm2 + common /bidul/ np +#if KEEP_SHALLOW + logical mask1(0:L,0:M), mask2(0:L,0:M), mask3(0:L,0:M) + BIGREAL depth1, depth2, depth3 + parameter ( depth1=200, depth2=400, depth3=1000 ) +#endif /* KEEP_SHALLOW */ + parameter ( Lm2=L-2, Mm2=M-2 ) + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + +#include "gridid.h" + + call get_xy + call get_mn + call get_h + call get_rmask + + xmin = vmin(xr,Lp*Mp) + ymin = vmin(yr,Lp*Mp) + xmax = vmax(xr,Lp*Mp) + ymax = vmax(yr,Lp*Mp) + + el = ymax-ymin + xl = xmax-xmin + +! true for colour fill plots (false gives contours) + colour = .true. + +! true to draw grid over colour plots + grover = .false. + +#if PLOTS + call start_plot +#if DRAW_COASTS +! put things on EZMAP space: + call mapsti('GR',JGRD) + call mapstc('OU','PS') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapint + +! rescale xp, yp, xr, yr (from Roberta Young) + call maptrn((PLAT+.5),PLONG,U2,V2) + call maptrn((PLAT-.5),PLONG,U1,V1) + udeg = sqrt((U2-U1)*(U2-U1) + (V2-V1)*(V2-V1)) + uscale=DTOR*REarth/udeg + write(6,*)' udeg =',udeg + write(6,*)' uscale =',uscale + + do j=1,M + do i=1,L + xp(i,j)=(xp(i,j)-XOFF)/uscale + yp(i,j)=(yp(i,j)-YOFF)/uscale + enddo + enddo + + do j=0,M + do i=0,L + xr(i,j)=(xr(i,j)-XOFF)/uscale + yr(i,j)=(yr(i,j)-YOFF)/uscale + enddo + enddo + +! find minimum x and y locations: + xmin = vmin(xp,L*M) + ymin = vmin(yp,L*M) + xmax = vmax(xp,L*M) + ymax = vmax(yp,L*M) + el = ymax-ymin + xl = xmax-xmin + +! make them larger for the plots + enlarge = 0.03 + xmin = xmin - xl*enlarge + ymin = ymin - el*enlarge + xmax = xmax + xl*enlarge + ymax = ymax + el*enlarge +#endif /* DRAW_COASTS */ + +! set foreground to black, background to white + if (colour) then + call gscr(1,0,1.,1.,1.) + call gscr(1,1,0.,0.,0.) + end if + + imap = 3 + call cpseti('MAP',imap) + call getxxyy + call pcseti('QUALITY',1) + + call ploth(gridid(1:40),colour,grover) +#endif /* PLOTS */ + +#if KEEP_SHALLOW + do j=0,M + do i=0,L + mask1(i,j) = .false. + mask2(i,j) = .false. + mask3(i,j) = .false. + enddo + enddo + do j=0,M + do i=0,L + if (h(i,j) .lt. depth1) mask1(i,j) = .true. + if (h(i,j) .lt. depth2) mask2(i,j) = .true. + if (h(i,j) .lt. depth3) mask3(i,j) = .true. + enddo + enddo +#endif /* KEEP_SHALLOW */ + + print *,' Enter number of passes of filter:' + read(5,*) npasses + + do 120 k=1,npasses + +#if KEEP_SHALLOW +! Keep shallow areas shallow + if (k .le. npasses-2) then + do j=0,M + do i=0,L + if (h(i,j) .gt. depth1 .and. mask1(i,j)) h(i,j) = depth1 + if (h(i,j) .gt. depth2 .and. mask2(i,j)) h(i,j) = depth2 + if (h(i,j) .gt. depth3 .and. mask3(i,j)) h(i,j) = depth3 + enddo + enddo + endif +#endif /* KEEP_SHALLOW */ + + call shapiro(h,Lp,Mp,2,wrk1,wrk2) +! call ploth(gridid(1:40),colour,grover) +! zero slope on h at boundaries + do i=1,Lm + h(i,0) = h(i,1) + h(i,M) = h(i,Mm) + enddo + do j=0,M + h(0,j) = h(1,j) + h(L,j) = h(Lm,j) + enddo + + rmax = 0. + ii = 1 + jj = 1 + do j=1,M-1 + do i=1,L-1 + if (rv(i,j) .gt. rmax) then + rmax = rv(i,j) + ii = i + jj = j + endif + enddo + enddo + print *,k,' rmax = ',rmax,' at (i,j): ',ii,jj + + 120 continue + +! Write the final filtered bathymetry to netCDF file + + call wrt_h + +#if PLOTS +! Plot the final bathymetry + call ploth(gridid(1:40),colour,grover) + call end_plot +#endif /* PLOTS */ + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 130 call crash('bathsuds: read or write error ',0) + end + +! ******************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end + +! **************************************************************** + + subroutine shapiro(u,Lp,Mp,N,tmp,tmp2) + integer Lp, Mp, N + BIGREAL u(0:Lp-1,0:Mp-1) + BIGREAL tmp(0:Lp-1,0:Mp-1), tmp2(0:Lp-1,0:Mp-1) + +! **************************************************************** + +! Version 1.0 April 27,1988 by Kate Hedstrom +! hacked about by John Wilkin 28 June 29, 1991 + +! **************************************************************** + +! The user must supply two work arrays, tmp and tmp2, dimensioned +! the same as the u array. + +! This subroutine will apply a Shapiro filter of order n (defined +! as twice the order in Shapiro (1970), with N even) to an +! array u. The order of the filter is reduced at the boundaries. +! The size of the u array is 0-L by 0-M. + +! This filter can be used for any rectangular grid. If the grid +! spacing is non-uniform then you have to scale by the grid spacing +! before filtering and scale back after filtering in order to +! conserve the quantity. If conservation is not important then the +! filter can be used as is even for non-uniform spacing. + + integer d, L, M, i, j, k + BIGREAL rvwgtx, rvwgty + + L = Lp-1 + M = Mp-1 + + if (mod(N,2).ne.0) then + print *,'N must be even in the shapiro filter' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end if + +! Do the first y pass to initialize the temporary array + + do 100 i=0,L + do 100 j=1,M-1 + tmp(i,j) = 0.25 * (u(i,j-1) + u(i,j+1) - 2*u(i,j)) + 100 continue + +! Other passes in the y direction. + + do 120 k=4,N,2 + d = k/2 + do 110 j=d,M-d + do 110 i=0,L + tmp2(i,j) = - 0.25 * (tmp(i,j-1) + tmp(i,j+1) & + & - 2*tmp(i,j)) + 110 continue + do 120 j=d,M-d + do 120 i=0,L + tmp(i,j) = tmp2(i,j) + 120 continue + +! Add the changes to u + + do 130 j=1,M-1 + do 130 i=0,L + u(i,j) = u(i,j) + rvwgty(i,j)*tmp(i,j) + 130 continue + +! Initialize tmp to filter in the x direction. + + do 140 j=0,M + do 140 i=1,L-1 + tmp(i,j) = 0.25 * (u(i-1,j) + u(i+1,j) - 2*u(i,j)) + 140 continue + +! Other x passes + + do 160 k=4,N,2 + d = k/2 + do 160 j=0,M + do 150 i=d,L-d + tmp2(i,j) = - 0.25 * (tmp(i-1,j) + tmp(i+1,j) & + & - 2*tmp(i,j)) + 150 continue + do 160 i=d,L-d + tmp(i,j) = tmp2(i,j) + 160 continue + +! Add changes to u + + do 170 j=0,M + do 170 i=1,L-1 + u(i,j) = u(i,j) + rvwgtx(i,j)*tmp(i,j) + 170 continue + + return + end + +! ******************************************************************** + + BIGREAL function rvwgtx(i,j) + integer i, j + BIGREAL rv0, rvwscl,rvwmin, rvwmax, dhdxx1, dhdxx2, dhdxx, & + & rvwavg, rvwrng + +#include "bathy.h" + + rv0 = 0.15 + rvwscl = 0.04 + rvwmin = 0.0 + rvwmax = 1.2 + rvwavg = 0.5*(rvwmin+rvwmax) + rvwrng = 0.5*(rvwmax-rvwmin) + + dhdxx1 = abs((h(i,j) - h(i-1,j)) / (h(i,j) + h(i-1,j))) & + & * mask_rho(i,j) * mask_rho(i-1,j) + dhdxx2 = abs((h(i+1,j) - h(i,j)) / (h(i,j) + h(i+1,j))) & + & * mask_rho(i,j) * mask_rho(i+1,j) + dhdxx = max(dhdxx1,dhdxx2) + + rvwgtx = rvwavg + rvwrng*(tanh((dhdxx-rv0)/rvwscl)) +! if (i .ge. 60) rvwgtx = max(rvwgtx,1.6) + return + end + +! ******************************************************************** + + BIGREAL function rvwgty(i,j) + integer i, j + BIGREAL rv0, rvwscl,rvwmin, rvwmax, & + & rvwavg, rvwrng, dhdyy1, dhdyy2, dhdyy + +#include "bathy.h" + + rv0 = 0.15 + rvwscl = 0.04 + rvwmin = 0.0 + rvwmax = 1.2 + rvwavg = 0.5*(rvwmin+rvwmax) + rvwrng = 0.5*(rvwmax-rvwmin) + dhdyy1 = abs((h(i,j) - h(i,j-1)) / (h(i,j) + h(i,j-1))) & + & * mask_rho(i,j) * mask_rho(i,j-1) + dhdyy2 = abs((h(i,j+1) - h(i,j)) / (h(i,j) + h(i,j+1))) & + & * mask_rho(i,j) * mask_rho(i,j+1) + dhdyy = max(dhdyy1,dhdyy2) + + rvwgty = rvwavg + rvwrng*(tanh((dhdyy-rv0)/rvwscl)) +! if (i .ge. 60) rvwgty = max(rvwgty,1.6) + return + end + +! ******************************************************************** + + BIGREAL function rv(i,j) + integer i, j + +! calculate the SPEM r-value +#include "bathy.h" + BIGREAL dhdxx, dhdyy + + dhdxx = abs((h(i,j) - h(i-1,j)) / (h(i,j) + h(i-1,j))) & + & * mask_rho(i,j) * mask_rho(i-1,j) + dhdyy = abs((h(i,j) - h(i,j-1)) / (h(i,j) + h(i,j-1))) & + & * mask_rho(i,j) * mask_rho(i,j-1) + rv = max(dhdxx,dhdyy) + return + end diff --git a/Drivers/bathtub.F b/Drivers/bathtub.F new file mode 100644 index 0000000..c006c8f --- /dev/null +++ b/Drivers/bathtub.F @@ -0,0 +1,564 @@ + program bathtub + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! This program reads in the bathymetric data as well as the lat,long +! points at which depth is carried in SPEM. It interpolates the +! bathymetry to those grid points by a bilinear fit from the four +! nearest neighbors. The bathymetry data used is the ETOPO5 +! bathymetry read from the netCDF file. It is stored at +! 5 minute intervals (1/12 degrees = DELTA_X, DELTA_Y). +! +! ILAT is # of latitude grid points; +! ILON is # of longitude grid points. +! NSUB decimates the input data -- solely for plotting purposes to +! avoid overflowing conpack work arrays. +!******************************************************************** + +#include "griddefs.h" +#include "bathy.h" +#include "ncgrid.h" + integer Lm2, Mm2 + parameter ( Lm2=L-2, Mm2=M-2 ) + integer ILON, ILAT + BIGREAL DELTA_X, DELTA_Y + logical evenflag +#if NJB + parameter ( evenflag = .true. ) + parameter ( ILAT=1319, ILON=2600 ) + parameter ( DELTA_X=1/120.d0, DELTA_Y=1/120.d0 ) +#elif ETOPO5 + parameter ( evenflag = .true. ) + parameter ( ILON=360*12+1, ILAT=180*12+1 ) + parameter ( DELTA_X=1/12.d0, DELTA_Y=1/12.d0 ) + integer*2 bathy2(ILON-1,ILAT) +#elif ETOPO2 + parameter ( evenflag = .true. ) + parameter ( ILON=360*30+1, ILAT=180*30+1 ) + parameter ( DELTA_X=1/30.d0, DELTA_Y=1/30.d0 ) + integer*2 bathy2(ILON-1,ILAT) +#elif GEBCO + parameter ( evenflag = .true. ) + parameter ( ILON=360*60+1, ILAT=180*60+1 ) + parameter ( DELTA_X=1/60.d0, DELTA_Y=1/60.d0 ) +#else + parameter ( evenflag = .true. ) +! Seth's AK bathy + parameter ( ILON=6601, ILAT=3601) + parameter ( DELTA_X=1/60.d0, DELTA_Y=1/120.d0) +! parameter ( ILON=2601, ILAT=1401, DELTA=1/30.d0) +! Hank's CGOA +! parameter ( ILON=1861, ILAT=1093, DELTA=1/60.d0) +! Smith and Sandwell +! parameter ( evenflag = .false. ) +! parameter ( ILON=1771, ILAT=1978) + +#endif /* DAMEE */ + integer*2 bathy(ILON,ILAT) + BIGREAL lat(ILAT), lon(ILON) + common /ll/ lat, lon + BIGREAL corner(2,2), dx, dy + BIGREAL minlat, minlon, maxlat, maxlon + + integer NSUB, LONSUB, LATSUB + parameter(NSUB = ILON/250+ILAT/250) + parameter(LONSUB=(ILON-1)/NSUB, LATSUB=(ILAT-1)/NSUB ) + real tmp(LONSUB,LATSUB), htmp(0:L,0:M) + character*24 lbl + real alatn, alats, alonw, alone + BIGREAL depthmxr, depthmnr, & + & htmp1, htmp2, x1, y1 + BIGREAL vmin, vmax + integer*2 vsimin, vsimax + integer i, j, i1, j1 + BIGREAL zero, one + parameter ( zero=0.d0, one=1.d0 ) + integer find_i, find_j + logical mask_flag +#if IMG_AVG + integer i2, j2, ii, jj, np + BIGREAL aa, bb, cc, dd +#endif /* IMG_AVG */ + +#include "gridid.h" + +! depths less than depthmin will be set to depthmin + print *, 'minimum depth (negative is land elevation)' + read(5,*) depthmin +! depths greater than depthmax will be set to depthmax + print *, 'maximum depth' + read(5,*) depthmax + print *, 'apply mask? (T/F)' + read(5,*) mask_flag + +#if ETOPO5 || ETOPO2 + call extract(lon,lat,bathy2,ILON-1,ILAT) + +! Longitudes between 0 and 360 + lon(ILON) = 180. + do i=1,ILON + if (lon(i) .lt. 0.) lon(i) = lon(i) + 360. + enddo + +! Copy value at one end of the Earth to other end + do i=1,ILON-1 + do j=1,ILAT + bathy(i,j) = bathy2(i,j) + enddo + enddo + do j=1,ILAT + bathy(ILON,j) = bathy(1,j) + enddo +#else + call extract(lon,lat,bathy,ILON,ILAT) + +! Longitudes between 0 and 360 + do i=1,ILON + if (lon(i) .lt. 0.) lon(i) = lon(i) + 360. + enddo +#endif /* ETOPO5 || ETOPO2 */ + +! Our convention has been negative for land elevations + do j=1,ILAT + do i=1,ILON + bathy(i,j) = -bathy(i,j) + enddo + enddo + + alatn = lat(ILAT) + alats = lat(1) + alonw = vmin(lon,ILON) + alone = vmax(lon,ILON) + + depthmxr = vsimax(bathy,ILON*ILAT) + print *,' Maximum depth read is ',depthmxr + depthmnr = vsimin(bathy,ILON*ILAT) + print *,' Minimum depth read is ',depthmnr + + call get_lat + + minlat = vmin(lat_rho,Lp*Mp) + minlon = vmin(lon_rho,Lp*Mp) + maxlat = vmax(lat_rho,Lp*Mp) + maxlon = vmax(lon_rho,Lp*Mp) + +#if ETOPO5 + if (minlon .lt. 0.) then +#endif /* ETOPO5 */ + do j=0,M + do i=0,L + if (lon_rho(i,j) .lt. 0.) lon_rho(i,j) = lon_rho(i,j) + 360. + enddo + enddo + minlon = vmin(lon_rho,Lp*Mp) + maxlon = vmax(lon_rho,Lp*Mp) +#if ETOPO5 + endif +#endif /* ETOPO5 */ + + print *,'latitude range of grid ',minlat,maxlat + print *,'latitude range of data ',alats,alatn + print *,'longitute range of grid ',minlon,maxlon + print *,'longitute range of data ',alonw,alone + if (minlat .lt. alats .or. maxlat .gt. alatn) then + print *,'Insufficient latitude range of data' + print *,'try again ... ' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end if + if (minlon .lt. alonw .or. maxlon .gt. alone) then + print *,'Insufficient longitute range of data' + print *,'try again ... ' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end if + +! h at lat_rho, lon_rho, before h is clipped + +#if IMG_AVG +! h at lat_rho, lon_rho + + do j=1,Mm + do i=1,Lm + aa = lat_v(i,j) + bb = lat_v(i,j+1) + cc = lon_u(i,j) + dd = lon_u(i+1,j) + + call locate(lon,ILON,cc,i1) + call locate(lon,ILON,dd,i2) + call locate(lat,ILAT,aa,j1) + call locate(lat,ILAT,bb,j2) + + np=0 + h(i,j) = 0. + do jj=j1+1,j2 + do ii=i1+1,i2 + h(i,j)=h(i,j)+bathy(ii,jj) + if(bathy(ii,jj).ne.0.) np=np+1 + enddo + enddo + if (np .ne. 0) h(i,j)=h(i,j)/float(np) + enddo + enddo + +! Valeurs au bord + do i=1,Lm + h(i,0)=h(i,1) + h(i,M)=h(i,Mm) + enddo + do j=0,M + h(0,j)=h(1,j) + h(L,j)=h(Lm,j) + enddo +#else + if (evenflag) then + do i=0,L + do j=0,M + i1 = int((lon_rho(i,j) - alonw)/DELTA_X) + 1 + j1 = int((lat_rho(i,j) - alats)/DELTA_Y) + 1 + x1 = lon_rho(i,j) - (alonw + (i1-1.)*DELTA_X) + y1 = lat_rho(i,j) - (alats + (j1-1.)*DELTA_Y) + corner(1,1) = bathy(i1,j1) + corner(1,2) = bathy(i1,j1+1) + corner(2,1) = bathy(i1+1,j1) + corner(2,2) = bathy(i1+1,j1+1) + htmp1 = corner(1,1) + (corner(2,1)-corner(1,1))*x1/DELTA_X + htmp2 = corner(1,2) + (corner(2,2)-corner(1,2))*x1/DELTA_X + h(i,j) = htmp1 + (htmp2-htmp1)*y1/DELTA_Y + enddo + enddo + else + do i=0,L + do j=0,M + i1 = find_i(lon_rho(i,j),ILON,lon) + j1 = find_j(lat_rho(i,j),ILAT,lat) + x1 = lon_rho(i,j) - lon(i1) + y1 = lat_rho(i,j) - lat(j1) + corner(1,1) = bathy(i1,j1) + corner(1,2) = bathy(i1,j1+1) + corner(2,1) = bathy(i1+1,j1) + corner(2,2) = bathy(i1+1,j1+1) + dx = lon(i1+1) - lon(i1) + dy = lat(j1+1) - lat(j1) + htmp1 = corner(1,1) + (corner(2,1)-corner(1,1))*x1/dx + htmp2 = corner(1,2) + (corner(2,2)-corner(1,2))*x1/dx + h(i,j) = htmp1 + (htmp2-htmp1)*y1/dy + enddo + enddo + endif +#endif /* IMG_AVG */ + +! calculate mask from bathymetry + if (mask_flag) then + do i=0,L + do j=0,M + if (h(i,j) .le. 0.) then + mask_rho(i,j) = zero + else + mask_rho(i,j) = one + endif + enddo + enddo + call uv_mask + +! Write mask + call wrt_mask + endif +! Write unclipped bathymetry + call wrt_h + +! Now clip bathy values before interpolating h again + if (depthmnr .lt. depthmin) then + do j=1,ILAT + do i=1,ILON + bathy(i,j) = max(depthmin,bathy(i,j)) + enddo + enddo + print *,' There were depths less than ',depthmin + print *,' These were set to ',depthmin + endif + if (depthmxr .gt. depthmax) then + do j=1,ILAT + do i=1,ILON + bathy(i,j) = min(depthmax,bathy(i,j)) + enddo + enddo + print *,' There were depths greater than ',depthmax + print *,' These were set to ',depthmax + endif + +! h at lat_rho, lon_rho, take 2 +#if IMG_AVG +! h at lat_rho, lon_rho + do j=1,Mm + do i=1,Lm + aa = lat_v(i,j) + bb = lat_v(i,j+1) + cc = lon_u(i,j) + dd = lon_u(i+1,j) + + call locate(lon,ILON,cc,i1) + call locate(lon,ILON,dd,i2) + call locate(lat,ILAT,aa,j1) + call locate(lat,ILAT,bb,j2) + + np=0 + h(i,j) = 0. + do jj=j1+1,j2 + do ii=i1+1,i2 + h(i,j)=h(i,j)+bathy(ii,jj) + if(bathy(ii,jj).ne.0.) np=np+1 + enddo + enddo + if (np .ne. 0) h(i,j)=h(i,j)/float(np) + enddo + enddo + +! Valeurs au bord + do i=1,Lm + h(i,0)=h(i,1) + h(i,M)=h(i,Mm) + enddo + do j=0,M + h(0,j)=h(1,j) + h(L,j)=h(Lm,j) + enddo +#else + if (evenflag) then + do i=0,L + do j=0,M + i1 = int((lon_rho(i,j) - alonw)/DELTA_X) + 1 + j1 = int((lat_rho(i,j) - alats)/DELTA_Y) + 1 + x1 = lon_rho(i,j) - (alonw + (i1-1.)*DELTA_X) + y1 = lat_rho(i,j) - (alats + (j1-1.)*DELTA_Y) + corner(1,1) = bathy(i1,j1) + corner(1,2) = bathy(i1,j1+1) + corner(2,1) = bathy(i1+1,j1) + corner(2,2) = bathy(i1+1,j1+1) + htmp1 = corner(1,1) + (corner(2,1)-corner(1,1))*x1/DELTA_X + htmp2 = corner(1,2) + (corner(2,2)-corner(1,2))*x1/DELTA_X + h(i,j) = htmp1 + (htmp2-htmp1)*y1/DELTA_Y + enddo + enddo + else + do i=0,L + do j=0,M + i1 = find_i(lon_rho(i,j),ILON,lon) + j1 = find_j(lat_rho(i,j),ILAT,lat) + x1 = lon_rho(i,j) - lon(i1) + y1 = lat_rho(i,j) - lat(j1) + corner(1,1) = bathy(i1,j1) + corner(1,2) = bathy(i1,j1+1) + corner(2,1) = bathy(i1+1,j1) + corner(2,2) = bathy(i1+1,j1+1) + dx = lon(i1+1) - lon(i1) + dy = lat(j1+1) - lat(j1) + htmp1 = corner(1,1) + (corner(2,1)-corner(1,1))*x1/dx + htmp2 = corner(1,2) + (corner(2,2)-corner(1,2))*x1/dx + h(i,j) = htmp1 + (htmp2-htmp1)*y1/dy + enddo + enddo + endif +#endif /* IMG_AVG */ + +! write clipped bathymetry + call wrt_h + +#if PLOTS +! Plot the original topography + call start_plot + +! set foreground to black, background to white + call gscr(1,0,1.,1.,1.) + call gscr(1,1,0.,0.,0.) + + call pcseti('QUALITY',1) + write(lbl,200) + 200 format('Bottom Topography') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,lbl,.012,0.,0.) + do j=1,LATSUB + do i=1,LONSUB + tmp(i,j)=bathy(NSUB*i,NSUB*j) + enddo + enddo + call set(.05,.95,.25,.95,1.,float(LONSUB),1.,float(LATSUB),1) + call perim(1,ILON/12,1,ILAT/12) + call cpseti('SET',0) + call cpshift(tmp,LONSUB,LONSUB,LATSUB,0.,.false.,1.) + call frame +! set foreground to black, background to white + call gscr(1,0,1.,1.,1.) + call gscr(1,1,0.,0.,0.) + call cpsfill(tmp,LONSUB,LONSUB,LATSUB,5,2,.false.,.false.) + call frame + +! Plot the topography on the grid + + do j=0,M + do i=0,L + htmp(i,j)=h(i,j) + enddo + enddo + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,lbl,.012,0.,0.) + call set(.05,.95,.05,.95,1.,float(Lp),1.,float(Mp),1) + call perim(1,L,1,M) + call cpcnrc(htmp,Lp,Lp,Mp,0.,0.,0.,1,-1,-682) + call frame + call end_plot +#endif /* PLOTS */ + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 220 call crash('bathtub: read error', 0) + end + +! ****************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end + +! *********************************************************** + + integer*2 function vsimax(vect,N) + integer N + integer*2 vect(N) + integer*2 tmp + integer i + + tmp = vect(1) + do i=2,N + tmp = max(tmp,vect(i)) + enddo + vsimax = tmp + return + end + + integer*2 function vsimin(vect,N) + integer N + integer*2 vect(N) + integer*2 tmp + integer i + + tmp = vect(1) + do i=2,N + tmp = min(tmp,vect(i)) + enddo + vsimin = tmp + return + end + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + subroutine locate(xx,n,x,j) + + integer j,n + BIGREAL xx(n) + BIGREAL x + integer jl,jm,ju + + jl=0 + ju=n+1 + 10 if (ju-jl .gt. 1) then + jm=(ju+jl)/2 + if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then + jl=jm + else + ju=jm + endif + goto 10 + endif + j=jl + return + end + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + function find_i(lon_rho,ILON,lon) + integer find_i + BIGREAL lon_rho + integer ILON + real lon(ILON) + integer mid, high, low + + low = 1 + high = ILON + mid = (high+low)/2 + + do while (.true.) + if (lon_rho .gt. lon(mid)) then + low = mid + mid = (high+low)/2 + if (high - low .eq. 1) then + find_i = low + return + endif + else + high = mid + mid = (high+low)/2 + if (high - low .eq. 1) then + find_i = low + return + endif + endif + enddo + + end + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + function find_j(lat_rho,ILAT,lat) + integer find_j + BIGREAL lat_rho + integer ILAT + real lat(ILAT) + integer mid, high, low + + low = 1 + high = ILAT + mid = (high+low)/2 + + do while (.true.) + if (lat_rho .gt. lat(mid)) then + low = mid + mid = (high+low)/2 + if (high - low .eq. 1) then + find_j = low + return + endif + else + high = mid + mid = (high+low)/2 + if (high - low .eq. 1) then + find_j = low + return + endif + endif + enddo + + end diff --git a/Drivers/coast.F b/Drivers/coast.F new file mode 100644 index 0000000..25da802 --- /dev/null +++ b/Drivers/coast.F @@ -0,0 +1,232 @@ + program coast1 + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! +! This program converts a coastline given in Latitude-Longitude pairs +! into meters on a plane for use by the grid generation program. +! The plane projection is any one of the ten provided by the +! NCAR Graphics routines in EZMAP. See the EZMAP manual for a +! description of its (many) subroutines and their parameters. +! +! backward is a logical variable which is true if you read in the +! data in the direction opposite to the direction it should be +! written out for the grid program. +! ******************************************************************* + +#include "coast.h" +#include "proj.h" + +! Earth angular frequency and radius of sphere of equal volume + real Aomega, REarth + parameter ( Aomega=7.292115e-5 , REarth=6.3708e6 ) + + real s(IBIG), u(IBIG), v(IBIG), x(IBIG), y(IBIG) + real xwrk(IBIG), ywrk(IBIG) + character*21 ident + real DTOR, RTOD + integer i, nn + real u1, v1, u2, v2, udeg, s1 + + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + + call opngks + call pcseti('QUALITY',1) + +! The map of the coastline database + + write(ident,100) + 100 format(' EZMAP Coast Database') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ident,.012,0.,0.) + call mapsti('GR',JGRD) + call mapstc('OU','PS') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapdrw + call frame + +! The map of your coastline + + call cstiput(nn) + write(ident,110) + 110 format('Digitized Coastline') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ident,.012,0.,0.) + call mapstc('OU','NO') + call mapset(JLTS,P1,P2,P3,P4) + call mapdrw + + call mapit(clat(1),clong(1),0) + do i=2,nn + call mapit(clat(i),clong(i),2) + enddo + call mapiq + call frame + + call maptrn(PLAT+.5,PLONG,u2,v2) + call maptrn(PLAT-.5,PLONG,u1,v1) + udeg = sqrt((u2-u1)*(u2-u1) + (v2-v1)*(v2-v1)) + do i=1,nn + call maptrn(clat(i),clong(i),u(i),v(i)) + x(i) = u(i)*DTOR*REarth/udeg + XOFF + y(i) = v(i)*DTOR*REarth/udeg + YOFF + enddo + + open(unit=60,form='FORMATTED') + write(60,*) nn + if (backward) then + do i=nn,1,-1 + write(60,*) x(i),' ',y(i) + enddo + else + do i=1,nn + write(60,*) x(i),' ',y(i) + enddo + end if + close(60) + +! Everything up to this point is generic. What follows should +! use the same interpolation scheme that the grid program uses. + +! The map of your coastline, interpolated by cubic splines + + write(ident,120) + 120 format('Spline Smoothed Coast') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ident,.012,0.,0.) + call mapset(JLTS,P1,P2,P3,P4) + call mapdrw + + do i=1,nn + s(i) = (i-1.)/(nn-1.) + enddo + call spline(s,u,nn,1.e30,1.e30,xwrk) + call spline(s,v,nn,0.,0.,ywrk) + + call frstd(u(1),v(1)) + do i=1,400 + s1 = i/400. + call splint(s,u,xwrk,nn,s1,u1) + call splint(s,v,ywrk,nn,s1,v1) + call vectd(u1,v1) + enddo + call mapiq + call frame + + call clsgks +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + end + +!********************************************************************* + + subroutine cstiput(nn) + integer nn +#include "coast.h" + +! I want a "while (scanf() != EOF)", but I have to fake it. + do nn=1,IBIG + read(5,*,err=120,end=110) clat(nn),clong(nn) + enddo + +! If you get here then you have not reached the EOF mark + print *,'Array size too small for the number of points' + print *,'in coastline data file. Only the first ',IBIG + print *,'points will be used.' + + 110 continue + nn = nn-1 + print *,'Number of points read = ',nn + return + 120 print *,'read error in cstiput' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end + +! ********************************************************************** + + subroutine spline(x,y,N,yp1,ypn,y2) + integer N + real x(N), y(N), yp1, ypn, y2(N) + +! The following two subroutines are used to perform a cubic spline +! interpolation. The routines are taken from Press,W.H., B.P. +! Flannery, S.A.Teukolsky and W.T.Vetterling: "Numerical Recipes, +! the Art of Scientific Computing" Cambridge University Press, 1986. + +#include "coast.h" + real u(IBIG), sig, p, qn, un + integer i, k + + if (yp1.gt..99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do 100 i=2,N-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) & + & /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + 100 continue + if (ypn.gt..99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(N)-x(N-1)))*(ypn-(y(N)-y(N-1))/(x(N)-x(N-1))) + endif + y2(N)=(un-qn*u(N-1))/(qn*y2(N-1)+1.) + do 110 k=N-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + 110 continue + return + end + +! ********************************************************************** + + subroutine splint(xa,ya,y2a,N,x,y) + integer N + real xa(N), ya(N), y2a(N), x, y + + integer klo, khi, k + real h, a, b + + klo=1 + khi=N + 100 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if(xa(k).gt.x)then + khi=k + else + klo=k + endif + goto 100 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) then + print *,'problem in splint' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end if + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ & + & ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + return + end diff --git a/Drivers/grid.F b/Drivers/grid.F new file mode 100644 index 0000000..c944281 --- /dev/null +++ b/Drivers/grid.F @@ -0,0 +1,1233 @@ + program gridmain + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! This version reads digitized coastal and offshore boundaries and +! computes an orthogonal curvilinear coordinate grid for use with +! the Haidvogel Semi-spectral Primitive Equation Model (SPEM). +! The algorithm used is from David C.Ives and Robert M.Zacharias: +! "Conformal Mapping and Orthogonal Grid Generation", +! paper no. 87-2057, AIAA/SAE/ASME/ASEE 23rd Joint Propulsion +! Conference, San Diego, California, June 1987. +! +! It now uses mud2 version 3.0 or sepeli. +! +! This version uses double precision complex arithmetic. If your +! compiler does not support double precision complex, undefine +! DCOMPLEX in griddefs.h. Conversion +! to single precision will produce a significant degradation in +! performance. It will probably cause 'tracking error' problems in +! the conformal mapping calculation unless the machine you are using +! (e.g. a Cray) has a greater than 32-bit word length. + +! Direct any question/problems (and reports of errors!) to: +! John Wilkin +! CSIRO Division of Oceanography +! GPO Box 1538, Hobart +! Tasmania 7001, Australia +! email: wilkin@flood.ml.csiro.au + +! ITMAX is the number of iterations to perform +! IBIG is the largest number of points to be read in for one +! boundary + +#include "griddefs.h" +#include "grid.h" +#include "ncgrid.h" +#if DCOMPLEX + complex*16 zwrk(M2+L2+M2+L2) +#endif /* DCOMPLEX */ + BIGCOMPLEX z(M2+L2+M2+L2) + integer i, j, k, ikb, ierr + BIGREAL xb(M2+L2+M2+L2), yb(M2+L2+M2+L2), wrk(0:M2+L2), & + & wxi(0:L2), weta(0:M2), s1(0:L2), s2(0:M2), & + & xint(0:M2+L2), yint(0:M2+L2), & + & x(0:L2big,0:M2big), y(0:L2big,0:M2big), & + & rhs(0:L2big,0:M2big), ewrk(nwrk), huge + parameter ( huge = 1.e+35 ) + BIGREAL pertrb, dum, t1, t2, zero + parameter ( zero = 0.d0 ) + character*40 lbl + BIGREAL errplt(Lm,Mm), stmp, error, area, tarea + equivalence (rhs,errplt) + external coef, bndyc, cofx, cofy + +! label for grid +#include "gridid.h" + write(lbl,100) gridid(1:40) + 100 format(40a) + +#if PLOTS + call start_plot +#endif /* PLOTS */ + +! original distribution of x,y points is preserved on boundary kb1 +! and kb2: + if(kb1.ne.1.and.kb1.ne.3) & + & call crash('boundary index kb1 must be 1 or 3', kb1) + if(kb2.ne.2.and.kb2.ne.4) & + & call crash('boundary index kb2 must be 2 or 4', kb2) + +! set up boundary spline interpolation arrays + call readbndy + +! initialize vector z (complex) with contour of physical boundary + call z_init(z, xb, yb) + +#if FOO +#if DCOMPLEX +! On 32-bit machines things work much better if the conformal mapping +! is done in double precision complex arithmetic + + do i=1,N4 + zwrk(i)=dcmplx(real(z(i)),aimag(z(i))) + enddo +#endif /* DCOMPLEX */ +#endif + +! Map physical boundary to a rectangle + do 120 k=1,ITMAX +#if DCOMPLEX +! call rect(zwrk,N,N1,N2,N3,N4) + call rect(z,N,N1,N2,N3,N4) +#else + call rects(z,N,N1,N2,N3,N4) +#endif /* DCOMPLEX */ + +#if FOO +#if DCOMPLEX +! Convert back to single precision complex for all other calculations + do i=1,N4 + z(i)=cmplx(sngl(dreal(zwrk(i))),sngl(dimag(zwrk(i)))) + enddo +#endif /* DCOMPLEX */ +#endif + +! Calculate departure of contour from rectangular + error = 0. +#if DBLEPREC + do i=1,N1 + error = error + dabs(dreal(z(i))-dreal(z(1))) + enddo + do i=N1+1,N2 + error = error + dabs(dimag(z(i))-dimag(z(N1+1))) + enddo + do i=N2+1,N3 + error = error + dabs(dreal(z(i))-dreal(z(N2+1))) + enddo + do i=N3+1,N4 + error = error + dabs(dimag(z(i))-dimag(z(N3+1))) + enddo +#else + do i=1,N1 + error = error + abs(real(z(i))-real(z(1))) + enddo + do i=N1+1,N2 + error = error + abs(aimag(z(i))-aimag(z(N1+1))) + enddo + do i=N2+1,N3 + error = error + abs(real(z(i))-real(z(N2+1))) + enddo + do i=N3+1,N4 + error = error + abs(aimag(z(i))-aimag(z(N3+1))) + enddo +#endif /* DBLEPREC */ + error = error/FLoaT(N4) + write(6,110)k,error + 110 format(' rectangularity error in mapped contour at', & + & ' iteration ',i2,' is ',1pe10.4) + 120 continue + +! Store distribution of xi,eta points along boundaries (used to +! compute coefficients of elliptic equation) + do i=0,L2 +#if DBLEPREC + if (kb2 .eq. 2) sxi(i) = dreal(z(N1+i)) + if (kb2 .eq. 4) sxi(i) = dreal(z(N4-i)) +#else + if (kb2 .eq. 2) sxi(i) = real(z(N1+i)) + if (kb2 .eq. 4) sxi(i) = real(z(N4-i)) +#endif /* DBLEPREC */ + enddo + + do j=0,M2-1 +#if DBLEPREC + if (kb1 .eq. 1) seta(j) = dimag(z(N1-j)) + if (kb1 .eq. 3) seta(j) = dimag(z(N2+j)) +#else + if (kb1 .eq. 1) seta(j) = aimag(z(N1-j)) + if (kb1 .eq. 3) seta(j) = aimag(z(N2+j)) +#endif /* DBLEPREC */ + enddo +#if DBLEPREC + seta(M2) = dimag(z(N4)) +#else + seta(M2) = aimag(z(N4)) +#endif /* DBLEPREC */ + +! Cubic spline interpolation of mapping on boundaries 3 and 4 to +! match distribution of points with those on boundaries 1 and 2 +! This also does the interpolation when Lsmall and L are different. +! It actually does too much work when L==Lsmall. + +! boundary 1 + do j=0,M2-1 + ikb = N1-j +#if DBLEPREC + weta(j) = dimag(z(ikb)) +#else + weta(j) = aimag(z(ikb)) +#endif /* DBLEPREC */ + xint(j) = xb(ikb) + yint(j) = yb(ikb) + enddo + ikb = N4 +#if DBLEPREC + weta(N1) = dimag(z(ikb)) +#else + weta(N1) = aimag(z(ikb)) +#endif /* DBLEPREC */ + xint(N1) = xb(ikb) + yint(N1) = yb(ikb) + call spline(weta,xint,M2+1,huge,huge,wrk) + do j=0,M2big + call splint(weta,xint,wrk,M2+1,seta(j),x(0,j)) + enddo + call spline(weta,yint,M2+1,huge,huge,wrk) + do j=0,M2big + call splint(weta,yint,wrk,M2+1,seta(j),y(0,j)) + enddo + +! boundary 3 + do j=0,M2 + ikb = N2+j +#if DBLEPREC + weta(j) = dimag(z(ikb)) +#else + weta(j) = aimag(z(ikb)) +#endif /* DBLEPREC */ + xint(j) = xb(ikb) + yint(j) = yb(ikb) + enddo + call spline(weta,xint,M2+1,huge,huge,wrk) + do j=0,M2big + call splint(weta,xint,wrk,M2+1,seta(j),x(L2big,j)) + enddo + call spline(weta,yint,M2+1,huge,huge,wrk) + do j=0,M2big + call splint(weta,yint,wrk,M2+1,seta(j),y(L2big,j)) + enddo + +! boundary 2 + do i=0,L2 + ikb = N1+i +#if DBLEPREC + wxi(i) = dreal(z(ikb)) +#else + wxi(i) = real(z(ikb)) +#endif /* DBLEPREC */ + xint(i) = xb(ikb) + yint(i) = yb(ikb) + enddo + call spline(wxi,xint,L2+1,huge,huge,wrk) + do i=0,L2big + call splint(wxi,xint,wrk,L2+1,sxi(i),x(i,0)) + enddo + call spline(wxi,yint,L2+1,huge,huge,wrk) + do i=0,L2big + call splint(wxi,yint,wrk,L2+1,sxi(i),y(i,0)) + enddo + +! boundary 4 + do i=0,L2 + ikb = N4-i +#if DBLEPREC + wxi(i) = dreal(z(ikb)) +#else + wxi(i) = real(z(ikb)) +#endif /* DBLEPREC */ + xint(i) = xb(ikb) + yint(i) = yb(ikb) + enddo + call spline(wxi,xint,L2+1,huge,huge,wrk) + do i=0,L2big + call splint(wxi,xint,wrk,L2+1,sxi(i),x(i,M2big)) + enddo + call spline(wxi,yint,L2+1,huge,huge,wrk) + do i=0,L2big + call splint(wxi,yint,wrk,L2+1,sxi(i),y(i,M2big)) + enddo + +! Set right hand side of elliptic equation to zero + do j=1,M2big-1 + do i=1,L2big-1 + x(i,j) = 0. + y(i,j) = 0. + rhs(i,j) = 0. + enddo + enddo + + ewrk(1) = nwrk + t1 = L2big + t2 = M2big + call sepeli(0,2,zero,t1,L2big,1,dum,dum,dum,dum, & + & zero,t2,M2big,1,dum,dum,dum,dum, & + & cofx,cofy,rhs,x,L2big+1,ewrk,pertrb,ierr) + if (ierr .gt. 0) then + call crash('sepeli failed while computing x solution', ierr) + end if + ewrk(1) = nwrk + call sepeli(0,2,zero,t1,L2big,1,dum,dum,dum,dum, & + & zero,t2,M2big,1,dum,dum,dum,dum, & + & cofx,cofy,rhs,y,L2big+1,ewrk,pertrb,ierr) + if (ierr .gt. 0) then + call crash('sepeli failed while computing y solution', ierr) + end if + +! Compute pm,pn factors + do j = 1,Mm + do i = 1,Lm + pm(i,j) = 1.0/sqrt( ( x(2*i,2*j-1)-x(2*i-2,2*j-1) )**2 & + & + ( y(2*i,2*j-1)-y(2*i-2,2*j-1) )**2 ) + pn(i,j) = 1.0/sqrt( ( x(2*i-1,2*j)-x(2*i-1,2*j-2) )**2 & + & + ( y(2*i-1,2*j)-y(2*i-1,2*j-2) )**2 ) + enddo + enddo + +! M,N factors outside the boundaries + do j=1,Mm + pm(0,j) = pm(1,j) + pn(0,j) = pn(1,j) + pm(L,j) = pm(Lm,j) + pn(L,j) = pn(Lm,j) + enddo + do i=0,L + pm(i,0) = pm(i,1) + pn(i,0) = pn(i,1) + pm(i,M) = pm(i,Mm) + pn(i,M) = pn(i,Mm) + enddo + +! Compute dndx,dmde + do i=1,Lm + do j=1,Mm + dndx(i,j) = (1./pn(i+1,j) - 1./pn(i-1,j))/2. + enddo + enddo + do i=1,Lm + do j=1,Mm + dmde(i,j) = (1./pm(i,j+1) - 1./pm(i,j-1))/2. + enddo + enddo + do j=1,Mm + dndx(0,j) = 0. + dmde(0,j) = 0. + dndx(L,j) = 0. + dmde(L,j) = 0. + enddo + do i=0,L + dndx(i,0) = 0. + dmde(i,0) = 0. + dndx(i,M) = 0. + dmde(i,M) = 0. + enddo + +! Split up grid solution into separate arrays for the coordinates +! of the four locations on the Arakawa C grid corresponding to rho, +! psi, u and v points. + +! psi points + do j=1,M + do i=1,L + xp(i,j) = x(2*i-2,2*j-2) + yp(i,j) = y(2*i-2,2*j-2) + enddo + enddo + + if (pleft1) then + write (iout1,*) nb1pts + do j=1,nb1pts + write (iout1,*) x1spl(j),y1spl(j) + enddo + write (iout1,*) Lmiddle + do i=1,Lmiddle + write (iout1,*) xp(i,1),yp(i,1) + enddo + write (iout1,*) M + do j=1,M + write (iout1,*) xp(Lmiddle,j),yp(Lmiddle,j) + enddo + write (iout1,*) Lmiddle + do i=Lmiddle,1,-1 + write (iout1,*) xp(i,M),yp(i,M) + enddo + end if + if (pleft2) then + write (iout2,*) M + do j=M,1,-1 + write (iout2,*) xp(1,j),yp(1,j) + enddo + end if + + if (pbot1) then + write (iout1,*) Mmiddle + do j=Mmiddle,1,-1 + write (iout1,*) xp(1,j),yp(1,j) + enddo + write (iout1,*) nb2pts + do i=1,nb2pts + write (iout1,*) x2spl(i),y2spl(i) + enddo + write (iout1,*) Mmiddle + do j=1,Mmiddle + write (iout1,*) xp(L,j),yp(L,j) + enddo + write (iout1,*) L + do i=L,1,-1 + write (iout1,*) xp(i,Mmiddle),yp(i,Mmiddle) + enddo + end if + if (pbot2) then + write (iout2,*) L + do i=1,L + write (iout2,*) xp(i,1),yp(i,1) + enddo + end if + + if (subset) then + write (iout3,*) Mnorth-Msouth+1 + do j=Mnorth,Msouth,-1 + write (iout3,*) xp(Lwest,j),yp(Lwest,j) + enddo + write (iout3,*) Least-Lwest+1 + do i=Lwest,Least + write (iout3,*) xp(i,Msouth),yp(i,Msouth) + enddo + write (iout3,*) Mnorth-Msouth+1 + do j=Msouth,Mnorth + write (iout3,*) xp(Least,j),yp(Least,j) + enddo + write (iout3,*) Least-Lwest+1 + do i=Least,Lwest,-1 + write (iout3,*) xp(i,Mnorth),yp(i,Mnorth) + enddo + end if + +! u points + do j=1,Mm + do i=1,L + xu(i,j) = x(2*i-2,2*j-1) + yu(i,j) = y(2*i-2,2*j-1) + enddo + enddo + do i=1,L + xu(i,0) = 2*xp(i,1) - xu(i,1) + xu(i,M) = 2*xp(i,M) - xu(i,Mm) + yu(i,0) = 2*yp(i,1) - yu(i,1) + yu(i,M) = 2*yp(i,M) - yu(i,Mm) + enddo + +! vpoints + do j=1,M + do i=1,Lm + xv(i,j) = x(2*i-1,2*j-2) + yv(i,j) = y(2*i-1,2*j-2) + enddo + enddo + do j=1,M + xv(0,j) = 2*xp(1,j) - xv(1,j) + xv(L,j) = 2*xp(L,j) - xv(Lm,j) + yv(0,j) = 2*yp(1,j) - yv(1,j) + yv(L,j) = 2*yp(L,j) - yv(Lm,j) + enddo + +! rho points + do j=1,Mm + do i=1,Lm + xr(i,j) = x(2*i-1,2*j-1) + yr(i,j) = y(2*i-1,2*j-1) + enddo + enddo + do j=1,Mm + xr(L,j) = 2*xu(L,j) - xr(Lm,j) + xr(0,j) = 2*xu(1,j) - xr(1,j) + yr(L,j) = 2*yu(L,j) - yr(Lm,j) + yr(0,j) = 2*yu(1,j) - yr(1,j) + enddo + do i=0,L + xr(i,M) = 2*xv(i,M) - xr(i,Mm) + yr(i,M) = 2*yv(i,M) - yr(i,Mm) + xr(i,0) = 2*xv(i,1) - xr(i,1) + yr(i,0) = 2*yv(i,1) - yr(i,1) + enddo + +! Diagnostics: +! Compute area of domain from m,n factors + area = 0. + do j = 1,Mm + do i = 1,Lm + area = area + 1./(pm(i,j)*pn(i,j)) + enddo + enddo + write(6,130)area + 130 format(5x,'area ',g10.4) + +! Check orthogonality by evaluating dx/dxi*dx/deta+dy/dxi*dy/deta +! everywhere. Normalize with respect to local grid cell area. +! Store result in errplt and pass to gridplot. + do j=1,Mm + do i=1,Lm + errplt(i,j) = ((x(2*i,2*j-1)-x(2*i-2,2*j-1))* & + & (x(2*i-1,2*j)-x(2*i-1,2*j-2))+ & + & (y(2*i,2*j-1)-y(2*i-2,2*j-1))* & + & (y(2*i-1,2*j)-y(2*i-1,2*j-2)))* & + & pm(i,j)*pn(i,j) + enddo + enddo + +! Output solution +! (This output format parallels the input format assumed by +! subroutine getgrid in pemodel) + call checkdefs + call def_grid +#if PLOTS + call gridplot(lbl,area,tarea,errplt) + call end_plot +#endif /* PLOTS */ + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 140 call crash('grid: error while outputing solution', 0) + end + +! ******************************************************************* + + subroutine bndyc (kbdy,xory,alfa,gbdy) + integer kbdy + BIGREAL xory, alfa, gbdy + write (6,100) + 100 format (' you are in bndyc: tut tut.') + stop + end + +! ******************************************************************* + + subroutine coef (x,y,cxx,cyy,cx,cy,c) + BIGREAL x, y, cxx, cyy, cx, cy, c +#include "grid.h" + integer i, j + BIGREAL dxdi, dedj + + i = nint(x) + j = nint(y) + dxdi = 0.5*(sxi(i+1)-sxi(i-1)) + dedj = 0.5*(seta(j+1)-seta(j-1)) + cxx = 1./dxdi**2 + cyy = 1./dedj**2 + cx = (-sxi(i+1)+2.*sxi(i)-sxi(i-1))/dxdi**3 + cy = (-seta(j+1)+2.*seta(j)-seta(j-1))/dedj**3 + c = 0. + return + end + +! ******************************************************************* + + subroutine cofx(xx,afun,bfun,cfun) + BIGREAL xx, afun, bfun, cfun + +! subroutine to compute the coefficients of the elliptic equation +! solved to fill in the grid. it is passed (along with cofy) to +! the elliptic solver sepeli. + +#include "grid.h" + integer i + BIGREAL dxdi + i = int(xx) + dxdi = 0.5 * (sxi(i+1)-sxi(i-1)) + afun = 1. / dxdi ** 2 + bfun = (-sxi(i+1)+2.*sxi(i)-sxi(i-1)) / dxdi ** 3 + cfun = 0. + return + end + +! ******************************************************************* + + subroutine cofy(yy,dfun,efun,ffun) + BIGREAL yy, dfun, efun, ffun +#include "grid.h" + integer j + BIGREAL dedj + j = int(yy) + dedj = 0.5 * (seta(j+1)-seta(j-1)) + dfun = 1. / dedj ** 2 + efun = (-seta(j+1)+2.*seta(j)-seta(j-1)) / dedj ** 3 + ffun = 0. + return + end + +! ******************************************************************* + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(ierr) +#endif /* NO_EXIT */ + return + end + +! ******************************************************************* +! subroutine factor: +! factors grid size to return the coefficients needed +! by mud2. +! +! John D. McCalpin (mccalpin@perelandra.cms.udel.edu) +! Mon Apr 1 12:13:44 EST 1991 +! +! Here is a short test code: +! write (*,'(a,$)') 'Enter NX, NY : ' +! read (*,*) nx,ny +! call factor (nx,ny,nxl,nyl,npow2x,npow2y) +! write (*,*) nxl,nyl,npow2x,npow2y +! end +!-------------------------------------------------------------- + + subroutine factor (nx,ny,nxl,nyl,ix,iy) +! -- input args -- + integer nx,ny +! -- output args -- + integer nxl,nyl,ix,iy + integer n2facts + +! get number of factors of 2 in nx and ny and correct to make +! sure remaining coefficient is greater than 1 + + ix = n2facts(nx) + if (ix .lt. 0) then + call crash('BAD NX IN FACTOR2', 1) + end if + if (nx/2**ix.eq.1) ix = ix-1 + iy = n2facts(ny) + if (iy .lt. 0) then + call crash('BAD NY IN FACTOR2', 1) + end if + if (ny/2**iy.eq.1) iy = iy-1 + +! now nxl and nyl are guaranteed to be consistent +! with respect to npow2 + + nxl = nx/2**ix + nyl = ny/2**iy + + return + end + +! +! integer function n2facts: +! returns the number of 2's in the prime factorization +! of a number +! + integer function n2facts(input) + integer input + integer n, npow2, i + + if (input.lt.0) goto 110 + + n = input + npow2 = 0 + do 100 i=1,64 + if (mod(n,2).eq.0) then + npow2 = npow2+1 + n = n/2 + else + goto 120 + endif + 100 continue + +! error return: n<0 or n>2**64 : the latter should not be possible! + 110 npow2 = -1 + + 120 n2facts = npow2 + return + end + +! ******************************************************************* + +#if PLOTS + subroutine gridplot(lbl,area,tarea,errplt) +#include "grid.h" + character*40 lbl + character*5 lbls + BIGREAL area, tarea + BIGREAL errplt(Lm,Mm) + SMALLREAL tmp(0:L,0:M), xlow, xhigh, ylow, yhigh, & + & x1, x2, y1, y2, dxmin, tmp2(Lm,Mm) + integer i, j + BIGREAL vmin, vmax + + call pcseti('QUALITY',1) + + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbl,.012,0.,0.) + write(lbl,100)area + 100 format(' Sum 1/MN=',g10.4) + call plchhq(.5,.03,lbl,.012,0.,0.) + +! Draw the psi points grid (boundaries coincide with channel walls) + xlow = vmin(xp,L*M) + xhigh = vmax(xp,L*M) + yhigh = vmax(yp,L*M) + ylow = vmin(yp,L*M) + xl = xhigh-xlow + el = yhigh-ylow + if (xl .ge. el) then + x1 = 0.05 + x2 = 0.95 + y1 = -.45*el/xl + .5 + y2 = y1 + el/xl*.9 + else + y1 = 0.05 + y2 = 0.95 + x1 = -.45*xl/el + .5 + x2 = x1 + xl/el*.9 + end if + call set(x1,x2,y1,y2,xlow,xhigh,ylow,yhigh,1) +#if DBLEPREC + do j = 1,M + call frstpt(sngl(xp(1,j)),sngl(yp(1,j))) + do i = 2,L + call vector(sngl(xp(i,j)),sngl(yp(i,j))) + enddo + enddo + do i = 1,L + call frstpt(sngl(xp(i,1)),sngl(yp(i,1))) + do j = 2,M + call vector(sngl(xp(i,j)),sngl(yp(i,j))) + enddo + enddo +#else + do j = 1,M + call frstpt(xp(1,j),yp(1,j)) + do i = 2,L + call vector(xp(i,j),yp(i,j)) + enddo + enddo + do i = 1,L + call frstpt(xp(i,1),yp(i,1)) + do j = 2,M + call vector(xp(i,j),yp(i,j)) + enddo + enddo +#endif /* DBLEPREC */ + call frame + +! Plot m and n + write(lbls,110) + 110 format('DX') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbls(1:2),.012,0.,0.) + do j=0,M + do i=0,L + tmp(i,j) = 1/pm(i,j) + enddo + enddo + dxmin = vmax(pm,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dx = ',dxmin + call set(.05,.95,.1,.9,1.,float(Lp),1.,float(Mp),1) + call perim(1,L,1,M) + call cpseti('SET',0) + call cpcnrc(tmp,Lp,Lp,Mp,0.0,0.0,0.0,1,-1,-682) + call frame + write(lbls,120) + 120 format('DY') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbls(1:2),.012,0.,0.) + do j=0,M + do i=0,L + tmp(i,j) = 1/pn(i,j) + enddo + enddo + dxmin = vmax(pn,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dy = ',dxmin + call set(.05,.95,.1,.9,1.,float(Lp),1.,float(Mp),1) + call perim(1,L,1,M) + call cpseti('SET',0) + call cpcnrc(tmp,Lp,Lp,Mp,0.0,0.0,0.0,1,-1,-682) + call frame + +! plot error in grid + do j=1,Mm + do i=1,Lm + tmp2(i,j) = errplt(i,j) + enddo + enddo + write(lbls,130) + 130 format('Error') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbls,.012,0.,0.) + call set(.05,.95,.1,.9,1.,float(Lm),1.,float(Mm),1) + call perim(1,Lm-1,1,Mm-1) + call cpseti('SET',0) + call cpcnrc(tmp2,Lm,Lm,Mm,0.0,0.0,0.0,1,-1,-682) + call frame + return + end +#endif /* PLOTS */ + +! ******************************************************************* + + subroutine readbndy +#include "grid.h" + BIGREAL arcs(IBIG), huge + parameter (huge = 1.e+35 ) + integer i + +! Read x,y data points describing boundary 1 + read(5,*) nb1pts + if (nb1pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb1pts) + end if + do i=1,nb1pts + read(5,*) x1spl(i),y1spl(i) + enddo + if (.not. even1) then + do i=1,nb1pts + s1spl(i) = (i-1.)/(nb1pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb1pts + arcs(i) = arcs(i-1) + sqrt((x1spl(i)-x1spl(i-1))**2 + & + & (y1spl(i)-y1spl(i-1))**2) + enddo + do i=1,nb1pts + s1spl(i) = arcs(i)/arcs(nb1pts) + enddo + end if + + call spline(s1spl,x1spl,nb1pts,huge,huge,b1spl) + call spline(s1spl,y1spl,nb1pts,huge,huge,c1spl) + +! Read x,y data points describing boundary 2 + read(5,*) nb2pts + if (nb2pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb2pts) + end if + do i=1,nb2pts + read(5,*) x2spl(i),y2spl(i) + enddo + if (.not. even2) then + do i=1,nb2pts + s2spl(i) = (i-1.)/(nb2pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb2pts + arcs(i) = arcs(i-1) + sqrt((x2spl(i)-x2spl(i-1))**2 + & + & (y2spl(i)-y2spl(i-1))**2) + enddo + do i=1,nb2pts + s2spl(i) = arcs(i)/arcs(nb2pts) + enddo + end if + + call spline(s2spl,x2spl,nb2pts,huge,huge,b2spl) + call spline(s2spl,y2spl,nb2pts,huge,huge,c2spl) + +! Read x,y data points describing boundary 3 + read(5,*) nb3pts + if (nb3pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb3pts) + end if + do i=1,nb3pts + read(5,*) x3spl(i),y3spl(i) + enddo + if (.not. even3) then + do i=1,nb3pts + s3spl(i) = (i-1.)/(nb3pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb3pts + arcs(i) = arcs(i-1) + sqrt((x3spl(i)-x3spl(i-1))**2 + & + & (y3spl(i)-y3spl(i-1))**2) + enddo + do i=1,nb3pts + s3spl(i) = arcs(i)/arcs(nb3pts) + enddo + end if + + call spline(s3spl,x3spl,nb3pts,huge,huge,b3spl) + call spline(s3spl,y3spl,nb3pts,huge,huge,c3spl) + +! Read x,y data points describing boundary 4 + read(5,*) nb4pts + if (nb4pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb4pts) + end if + do i=1,nb4pts + read(5,*) x4spl(i),y4spl(i) + enddo + if (.not. even4) then + do i=1,nb4pts + s4spl(i) = (i-1.)/(nb4pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb4pts + arcs(i) = arcs(i-1) + sqrt((x4spl(i)-x4spl(i-1))**2 + & + & (y4spl(i)-y4spl(i-1))**2) + enddo + do i=1,nb4pts + s4spl(i) = arcs(i)/arcs(nb4pts) + enddo + end if + + call spline(s4spl,x4spl,nb4pts,huge,huge,b4spl) + call spline(s4spl,y4spl,nb4pts,huge,huge,c4spl) + return + end + +! ******************************************************************* + +#if DCOMPLEX + subroutine rect(z,N,N1,N2,N3,N4) + integer N, N1, N2, N3, N4 + +! This subroutine is taken directly from Ives, D.C. and +! R.M. Zacharias "Conformal Mapping and Orthogonal Grid Generation" +! AIAA-87-2057. + + complex*16 z(N), z0, zd + integer BIG + parameter (BIG=3000) + double precision r(BIG), t(BIG), pi, alpha, pwr, pmin, & + & pmax, tp + integer i, j, k, im, ip + +! Check on work array size + if (N .gt. BIG) then + call crash('BIG in rect must be at least ', N) + endif + pi = 4.d0*datan(1.d0) + do 160 i=1,N + im = N-mod(N-i+1,N) + ip = 1+mod(i,N) + zd = (z(im)-z(i))/(z(ip)-z(i)) + alpha = datan2(dimag(zd),dreal(zd)) + if(alpha.lt.0)alpha = alpha+pi+pi + pwr = pi/alpha + if(i.ne.N1.and.i.ne.N2.and.i.ne.N3.and.i.ne.N4) goto 110 + zd = (z(im)-z(i))/cdabs(z(im)-z(i)) + do 100 j=1,N + z(j) = dcmplx(0.d0,1.d0)*z(j)/zd + 100 continue + pwr = pwr/2. + 110 pmin = 100. + pmax =-100. + tp = 0. + do 140 j=2,N + zd = z(mod(j+i-2,N)+1)-z(i) + r(j) = cdabs(zd) + t(j) = datan2(dimag(zd),dreal(zd))-pi-pi-pi-pi-pi-pi + do 120 k=1,7 + if(dabs(t(j)-tp).lt.pi)goto 130 + t(j) = t(j)+pi+pi + 120 continue +! pause ' warning - tracking error ' + call crash('rect: tracking error', 0) + 130 tp = t(j) + pmax = dmax1(pmax,t(j)*pwr) + pmin = dmin1(pmin,t(j)*pwr) + 140 continue + pwr = dmin1(pwr,1.98d0*pi*pwr/(pmax-pmin)) + z(i) = dcmplx(0.d0,0.d0) + do 150 j=2,N +#if __sgi + z(mod(j+i-2,N)+1) = r(j)**pwr*zexp(dcmplx(0.d0,t(j)*pwr)) +#else + z(mod(j+i-2,N)+1) = r(j)**pwr*cdexp(dcmplx(0.d0,t(j)*pwr)) +#endif + 150 continue + zd = 1./(z(N2)-z(N1)) + z0 = z(N1) + do 160 j=1,N + z(j) = (z(j)-z0)*zd + 160 continue + return + end + +#else +! ******************************************************************* + + subroutine rects(z,N,N1,N2,N3,N4) + integer N, N1, N2, N3, N4 + +! Single precision version of subroutine rect from Ives,D.C. and +! R.M.Zacharias "Conformal Mapping and Orthogonal Grid Generation" +! AIAA-87-2057. + complex z(N), z0, zd + integer BIG + parameter (BIG=3000) + real r(BIG), t(BIG), pi, alpha, pwr, pmin, & + & pmax, tp + integer i, j, k, im, ip + +! Check on work array size + if (N .gt. BIG) then + call crash('BIG in rect must be at least ', N) + endif + pi = 4.*atan(1.) + do 160 i=1,N + im = N-mod(N-i+1,N) + ip = 1+mod(i,N) + zd = (z(im)-z(i))/(z(ip)-z(i)) + alpha = atan2(aimag(zd),real(zd)) + if(alpha.lt.0)alpha = alpha+pi+pi + pwr = pi/alpha + if(i.ne.N1.and.i.ne.N2.and.i.ne.N3.and.i.ne.N4)goto 110 + zd = (z(im)-z(i))/cabs(z(im)-z(i)) + do 100 j=1,N + z(j) = cmplx(0.,1.)*z(j)/zd + 100 continue + pwr = pwr/2. + 110 pmin = 100. + pmax =-100. + tp = 0. + do 140 j=2,N + zd = z(mod(j+i-2,N)+1)-z(i) + r(j) = cabs(zd) + t(j) = atan2(aimag(zd),real(zd))-pi-pi-pi-pi-pi-pi + do 120 k=1,7 + if(abs(t(j)-tp).lt.pi)goto 130 + t(j) = t(j)+pi+pi + 120 continue +! pause ' warning - tracking error ' + call crash('rects: tracking error', 0) + 130 tp = t(j) + pmax = max(pmax,t(j)*pwr) + pmin = min(pmin,t(j)*pwr) + 140 continue + pwr = min(pwr,1.98*pi*pwr/(pmax-pmin)) + z(i) = cmplx(0.,0.) + do 150 j=2,N + z(mod(j+i-2,N)+1) = r(j)**pwr*cexp(cmplx(0.,t(j)*pwr)) + 150 continue + zd = 1./(z(N2)-z(N1)) + z0 = z(N1) + do 160 j=1,N + z(j) = (z(j)-z0)*zd + 160 continue + return + end +#endif /* DCOMPLEX */ + +! ******************************************************************* + + subroutine spline(x,y,NN,yp1,ypn,y2) + integer NN + BIGREAL x(NN), y(NN), yp1, ypn, y2(NN) + +! The following two subroutines are used to perform the cubic spline +! interpolation required to match up the distribution of points on +! opposite sides of the transformed plane rectangle. The routines +! are taken from Press,W.H., B.P.Flannery, S.A.Teukolsky and +! W.T.Vetterling: "Numerical Recipes, the Art of Scientific Computing" +! Cambridge University Press, 1986. +#include "grid.h" + integer nmax + parameter ( nmax=M2+L2 ) + BIGREAL u(nmax), qn, un, sig, p + integer i, k + + if (yp1 .gt. .99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do i=2,NN-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) & + & /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + enddo + if (ypn .gt. .99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(NN)-x(NN-1)))*(ypn-(y(NN)-y(NN-1))/(x(NN)-x(NN-1))) + endif + y2(NN)=(un-qn*u(NN-1))/(qn*y2(NN-1)+1.) + do k=NN-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + enddo + return + end + +! ******************************************************************* + + subroutine splint(xa,ya,y2a,N,x,y) + integer N + BIGREAL xa(N), ya(N), y2a(N), x, y + integer klo, khi, k + BIGREAL h, a, b + + klo=1 + khi=N + 100 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if(xa(k).gt.x)then + khi=k + else + klo=k + endif + goto 100 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) call crash('splint: bad xa input', 0) + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ & + & ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + return + end + +! ******************************************************************* + + subroutine z1(s1,x,y,z) + BIGREAL s1, s2, s3, s4, x, y + BIGCOMPLEX z +#include "grid.h" + +! Subroutines which specify the boundaries of the physical +! domain. They are defined as functions of the variable s which +! ranges from 0 to 1 on each boundary, proceeding anti-clockwise. + + call splint(s1spl,x1spl,b1spl,nb1pts,s1,x) + call splint(s1spl,y1spl,c1spl,nb1pts,s1,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z2(s2,x,y,z) + call splint(s2spl,x2spl,b2spl,nb2pts,s2,x) + call splint(s2spl,y2spl,c2spl,nb2pts,s2,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z3(s3,x,y,z) + call splint(s3spl,x3spl,b3spl,nb3pts,s3,x) + call splint(s3spl,y3spl,c3spl,nb3pts,s3,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z4(s4,x,y,z) + call splint(s4spl,x4spl,b4spl,nb4pts,s4,x) + call splint(s4spl,y4spl,c4spl,nb4pts,s4,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + end + +! ******************************************************************* + + subroutine z_init(z, xb, yb) +#include "grid.h" + BIGCOMPLEX z(M2+L2+M2+L2) + BIGREAL xb(M2+L2+M2+L2), yb(M2+L2+M2+L2) + BIGREAL stmp + integer i + +#if XPOTS1 + read(ipot1,*) stmp +#endif /* XPOTS1 */ + do i=1,N1 +#if XPOTS1 + read(ipot1,*) stmp + call z1(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i)/FLoaT(N1) + call z1(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS1 */ + enddo +#if XPOTS1 + close(ipot1) +#endif /* XPOTS1 */ +#if XPOTS2 + read(ipot2,*) stmp +#endif /* XPOTS2 */ + do i=N1+1,N2 +#if XPOTS2 + read(ipot2,*) stmp + call z2(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N1)/FLoaT(N2-N1) + call z2(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS2 */ + enddo +#if XPOTS2 + close(ipot2) +#endif /* XPOTS2 */ +#if XPOTS3 + read(ipot3,*) stmp +#endif /* XPOTS3 */ + do i=N2+1,N3 +#if XPOTS3 + read(ipot3,*) stmp + call z3(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N2)/FLoaT(N3-N2) + call z3(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS3 */ + enddo +#if XPOTS3 + close(ipot3) +#endif /* XPOTS3 */ +#if XPOTS4 + read(ipot4,*) stmp +#endif /* XPOTS4 */ + do i=N3+1,N4 +#if XPOTS4 + read(ipot4,*) stmp + call z4(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N3)/FLoaT(N4-N3) + call z4(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS4 */ + enddo +#if XPOTS4 + close(ipot4) +#endif /* XPOTS4 */ + return + end diff --git a/Drivers/sphere.F b/Drivers/sphere.F new file mode 100644 index 0000000..80cc5e0 --- /dev/null +++ b/Drivers/sphere.F @@ -0,0 +1,506 @@ + program spheres + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! This program reads in the x,y grid, the lat,long grid, +! and the topography from the netCDF grid file. It uses the +! latitude information to calculate f = 2*Omega*sin(lat). The +! results are placed into the netCDF grid file. +! +! Logicals: +! hflat - true for constant depth of h0 - don't read in topography. +! sphere - true for spherical geometry in pm's and pn's or false +! for planar geometry. +! colour - true for colour fill plots (false gives contours) +! grover - true to draw grid over colour filled plots +! readlat - true to read in the lat, long file produced by tolat. +! ******************************************************************* + +#include "griddefs.h" +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" + BIGREAL h0, f0, beta + parameter ( h0 = 800. ) + parameter ( f0=9.e-4, beta=2.e-11 ) +#if DRAW_COASTS +! Earth angular frequency and radius of sphere of equal volume + real U1, U2, V1, V2, udeg, uscale + BIGREAL enlarge +#endif /* DRAW_COASTS */ + real DTOR, RTOD + BIGREAL Aomega, REarth, pi + parameter ( Aomega=7.292115e-5 , REarth=6.3708e6 ) + parameter ( pi = 3.14159265 ) + logical hflat, colour, grover, readlat + BIGREAL el2, sum, dxmin, dist, galpha + integer i, j, imap + BIGREAL a1, a2, av2, vmin, vmax + + av2(a1,a2) = .5*(a1+a2) + + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + +#include "sphereflags.h" +#include "gridid.h" + + call get_xy + call get_mn + call get_rmask + + if (readlat) then + call get_lat +! calculate the angle between the xi-eta grid and the lon-lat grid +! at rho points. + + do j = 1, Mm + do i = 1, Lm + a1 = lat_u(i+1, j) - lat_u(i, j) + a2 = lon_u(i+1, j) - lon_u(i, j) + if (abs(a2) .gt. 180.) then + if (a2 .lt. -180. ) then + a2 = a2 + 360. + else + a2 = a2 - 360. + endif + endif + a2 = a2 * cos(0.5*DTOR*(lat_u(i, j) + lat_u(i+1, j))) + angle(i, j) = atan2(a1, a2) + enddo + enddo + do j = 1, Mm + do i = 1, Lm + a2 = lat_v(i, j) - lat_v(i, j+1) + a1 = (lon_v(i, j) - lon_v(i, j+1)) + if (abs(a1) .gt. 180.) then + if (a1 .lt. -180. ) then + a1 = a1 + 360. + else + a1 = a1 - 360. + endif + endif + a1 = a1 * cos(0.5*DTOR*(lat_v(i, j) + lat_v(i, j+1))) + angle(i, j) = 0.5*(angle(i, j) + atan2(a1, -a2)) + enddo + enddo + else +! calculate the angle between the xi-eta grid and the lon-lat grid +! at rho points. + do j = 1, Mm + do i = 1, Lm + a1 = yu(i+1, j) - yu(i, j) + a2 = xu(i+1, j) - xu(i, j) + angle(i, j) = atan2(a1, a2) + a2 = yv(i, j) - yv(i, j+1) + a1 = xv(i, j) - xv(i, j+1) + angle(i, j) = 0.5*(angle(i, j) + atan2(a1, -a2)) + enddo + enddo + endif + + do i = 1, Lm + angle(i, 0) = angle(i, 1) + angle(i, M) = angle(i, Mm) + enddo + + do j = 0, M + angle(0, j) = angle(1, j) + angle(L, j) = angle(Lm, j) + enddo + + if (hflat) then + do j=0,M + do i=0,L + h(i,j) = h0 + enddo + enddo + else + call get_h + end if + +! If on a sphere then compute spherical pm,pn factors + if (spherical .and. readlat) then + + do j = 1,Mm + do i = 1,Lm + call geodesic_dist(lon_u(i,j),lat_u(i,j),lon_u(i+1,j), & + & lat_u(i+1,j),1,dist,galpha) + pm(i,j) = 1./dist + call geodesic_dist(lon_v(i,j),lat_v(i,j),lon_v(i,j+1), & + & lat_v(i,j+1),1,dist,galpha) + pn(i,j) = 1./dist + enddo + enddo + +! M,N factors outside the boundaries + do j=1,Mm + pm(0,j) = pm(1,j) + pn(0,j) = pn(1,j) + pm(L,j) = pm(Lm,j) + pn(L,j) = pn(Lm,j) + enddo + do i=0,L + pm(i,0) = pm(i,1) + pn(i,0) = pn(i,1) + pm(i,M) = pm(i,Mm) + pn(i,M) = pn(i,Mm) + enddo + +! Compute dndx,dmde + do i=1,Lm + do j=1,Mm + dndx(i,j) = (1./pn(i+1,j) - 1./pn(i-1,j))/2. + enddo + enddo + do i=1,Lm + do j=1,Mm + dmde(i,j) = (1./pm(i,j+1) - 1./pm(i,j-1))/2. + enddo + enddo + do j=1,Mm + dndx(0,j) = 0. + dmde(0,j) = 0. + dndx(L,j) = 0. + dmde(L,j) = 0. + enddo + do i=0,L + dndx(i,0) = 0. + dmde(i,0) = 0. + dndx(i,M) = 0. + dmde(i,M) = 0. + enddo + end if + +! Coriolis parameter + if (readlat) then + do i=0,L + do j=0,M + f(i,j) = 2*Aomega*sin(DTOR*lat_rho(i,j)) + enddo + enddo + else + el2 = yp(1,M/2) + do i=0,L + do j=0,M + f(i,j) = f0 + beta*(yr(1,j) - el2) + enddo + enddo + end if + +! Output for the SPEM + + call wrt_fhmn(spherical,f0,beta) + +#if PLOTS +! Plots just to be sure + + xmin = vmin(xr,Lp*Mp) + ymin = vmin(yr,Lp*Mp) + xmax = vmax(xr,Lp*Mp) + ymax = vmax(yr,Lp*Mp) + + el = ymax-ymin + xl = xmax-xmin + + call start_plot +! set foreground to black, background to white + if (colour) then + call gscr(1,0,1.,1.,1.) + call gscr(1,1,0.,0.,0.) + end if + +#if DRAW_COASTS +! put things on EZMAP space: + call mapsti('GR',JGRD) + call mapstc('OU','NO') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapint + +! rescale xp, yp, xr, yr (from Roberta Young) + call maptrn((PLAT+.5),PLONG,U2,V2) + call maptrn((PLAT-.5),PLONG,U1,V1) + udeg = sqrt((U2-U1)*(U2-U1) + (V2-V1)*(V2-V1)) + uscale=DTOR*REarth/udeg + write(6,*)' udeg =',udeg + write(6,*)' uscale =',uscale + + do j=1,M + do i=1,L + xp(i,j)=(xp(i,j)-XOFF)/uscale + yp(i,j)=(yp(i,j)-YOFF)/uscale + enddo + enddo + + do j=0,M + do i=0,L + xr(i,j)=(xr(i,j)-XOFF)/uscale + yr(i,j)=(yr(i,j)-YOFF)/uscale + enddo + enddo + +! find minimum x and y locations: + xmin = vmin(xp,L*M) + ymin = vmin(yp,L*M) + xmax = vmax(xp,L*M) + ymax = vmax(yp,L*M) + el = ymax-ymin + xl = xmax-xmin + +! make them larger for the plots + enlarge = 0.03 + xmin = xmin - xl*enlarge + ymin = ymin - el*enlarge + xmax = xmax + xl*enlarge + ymax = ymax + el*enlarge +#endif /* DRAW_COASTS */ + + imap = 3 + call cpseti('MAP',imap) + call getxxyy + call pcseti('QUALITY',1) + call ploth(gridid(1:40),colour,grover) + call plotmnf(gridid(1:40),colour,grover) + + call end_plot +#endif /* PLOTS */ + + sum = 0 + do j=1,Mm + do i=1,Lm + sum = sum + 1/pm(i,j) + enddo + enddo + print *,'average dx ',sum/(Lm*Mm) + dxmin = vmax(pm,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dx = ',dxmin + sum = 0 + do j=1,Mm + do i=1,Lm + sum = sum + 1/pn(i,j) + enddo + enddo + print *,'average dy ',sum/(Lm*Mm) + dxmin = vmax(pn,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dy = ',dxmin + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 200 call crash('sphere: read or write error', 0) + end + +! ******************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(ierr) +#endif /* NO_EXIT */ + return + end + +!**************************************************************** + + subroutine plotmnf(gridid,colour,grover) +#include "bathy.h" + real tmp(L,M), htmp(0:L,0:M) + character*20 ltit + character*24 lnote, lnote2 + character*40 gridid + logical colour, grover, tallflg + real x1, x2, y1, y2, dxmin, dxmax, dymin, dymax + integer i, j + real vsmin, vsmax + +! find shape of domain to plot + if (xl .ge. el) then + x1 = 0.05 + x2 = 0.95 + y1 = -.45*el/xl + .5 + y2 = y1 + el/xl*.9 + tallflg = .false. + else + if (colour) then + y1 = 0.02 + y2 = 0.92 + else + y1 = 0.04 + y2 = 0.94 + end if + x1 = -.45*xl/el + .45 + x2 = x1 + xl/el*.9 + tallflg = .true. + end if + + call getxxyy + + write (ltit,100) + 100 format ('DX') + + do j=1,M + do i=1,L + tmp(i,j) = 4./(pm(i,j) + pm(i-1,j) + pm(i,j-1) + & + & pm(i-1,j-1)) + enddo + enddo + + dxmin = vsmin(tmp,L*M) + write (lnote,120) dxmin + 120 format ('MIN DX =',f9.0) + dxmax = vsmax(tmp,L*M) + write (lnote2,130) dxmax + 130 format ('MAX DX =',f9.0) + + call set (0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,ltit,.012,0.,0.) + if (colour) then + call plchhq(.85,.98,lnote(1:17),.012,0.,0.) + call plchhq(.85,.95,lnote2(1:17),.012,0.,0.) + endif + call set (x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(tmp,L,L,M,8,lcflag,tallflg,.false.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(tmp,L,L,M,-20.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + write (ltit,140) + 140 format ('DY') + + do j=1,M + do i=1,L + tmp(i,j) = 4./(pn(i,j) + pn(i-1,j) + pn(i,j-1) + & + & pn(i-1,j-1)) + enddo + enddo + + dymin = vsmin(tmp,L*M) + write (lnote,160) dymin + 160 format ('MIN DY =',f9.0) + dymax = vsmax(tmp,L*M) + write (lnote2,170) dymax + 170 format ('MAX DY =',f9.0) + + call set (0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,ltit,.012,0.,0.) + if (colour) then + call plchhq(.85,.98,lnote(1:17),.012,0.,0.) + call plchhq(.85,.95,lnote2(1:17),.012,0.,0.) + endif + call set (x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill (tmp,L,L,M,8,lcflag,tallflg,.false.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(tmp,L,L,M,-20.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + write (ltit,180) + 180 format ('F') + + do j=1,M + do i=1,L + tmp(i,j) = 0.25*(f(i,j) + f(i-1,j) + f(i,j-1) + f(i-1,j-1)) + enddo + enddo + + call set (0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq (0.5,0.98,ltit(1:1),.012,0.,0.) + call set (x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill (tmp,L,L,M,8,lcflag,tallflg,.false.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(tmp,L,L,M,-20.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + write (ltit,190) + 190 format ('RHO MASK') + + call getxyh + do j=0,M + do i=0,L + htmp(i,j) = mask_rho(i,j) + enddo + enddo + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ltit(1:8),.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(htmp,Lp,Lp,Mp,2,lcflag,tallflg,.false.) + call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(htmp,Lp,Lp,Mp,0.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + write (ltit,200) + 200 format ('ANGLE') + + call getxyh + do j=0,M + do i=0,L + htmp(i,j) = angle(i,j) + enddo + enddo + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ltit(1:5),.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(htmp,Lp,Lp,Mp,8,lcflag,tallflg,.false.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(htmp,Lp,Lp,Mp,0.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + return + end diff --git a/Drivers/sqgrid.F b/Drivers/sqgrid.F new file mode 100644 index 0000000..a213c69 --- /dev/null +++ b/Drivers/sqgrid.F @@ -0,0 +1,676 @@ + program Wgrid + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ******************************************************************* +! This version reads digitized rectangular boundaries, uses +! splines to interpolate to the grid resolution, and fills in +! the interior. +! +! Direct any question/problems (and reports of errors!) to: +! Kate Hedstrom +! kate@ahab.rutgers.edu +! +! IBIG is the largest number of points to be read in for one +! boundary + +#include "griddefs.h" +#include "grid.h" +#include "ncgrid.h" + integer i, j + BIGCOMPLEX z(M2+L2+M2+L2) + BIGREAL stmp, area, tarea + BIGREAL xb(M2+L2+M2+L2),yb(M2+L2+M2+L2), & + & x(0:L2,0:M2),y(0:L2,0:M2) + character*40 lbl + +! label for grid +#include "gridid.h" + write(lbl,100) gridid(1:40) + 100 format(40a) + +! original distribution of x,y points is preserved on boundary kb1 +! and kb2: + if(kb1.ne.1.and.kb1.ne.3) & + & call crash('boundary index kb1 must be 1 or 3', kb1) + if(kb2.ne.2.and.kb2.ne.4) & + & call crash('boundary index kb2 must be 2 or 4', kb2) + +! set up boundary spline interpolation arrays + call readbndy + +! initialize vector z (complex) with contour of physical boundary +#if XPOTS1 + read(ipot1,*) stmp +#endif /* XPOTS1 */ + do i=1,N1 +#if XPOTS1 + read(ipot1,*) stmp + call z1(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i)/FLoaT(N1) + call z1(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS1 */ + enddo +#if XPOTS2 + read(ipot2,*) stmp +#endif /* XPOTS2 */ + do i=N1+1,N2 +#if XPOTS2 + read(ipot2,*) stmp + call z2(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N1)/FLoaT(N2-N1) + call z2(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS2 */ + enddo +#if XPOTS3 + read(ipot3,*) stmp +#endif /* XPOTS3 */ + do i=N2+1,N3 +#if XPOTS3 + read(ipot3,*) stmp + call z3(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N2)/FLoaT(N3-N2) + call z3(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS3 */ + enddo +#if XPOTS4 + read(ipot4,*) stmp +#endif /* XPOTS4 */ + do i=N3+1,N4 +#if XPOTS4 + read(ipot4,*) stmp + call z4(stmp,xb(i),yb(i),z(i)) +#else + stmp = FLoaT(i-N3)/FLoaT(N4-N3) + call z4(stmp,xb(i),yb(i),z(i)) +#endif /* XPOTS4 */ + enddo + +! Set boundary values of the grid + do i=1,N1 + x(0,N1-i) = xb(i) + y(0,N1-i) = yb(i) + enddo + do i=N1+1,N2 + x(i-N1,0) = xb(i) + y(i-N1,0) = yb(i) + enddo + do i=N2+1,N3 + x(L2,i-N2) = xb(i) + y(L2,i-N2) = yb(i) + enddo + do i=N3+1,N4 + x(N4-i,M2) = xb(i) + y(N4-i,M2) = yb(i) + enddo + +! interior of the grid + if (kb1 .eq. 1 .and. kb2 .eq. 2) then + do j=1,M2 + do i=1,L2 + x(i,j) = x(i,0) + x(0,j) - x(0,0) + y(i,j) = y(i,0) + y(0,j) - y(0,0) + enddo + enddo + else if (kb1 .eq. 1 .and. kb2 .eq. 4) then + do j=0,M2-1 + do i=1,L2 + x(i,j) = x(i,M2) + x(0,j) - x(0,M2) + y(i,j) = y(i,M2) + y(0,j) - y(0,M2) + enddo + enddo + else if (kb1 .eq. 3 .and. kb2 .eq. 2) then + do j=1,M2 + do i=0,L2-1 + x(i,j) = x(i,0) + x(L2,j) - x(L2,0) + y(i,j) = y(i,0) + y(L2,j) - y(L2,0) + enddo + enddo + else if (kb1 .eq. 3 .and. kb2 .eq. 4) then + do j=0,M2-1 + do i=0,L2-1 + x(i,j) = x(i,M2) + x(L2,j) - x(L2,M2) + y(i,j) = y(i,M2) + y(L2,j) - y(L2,M2) + enddo + enddo + endif + +! Compute pm,pn factors + do j = 1,Mm + do i = 1,Lm + pm(i,j) = 1.0/sqrt( ( x(2*i,2*j-1)-x(2*i-2,2*j-1) )**2 & + & + ( y(2*i,2*j-1)-y(2*i-2,2*j-1) )**2 ) + pn(i,j) = 1.0/sqrt( ( x(2*i-1,2*j)-x(2*i-1,2*j-2) )**2 & + & + ( y(2*i-1,2*j)-y(2*i-1,2*j-2) )**2 ) + enddo + enddo + +! M,N factors outside the boundaries + do j=1,Mm + pm(0,j) = pm(1,j) + pn(0,j) = pn(1,j) + pm(L,j) = pm(Lm,j) + pn(L,j) = pn(Lm,j) + enddo + do i=0,L + pm(i,0) = pm(i,1) + pn(i,0) = pn(i,1) + pm(i,M) = pm(i,Mm) + pn(i,M) = pn(i,Mm) + enddo + +! Compute dndx,dmde + do i=1,Lm + do j=1,Mm + dndx(i,j) = (1./pn(i+1,j) - 1./pn(i-1,j))/2. + enddo + enddo + do i=1,Lm + do j=1,Mm + dmde(i,j) = (1./pm(i,j+1) - 1./pm(i,j-1))/2. + enddo + enddo + do j=1,Mm + dndx(0,j) = 0. + dmde(0,j) = 0. + dndx(L,j) = 0. + dmde(L,j) = 0. + enddo + do i=0,L + dndx(i,0) = 0. + dmde(i,0) = 0. + dndx(i,M) = 0. + dmde(i,M) = 0. + enddo + +! Split up grid solution into separate arrays for the coordinates +! of the four locations on the Arakawa C grid corresponding to rho, +! psi, u and v points. + +! psi points + do j=1,M + do i=1,L + xp(i,j) = x(2*i-2,2*j-2) + yp(i,j) = y(2*i-2,2*j-2) + enddo + enddo + + if (subset) then + write (iout3,*) Mnorth-Msouth+1 + do j=Mnorth,Msouth,-1 + write (iout3,*) xp(Lwest,j),yp(Lwest,j) + enddo + write (iout3,*) Least-Lwest+1 + do i=Lwest,Least + write (iout3,*) xp(i,Msouth),yp(i,Msouth) + enddo + write (iout3,*) Mnorth-Msouth+1 + do j=Msouth,Mnorth + write (iout3,*) xp(Least,j),yp(Least,j) + enddo + write (iout3,*) Least-Lwest+1 + do i=Least,Lwest,-1 + write (iout3,*) xp(i,Mnorth),yp(i,Mnorth) + enddo + end if + + xl = xp(L,1) - xp(1,1) + el = yp(1,M) - yp(1,1) + +! u points + do j=1,Mm + do i=1,L + xu(i,j) = x(2*i-2,2*j-1) + yu(i,j) = y(2*i-2,2*j-1) + enddo + enddo + do i=1,L + xu(i,0) = 2*xp(i,1) - xu(i,1) + xu(i,M) = 2*xp(i,M) - xu(i,Mm) + yu(i,0) = 2*yp(i,1) - yu(i,1) + yu(i,M) = 2*yp(i,M) - yu(i,Mm) + enddo + +! vpoints + do j=1,M + do i=1,Lm + xv(i,j) = x(2*i-1,2*j-2) + yv(i,j) = y(2*i-1,2*j-2) + enddo + enddo + do j=1,M + xv(0,j) = 2*xp(1,j) - xv(1,j) + xv(L,j) = 2*xp(L,j) - xv(Lm,j) + yv(0,j) = 2*yp(1,j) - yv(1,j) + yv(L,j) = 2*yp(L,j) - yv(Lm,j) + enddo + +! rho points + do j=1,Mm + do i=1,Lm + xr(i,j) = x(2*i-1,2*j-1) + yr(i,j) = y(2*i-1,2*j-1) + enddo + enddo + do j=1,Mm + xr(L,j) = 2*xu(L,j) - xr(Lm,j) + xr(0,j) = 2*xu(1,j) - xr(1,j) + yr(L,j) = 2*yu(L,j) - yr(Lm,j) + yr(0,j) = 2*yu(1,j) - yr(1,j) + enddo + do i=0,L + xr(i,M) = 2*xv(i,M) - xr(i,Mm) + yr(i,M) = 2*yv(i,M) - yr(i,Mm) + xr(i,0) = 2*xv(i,1) - xr(i,1) + yr(i,0) = 2*yv(i,1) - yr(i,1) + enddo + +! Diagnostics: +! Compute area of domain from m,n factors + area = 0. + do j = 1,Mm + do i = 1,Lm + area = area + 1./(pm(i,j)*pn(i,j)) + enddo + enddo + + write(6,460)area + 460 format(5x,'area ',g10.4) + +! Output solution +! (This output format parallels the input format assumed by +! subroutine getgrid in pemodel) + call checkdefs + call def_grid +#if PLOTS + call start_plot + call gridplot(lbl,area,tarea) + call end_plot +#endif /* PLOTS */ +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + end + +! ******************************************************************* + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(ierr) +#endif /* NO_EXIT */ + return + end + +! ******************************************************************* + +#if PLOTS + subroutine gridplot(lbl,area,tarea) +#include "grid.h" + character*20 lbl + BIGREAL area, tarea + + character*5 lbls + integer i, j + SMALLREAL tmp(0:L,0:M), xlow, xhigh, ylow, yhigh + SMALLREAL x1, x2, y1, y2 + BIGREAL vmin, vmax + BIGREAL dxmin + + call pcseti('QUALITY',1) + + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbl,.012,0.,0.) + write(lbl,100)area + 100 format(' Sum 1/MN=',g10.4) + call plchhq(.5,.03,lbl,.012,0.,0.) + +! Draw the psi points grid (boundaries coincide with channel walls) + xlow = vmin(xp,L*M) + xhigh = vmax(xp,L*M) + yhigh = vmax(yp,L*M) + ylow = vmin(yp,L*M) + xl = xhigh-xlow + el = yhigh-ylow + if (xl .ge. el) then + x1 = 0.05 + x2 = 0.95 + y1 = -.45*el/xl + .5 + y2 = y1 + el/xl*.9 + else + y1 = 0.05 + y2 = 0.95 + x1 = -.45*xl/el + .5 + x2 = x1 + xl/el*.9 + end if + call set(x1,x2,y1,y2,xlow,xhigh,ylow,yhigh,1) +#if DBLEPREC + do j = 1,M + call frstpt(sngl(xp(1,j)),sngl(yp(1,j))) + do i = 2,L + call vector(sngl(xp(i,j)),sngl(yp(i,j))) + enddo + enddo + do i = 1,L + call frstpt(sngl(xp(i,1)),sngl(yp(i,1))) + do j = 2,M + call vector(sngl(xp(i,j)),sngl(yp(i,j))) + enddo + enddo +#else + do j = 1,M + call frstpt(xp(1,j),yp(1,j)) + do i = 2,L + call vector(xp(i,j),yp(i,j)) + enddo + enddo + do i = 1,L + call frstpt(xp(i,1),yp(i,1)) + do j = 2,M + call vector(xp(i,j),yp(i,j)) + enddo + enddo +#endif /* DBLEPREC */ + call frame + +! Plot m and n + write(lbls,130) + 130 format('DX') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbls(1:2),.012,0.,0.) + do j=0,M + do i=0,L + tmp(i,j) = 1/pm(i,j) + enddo + enddo + dxmin = vmax(pm,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dx = ',dxmin + call set(x1,x2,y1,y2,1.,float(Lp),1.,float(Mp),1) + call perim(1,L,1,M) + call cpseti('SET',0) + call cpcnrc(tmp,Lp,Lp,Mp,0.0,0.0,0.0,1,-1,-682) + call frame + write(lbls,150) + 150 format('DY') + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.5,.98,lbls(1:2),.012,0.,0.) + do j=0,M + do i=0,L + tmp(i,j) = 1/pn(i,j) + enddo + enddo + dxmin = vmax(pn,Lp*Mp) + dxmin = 1/dxmin + print *, 'minimum dy = ',dxmin + call set(x1,x2,y1,y2,1.,float(Lp),1.,float(Mp),1) + call perim(1,L,1,M) + call cpseti('SET',0) + call cpcnrc(tmp,Lp,Lp,Mp,0.0,0.0,0.0,1,-1,-682) + call frame + + return + end +#endif /* PLOTS */ + +! ******************************************************************* + + subroutine readbndy +#include "grid.h" + BIGREAL arcs(IBIG), huge + parameter ( huge = 1.e35 ) + integer i + + if (rbnd1) then +! Read x,y data points describing boundary 1 + read(5,*) nb1pts + if (nb1pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb1pts) + end if + do i=1,nb1pts + read(5,*) x1spl(i),y1spl(i) + enddo + if (.not. even1) then + do i=1,nb1pts + s1spl(i) = (i-1.)/(nb1pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb1pts + arcs(i) = arcs(i-1) + sqrt((x1spl(i)-x1spl(i-1))**2 + & + & (y1spl(i)-y1spl(i-1))**2) + enddo + do i=1,nb1pts + s1spl(i) = arcs(i)/arcs(nb1pts) + enddo + end if + + call spline(s1spl,x1spl,nb1pts,huge,huge,b1spl) + call spline(s1spl,y1spl,nb1pts,huge,huge,c1spl) + end if + + if (rbnd2) then +! Read x,y data points describing boundary 2 + read(5,*) nb2pts + if (nb2pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb2pts) + end if + do i=1,nb2pts + read(5,*) x2spl(i),y2spl(i) + enddo + if (.not. even2) then + do i=1,nb2pts + s2spl(i) = (i-1.)/(nb2pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb2pts + arcs(i) = arcs(i-1) + sqrt((x2spl(i)-x2spl(i-1))**2 + & + & (y2spl(i)-y2spl(i-1))**2) + enddo + do i=1,nb2pts + s2spl(i) = arcs(i)/arcs(nb2pts) + enddo + end if + + call spline(s2spl,x2spl,nb2pts,huge,huge,b2spl) + call spline(s2spl,y2spl,nb2pts,huge,huge,c2spl) + end if + + if (rbnd3) then +! Read x,y data points describing boundary 3 + read(5,*) nb3pts + if (nb3pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb3pts) + end if + do i=1,nb3pts + read(5,*) x3spl(i),y3spl(i) + enddo + if (.not. even3) then + do i=1,nb3pts + s3spl(i) = (i-1.)/(nb3pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb3pts + arcs(i) = arcs(i-1) + sqrt((x3spl(i)-x3spl(i-1))**2 + & + & (y3spl(i)-y3spl(i-1))**2) + enddo + do i=1,nb3pts + s3spl(i) = arcs(i)/arcs(nb3pts) + enddo + end if + + call spline(s3spl,x3spl,nb3pts,huge,huge,b3spl) + call spline(s3spl,y3spl,nb3pts,huge,huge,c3spl) + end if + + if (rbnd4) then +! Read x,y data points describing boundary 4 + read(5,*) nb4pts + if (nb4pts .gt. IBIG) then + call crash('readbndy: Need to make IBIG at least', nb4pts) + end if + do i=1,nb4pts + read(5,*) x4spl(i),y4spl(i) + enddo + if (.not. even4) then + do i=1,nb4pts + s4spl(i) = (i-1.)/(nb4pts-1.) + enddo + else + arcs(1) = 0 + do i = 2,nb4pts + arcs(i) = arcs(i-1) + sqrt((x4spl(i)-x4spl(i-1))**2 + & + & (y4spl(i)-y4spl(i-1))**2) + enddo + do i=1,nb4pts + s4spl(i) = arcs(i)/arcs(nb4pts) + enddo + end if + + call spline(s4spl,x4spl,nb4pts,huge,huge,b4spl) + call spline(s4spl,y4spl,nb4pts,huge,huge,c4spl) + end if + return + end + +! ******************************************************************* + + subroutine spline(x,y,NN,yp1,ypn,y2) + +! The following two subroutines are used to perform the cubic spline +! interpolation required to match up the distribution of points on +! opposite sides of the transformed plane rectangle. The routines +! are taken from Press,W.H., B.P.Flannery, S.A.Teukolsky and +! W.T.Vetterling: "Numerical Recipes, the Art of Scientific Computing" +! Cambridge University Press, 1986. +#include "grid.h" + integer NN + BIGREAL x(NN), y(NN), y2(NN), yp1, ypn + + integer nmax + parameter ( nmax=M2+L2 ) + BIGREAL u(nmax), sig, p, qn, un + integer i, k + + if (yp1 .gt. .99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do i=2,NN-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) & + & /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + enddo + if (ypn .gt. .99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(NN)-x(NN-1)))*(ypn-(y(NN)-y(NN-1))/(x(NN)-x(NN-1))) + endif + y2(NN)=(un-qn*u(NN-1))/(qn*y2(NN-1)+1.) + do k=NN-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + enddo + return + end + +! ******************************************************************* + + subroutine splint(xa,ya,y2a,NN,x,y) + integer NN + BIGREAL xa(NN), ya(NN), y2a(NN), x, y + + integer klo, khi, k + BIGREAL h, a, b + + klo=1 + khi=NN + 100 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if(xa(k).gt.x)then + khi=k + else + klo=k + endif + goto 100 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) call crash('splint: bad xa input', 0) + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ & + & ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + return + end + +! ******************************************************************* + + subroutine z1(s1,x,y,z) + BIGREAL s1, s2, s3, s4, x, y + BIGCOMPLEX z +#include "grid.h" + +! Subroutines which specify the boundaries of the physical +! domain. They are defined as functions of the variable s which +! ranges from 0 to 1 on each boundary, proceeding anti-clockwise. + + call splint(s1spl,x1spl,b1spl,nb1pts,s1,x) + call splint(s1spl,y1spl,c1spl,nb1pts,s1,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z2(s2,x,y,z) + call splint(s2spl,x2spl,b2spl,nb2pts,s2,x) + call splint(s2spl,y2spl,c2spl,nb2pts,s2,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z3(s3,x,y,z) + call splint(s3spl,x3spl,b3spl,nb3pts,s3,x) + call splint(s3spl,y3spl,c3spl,nb3pts,s3,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + + entry z4(s4,x,y,z) + call splint(s4spl,x4spl,b4spl,nb4pts,s4,x) + call splint(s4spl,y4spl,c4spl,nb4pts,s4,y) +#if DBLEPREC + z = dcmplx(x,y) +#else + z = cmplx(x,y) +#endif /* DBLEPREC */ + return + end + diff --git a/Drivers/tolat.F b/Drivers/tolat.F new file mode 100644 index 0000000..bc14df9 --- /dev/null +++ b/Drivers/tolat.F @@ -0,0 +1,261 @@ + program tolat + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ****************************************************************** +! +! This is a program to convert from the coordinate system in coast.f +! to back to latitude and longitude. If you change the parameters +! in coast.f you have to change them here as well, including HINIT +! and DH. This program writes out the four lat,long grids to the +! grid netCDF file. +! ****************************************************************** + +#include "griddefs.h" +#include "proj.h" +#include "bathy.h" +#include "ncgrid.h" + BIGREAL REarth + parameter ( REarth = 6.3708e6 ) + integer i, j + BIGREAL minlat, minlon, maxlat, maxlon + character*40 ident + logical dateline + BIGREAL DTOR, RTOD + BIGREAL udeg, vmin, vmax, addphase + real U1, U2, V1, V2, u, v, lat, lon + + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + +#include "gridid.h" + + call get_xy +#ifndef PLOTS + call crash('This program depends on NCAR graphics', 1) +#endif /* PLOTS */ + call start_plot + +! Initialize the mapping variables + + call pcseti('QUALITY',1) + write(ident,100) gridid(1:40) + 100 format(40a) + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ident,.012,0.,0.) + call mapsti('GR',JGRD) + call mapstc('OU','NO') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapdrw + call plotit(0,0,0) + call drawcoast + call mapiq + call maptrn(PLAT+.5,PLONG,U2,V2) + call maptrn(PLAT-.5,PLONG,U1,V1) + udeg = sqrt((U2-U1)*(U2-U1) + (V2-V1)*(V2-V1)) + +! Calculate the lat,long of the psi points + + do i=1,L + do j=1,M + u = (xp(i,j)-XOFF)*udeg*RTOD/REarth + v = (yp(i,j)-YOFF)*udeg*RTOD/REarth + call maptri(u,v,lat,lon) + lat_psi(i,j) = lat + lon_psi(i,j) = lon + enddo + enddo + +! Plot the grid in lat,long space + +#if DBLEPREC + do j = 1,M + call mapit(sngl(lat_psi(1,j)),sngl(lon_psi(1,j)),0) + do i = 2,L + call mapit(sngl(lat_psi(i,j)),sngl(lon_psi(i,j)),2) + enddo + enddo + do i = 1,L + call mapit(sngl(lat_psi(i,1)),sngl(lon_psi(i,1)),0) + do j = 2,M + call mapit(sngl(lat_psi(i,j)),sngl(lon_psi(i,j)),2) + enddo + enddo +#else + do j = 1,M + call mapit(lat_psi(1,j),lon_psi(1,j),0) + do i = 2,L + call mapit(lat_psi(i,j),lon_psi(i,j),2) + enddo + enddo + do i = 1,L + call mapit(lat_psi(i,1),lon_psi(i,1),0) + do j = 2,M + call mapit(lat_psi(i,j),lon_psi(i,j),2) + enddo + enddo +#endif /* DBLEPREC */ + call mapiq + call frame + call end_plot + +! Calculate the lat,long of the u points + + do i=1,L + do j=0,M + u = (xu(i,j)-XOFF)*udeg*RTOD/REarth + v = (yu(i,j)-YOFF)*udeg*RTOD/REarth + call maptri(u,v,lat,lon) + lat_u(i,j) = lat + lon_u(i,j) = lon + enddo + enddo + +! Calculate the lat,long of the v points + + do i=0,L + do j=1,M + u = (xv(i,j)-XOFF)*udeg*RTOD/REarth + v = (yv(i,j)-YOFF)*udeg*RTOD/REarth + call maptri(u,v,lat,lon) + lat_v(i,j) = lat + lon_v(i,j) = lon + enddo + enddo + +! Calculate the lat,long of the rho points + + do i=0,L + do j=0,M + u = (xr(i,j)-XOFF)*udeg*RTOD/REarth + v = (yr(i,j)-YOFF)*udeg*RTOD/REarth + call maptri(u,v,lat,lon) + lat_rho(i,j) = lat + lon_rho(i,j) = lon + enddo + print *,i,lat_rho(i,0),lon_rho(i,0),lat_rho(i,M),lon_rho(i,M) + enddo + + maxlat = vmax(lat_rho,Lp*Mp) + minlat = vmin(lat_rho,Lp*Mp) + maxlon = vmax(lon_rho,Lp*Mp) + minlon = vmin(lon_rho,Lp*Mp) + print *,'Latitude range ', minlat, maxlat + print *,'Longitude range ', minlon, maxlon + if (maxlat .eq. 1.e12 .or. maxlon .eq. 1.e12) then + call crash('need to modify proj.h plot range', 1) + end if + +! Write out the lat,long information + +! First check that grid doesn't span the international dateline +! If so this can mess up things in topo and sphere +! Beware: This test might not trap some nasty cases + + dateline = .false. + + addphase = 0.0 + do j = 1,M + do i = 2,L + if (abs(lon_psi(i,j)-lon_psi(i-1,j)) .gt. 270.) then + if (lon_psi(i,j) .lt. lon_psi(i-1,j)) then + addphase = 360.0 + else + addphase = -360.0 + endif + dateline = .true. + else + addphase = 0.0 + endif + lon_psi(i,j) = lon_psi(i,j) + addphase + enddo + enddo + + addphase = 0.0 + do j = 0,M + do i = 1,L + if (abs(lon_rho(i,j)-lon_rho(i-1,j)) .gt. 270.) then + if (lon_rho(i,j) .lt. lon_rho(i-1,j)) then + addphase = 360.0 + else + addphase = -360.0 + endif + dateline = .true. + else + addphase = 0.0 + endif + lon_rho(i,j) = lon_rho(i,j) + addphase + enddo + enddo + + addphase = 0.0 + do j = 0,M + do i = 2,L + if (abs(lon_u(i,j)-lon_u(i-1,j)) .gt. 270.) then + if (lon_u(i,j) .lt. lon_u(i-1,j)) then + addphase = 360.0 + else + addphase = -360.0 + endif + dateline = .true. + else + addphase = 0.0 + endif + lon_u(i,j) = lon_u(i,j) + addphase + enddo + enddo + + addphase = 0.0 + do j = 1,M + do i = 1,L + if (abs(lon_v(i,j)-lon_v(i-1,j)) .gt. 270.) then + if (lon_v(i,j) .lt. lon_v(i-1,j)) then + addphase = 360.0 + else + addphase = -360.0 + endif + dateline = .true. + else + addphase = 0.0 + endif + lon_v(i,j) = lon_v(i,j) + addphase + enddo + enddo + if(dateline) then + print *,'tolat: grid crosses Dateline (?)' + print *,' recovery attempted... check' + maxlat = vmax(lat_rho,Lp*Mp) + minlat = vmin(lat_rho,Lp*Mp) + maxlon = vmax(lon_rho,Lp*Mp) + minlon = vmin(lon_rho,Lp*Mp) + print *,'Latitude range ', minlat, maxlat + print *,'Longitude range ', minlon, maxlon + endif + + call wrt_lat + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 150 call crash('read or write error while outputing solution',0) + end + +!---------------------------------------------------------------------- + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(ierr) +#endif /* NO_EXIT */ + return + end diff --git a/External/coast.in b/External/coast.in new file mode 100644 index 0000000..5080f4a --- /dev/null +++ b/External/coast.in @@ -0,0 +1,41 @@ + 42.83 -124.54 + 42.57 -124.41 + 42.45 -124.44 + 42.34 -124.44 + 42.09 -124.33 + 42 -124.20 + 41.74 -124.17 + 41.57 -124.09 + 41.45 -124.06 + 41.11 -124.15 + 41.02 -124.10 + 40.92 -124.12 + 40.55 -124.35 + 40.44 -124.38 + 40.25 -124.35 + 40 -124.03 + 39.82 -123.82 + 39.55 -123.76 + 39.36 -123.81 + 39.20 -123.77 + 38.93 -123.74 + 38.57 -123.34 + 38.43 -123.11 + 38.23 -123 + 38 -122.86 + 37.86 -122.74 + 37.77 -122.53 + 37.57 -122.53 + 37.45 -122.46 + 37.18 -122.43 + 37 -122.20 + 36.93 -122.14 + 36.59 -121.97 + 36.30 -121.92 + 36 -121.50 + 35.68 -121.28 + 35.45 -121 + 35.24 -120.89 + 34.92 -120.64 + 34.58 -120.64 + 34.45 -120.60 diff --git a/External/grid.in b/External/grid.in new file mode 100644 index 0000000..b046a80 --- /dev/null +++ b/External/grid.in @@ -0,0 +1,56 @@ + 46 + -3.86718E+06 -1.68723E+06 + -3.86718E+06 -1.75871E+06 + -3.84716E+06 -1.86285E+06 + -3.79268E+06 -1.93138E+06 + -3.77711E+06 -2.04102E+06 + -3.74709E+06 -2.12657E+06 + -3.69261E+06 -2.18656E+06 + -3.61366E+06 -2.21131E+06 + -3.55362E+06 -2.26683E+06 + -3.48468E+06 -2.30236E+06 + -3.44910E+06 -2.38075E+06 + -3.40018E+06 -2.45472E+06 + -3.37016E+06 -2.54822E+06 + -3.33569E+06 -2.53860E+06 + -3.27565E+06 -2.57348E+06 + -3.25563E+06 -2.62774E+06 + -3.21561E+06 -2.71373E+06 + -3.14111E+06 -2.76359E+06 + -3.09218E+06 -2.83930E+06 + -3.03659E+06 -2.90924E+06 + -2.99767E+06 -3.00177E+06 + -2.99211E+06 -3.13981E+06 + -2.95765E+06 -3.23386E+06 + -2.95320E+06 -3.36408E+06 + -2.98322E+06 -3.46485E+06 + -3.01213E+06 -3.57028E+06 + -3.03770E+06 -3.68833E+06 + -3.07217E+06 -3.78649E+06 + -3.12221E+06 -3.87089E+06 + -3.18670E+06 -3.94125E+06 + -3.22116E+06 -4.04155E+06 + -3.26119E+06 -4.14410E+06 + -3.31123E+06 -4.22847E+06 + -3.34125E+06 -4.34382E+06 + -3.35126E+06 -4.46042E+06 + -3.41019E+06 -4.53887E+06 + -3.51026E+06 -4.90974E+06 + -3.53027E+06 -5.01534E+06 + -3.52471E+06 -5.17743E+06 + -3.57475E+06 -5.24667E+06 + -3.63479E+06 -5.31186E+06 + -3.68371E+06 -5.38670E+06 + -3.68371E+06 -5.61497E+06 + -3.68371E+06 -5.93514E+06 + -3.68371E+06 -6.26754E+06 + -3.68371E+06 -6.43876E+06 + 2 + -3.68371E+06 -6.43876E+06 + 3.33569E+06 -6.43876E+06 + 2 + 3.33569E+06 -6.43876E+06 + 3.33569E+06 -1.68723E+06 + 2 + 3.33569E+06 -1.68723E+06 + -3.86718E+06 -1.68723E+06 diff --git a/External/grid_1.in b/External/grid_1.in new file mode 100644 index 0000000..4d9ff66 --- /dev/null +++ b/External/grid_1.in @@ -0,0 +1,12 @@ +2 + -5281526.173 6438778.733 + -5281526.173 668362.837 +2 + -5281526.173 668362.837 + 5448311.210 668362.837 +2 + 5448311.210 668362.837 + 5448311.210 6438778.733 +2 + 5448311.210 6438778.733 + -5281526.173 6438778.733 diff --git a/External/sqgrid.in b/External/sqgrid.in new file mode 100644 index 0000000..6d20d1f --- /dev/null +++ b/External/sqgrid.in @@ -0,0 +1,440 @@ + 89 + -22944.18979578849 -3531683.793859726 + -22944.18979578849 -3534637.728235140 + -22944.18979578849 -3537591.662610555 + -22944.18979578849 -3540545.596985968 + -22944.18979578849 -3543499.531361382 + -22944.18979578849 -3546453.465736797 + -22944.18979578849 -3549407.400112211 + -22944.18979578849 -3552361.334487624 + -22944.18979578849 -3555315.268863039 + -22944.18979578849 -3558269.203238453 + -22944.18979578849 -3561223.137613867 + -22944.18979578849 -3564177.071989281 + -22944.18979578849 -3567131.006364696 + -22944.18979578849 -3570084.940740108 + -22944.18979578849 -3573038.875115523 + -22944.18979578849 -3575992.809490938 + -22944.18979578849 -3578946.743866351 + -22944.18979578849 -3581900.678241765 + -22944.18979578849 -3584854.612617180 + -22944.18979578849 -3587808.546992593 + -22944.18979578849 -3590762.481368008 + -22944.18979578849 -3593716.415743422 + -22944.18979578849 -3596670.350118836 + -22944.18979578849 -3599624.284494250 + -22944.18979578849 -3602578.218869664 + -22944.18979578849 -3605532.153245078 + -22944.18979578849 -3608486.087620492 + -22944.18979578849 -3611440.021995906 + -22944.18979578849 -3614393.956371320 + -22944.18979578849 -3617347.890746734 + -22944.18979578849 -3620301.825122148 + -22944.18979578849 -3623255.759497562 + -22944.18979578849 -3626209.693872977 + -22944.18979578849 -3629163.628248391 + -22944.18979578849 -3632117.562623804 + -22944.18979578849 -3635071.496999219 + -22944.18979578849 -3638025.431374633 + -22944.18979578849 -3640979.365750046 + -22944.18979578849 -3643933.300125461 + -22944.18979578849 -3646887.234500875 + -22944.18979578849 -3649841.168876288 + -22944.18979578849 -3652795.103251703 + -22944.18979578849 -3655749.037627117 + -22944.18979578849 -3658702.972002531 + -22944.18979578849 -3661656.906377945 + -22944.18979578849 -3664610.840753360 + -22944.18979578849 -3667564.775128773 + -22944.18979578849 -3670518.709504187 + -22944.18979578849 -3673472.643879602 + -22944.18979578849 -3676426.578255015 + -22944.18979578849 -3679380.512630429 + -22944.18979578849 -3682334.447005844 + -22944.18979578849 -3685288.381381257 + -22944.18979578849 -3688242.315756672 + -22944.18979578849 -3691196.250132086 + -22944.18979578849 -3694150.184507500 + -22944.18979578849 -3697104.118882914 + -22944.18979578849 -3700058.053258328 + -22944.18979578849 -3703011.987633742 + -22944.18979578849 -3705965.922009156 + -22944.18979578849 -3708919.856384570 + -22944.18979578849 -3711873.790759984 + -22944.18979578849 -3714827.725135398 + -22944.18979578849 -3717781.659510813 + -22944.18979578849 -3720735.593886226 + -22944.18979578849 -3723689.528261641 + -22944.18979578849 -3726643.462637055 + -22944.18979578849 -3729597.397012468 + -22944.18979578849 -3732551.331387883 + -22944.18979578849 -3735505.265763297 + -22944.18979578849 -3738459.200138710 + -22944.18979578849 -3741413.134514125 + -22944.18979578849 -3744367.068889539 + -22944.18979578849 -3747321.003264953 + -22944.18979578849 -3750274.937640367 + -22944.18979578849 -3753228.872015782 + -22944.18979578849 -3756182.806391195 + -22944.18979578849 -3759136.740766609 + -22944.18979578849 -3762090.675142024 + -22944.18979578849 -3765044.609517437 + -22944.18979578849 -3767998.543892851 + -22944.18979578849 -3770952.478268266 + -22944.18979578849 -3773906.412643679 + -22944.18979578849 -3776860.347019093 + -22944.18979578849 -3779814.281394508 + -22944.18979578849 -3782768.215769921 + -22944.18979578849 -3785722.150145336 + -22944.18979578849 -3788676.084520750 + -22944.18979578849 -3791630.018896164 + 129 + -22944.18979578849 -3791630.018896164 + -19990.25542037445 -3791630.018896164 + -17036.32104496041 -3791630.018896164 + -14082.38666954637 -3791630.018896164 + -11128.45229413221 -3791630.018896164 + -8174.517918718222 -3791630.018896164 + -5220.583543304121 -3791630.018896164 + -2266.649167890078 -3791630.018896164 + 687.2852075239643 -3791630.018896164 + 3641.219582938007 -3791630.018896164 + 6595.153958352108 -3791630.018896164 + 9549.088333766151 -3791630.018896164 + 12503.02270918025 -3791630.018896164 + 15456.95708459435 -3791630.018896164 + 18410.89146000834 -3791630.018896164 + 21364.82583542250 -3791630.018896164 + 24318.76021083648 -3791630.018896164 + 27272.69458625058 -3791630.018896164 + 30226.62896166462 -3791630.018896164 + 33180.56333707873 -3791630.018896164 + 36134.49771249277 -3791630.018896164 + 39088.43208790687 -3791630.018896164 + 42042.36646332091 -3791630.018896164 + 44996.30083873495 -3791630.018896164 + 47950.23521414906 -3791630.018896164 + 50904.16958956304 -3791630.018896164 + 53858.10396497720 -3791630.018896164 + 56812.03834039124 -3791630.018896164 + 59765.97271580528 -3791630.018896164 + 62719.90709121933 -3791630.018896164 + 65673.84146663337 -3791630.018896164 + 68627.77584204753 -3791630.018896164 + 71581.71021746157 -3791630.018896164 + 74535.64459287561 -3791630.018896164 + 77489.57896828966 -3791630.018896164 + 80443.51334370382 -3791630.018896164 + 83397.44771911786 -3791630.018896164 + 86351.38209453190 -3791630.018896164 + 89305.31646994594 -3791630.018896164 + 92259.25084535999 -3791630.018896164 + 95213.18522077415 -3791630.018896164 + 98167.11959618813 -3791630.018896164 + 101121.0539716022 -3791630.018896164 + 104074.9883470163 -3791630.018896164 + 107028.9227224304 -3791630.018896164 + 109982.8570978445 -3791630.018896164 + 112936.7914732585 -3791630.018896164 + 115890.7258486726 -3791630.018896164 + 118844.6602240866 -3791630.018896164 + 121798.5945995008 -3791630.018896164 + 124752.5289749147 -3791630.018896164 + 127706.4633503288 -3791630.018896164 + 130660.3977257429 -3791630.018896164 + 133614.3321011569 -3791630.018896164 + 136568.2664765710 -3791630.018896164 + 139522.2008519851 -3791630.018896164 + 142476.1352273992 -3791630.018896164 + 145430.0696028132 -3791630.018896164 + 148384.0039782273 -3791630.018896164 + 151337.9383536413 -3791630.018896163 + 154291.8727290554 -3791630.018896164 + 157245.8071044694 -3791630.018896164 + 160199.7414798836 -3791630.018896164 + 163153.6758552977 -3791630.018896164 + 166107.6102307116 -3791630.018896164 + 169061.5446061257 -3791630.018896164 + 172015.4789815398 -3791630.018896164 + 174969.4133569539 -3791630.018896164 + 177923.3477323679 -3791630.018896163 + 180877.2821077820 -3791630.018896164 + 183831.2164831961 -3791630.018896164 + 186785.1508586101 -3791630.018896164 + 189739.0852340242 -3791630.018896164 + 192693.0196094383 -3791630.018896164 + 195646.9539848523 -3791630.018896164 + 198600.8883602664 -3791630.018896164 + 201554.8227356804 -3791630.018896164 + 204508.7571110945 -3791630.018896163 + 207462.6914865086 -3791630.018896164 + 210416.6258619227 -3791630.018896164 + 213370.5602373368 -3791630.018896164 + 216324.4946127508 -3791630.018896164 + 219278.4289881649 -3791630.018896164 + 222232.3633635789 -3791630.018896164 + 225186.2977389930 -3791630.018896164 + 228140.2321144070 -3791630.018896164 + 231094.1664898211 -3791630.018896164 + 234048.1008652352 -3791630.018896164 + 237002.0352406492 -3791630.018896164 + 239955.9696160633 -3791630.018896164 + 242909.9039914774 -3791630.018896164 + 245863.8383668915 -3791630.018896164 + 248817.7727423055 -3791630.018896164 + 251771.7071177196 -3791630.018896164 + 254725.6414931336 -3791630.018896164 + 257679.5758685477 -3791630.018896164 + 260633.5102439618 -3791630.018896164 + 263587.4446193759 -3791630.018896164 + 266541.3789947899 -3791630.018896164 + 269495.3133702039 -3791630.018896164 + 272449.2477456180 -3791630.018896164 + 275403.1821210322 -3791630.018896164 + 278357.1164964461 -3791630.018896164 + 281311.0508718602 -3791630.018896163 + 284264.9852472743 -3791630.018896164 + 287218.9196226884 -3791630.018896164 + 290172.8539981025 -3791630.018896164 + 293126.7883735165 -3791630.018896164 + 296080.7227489306 -3791630.018896164 + 299034.6571243446 -3791630.018896164 + 301988.5914997587 -3791630.018896164 + 304942.5258751728 -3791630.018896164 + 307896.4602505869 -3791630.018896164 + 310850.3946260009 -3791630.018896164 + 313804.3290014150 -3791630.018896164 + 316758.2633768291 -3791630.018896164 + 319712.1977522431 -3791630.018896164 + 322666.1321276572 -3791630.018896164 + 325620.0665030712 -3791630.018896164 + 328574.0008784853 -3791630.018896164 + 331527.9352538994 -3791630.018896163 + 334481.8696293134 -3791630.018896164 + 337435.8040047275 -3791630.018896164 + 340389.7383801416 -3791630.018896164 + 343343.6727555557 -3791630.018896164 + 346297.6071309697 -3791630.018896164 + 349251.5415063837 -3791630.018896164 + 352205.4758817978 -3791630.018896164 + 355159.4102572119 -3791630.018896164 + 89 + 355159.4102572119 -3791630.018896164 + 355159.4102572119 -3788676.084520750 + 355159.4102572119 -3785722.150145336 + 355159.4102572119 -3782768.215769921 + 355159.4102572119 -3779814.281394508 + 355159.4102572119 -3776860.347019093 + 355159.4102572119 -3773906.412643679 + 355159.4102572119 -3770952.478268266 + 355159.4102572119 -3767998.543892851 + 355159.4102572119 -3765044.609517437 + 355159.4102572119 -3762090.675142024 + 355159.4102572119 -3759136.740766609 + 355159.4102572119 -3756182.806391195 + 355159.4102572119 -3753228.872015782 + 355159.4102572119 -3750274.937640367 + 355159.4102572119 -3747321.003264953 + 355159.4102572119 -3744367.068889539 + 355159.4102572119 -3741413.134514125 + 355159.4102572119 -3738459.200138710 + 355159.4102572119 -3735505.265763297 + 355159.4102572119 -3732551.331387883 + 355159.4102572119 -3729597.397012468 + 355159.4102572119 -3726643.462637055 + 355159.4102572119 -3723689.528261641 + 355159.4102572119 -3720735.593886226 + 355159.4102572119 -3717781.659510813 + 355159.4102572119 -3714827.725135398 + 355159.4102572119 -3711873.790759984 + 355159.4102572119 -3708919.856384570 + 355159.4102572119 -3705965.922009156 + 355159.4102572119 -3703011.987633742 + 355159.4102572119 -3700058.053258328 + 355159.4102572119 -3697104.118882914 + 355159.4102572119 -3694150.184507500 + 355159.4102572119 -3691196.250132086 + 355159.4102572119 -3688242.315756672 + 355159.4102572119 -3685288.381381257 + 355159.4102572119 -3682334.447005844 + 355159.4102572119 -3679380.512630429 + 355159.4102572119 -3676426.578255015 + 355159.4102572119 -3673472.643879602 + 355159.4102572119 -3670518.709504187 + 355159.4102572119 -3667564.775128773 + 355159.4102572119 -3664610.840753360 + 355159.4102572119 -3661656.906377945 + 355159.4102572119 -3658702.972002531 + 355159.4102572119 -3655749.037627117 + 355159.4102572119 -3652795.103251703 + 355159.4102572119 -3649841.168876288 + 355159.4102572119 -3646887.234500875 + 355159.4102572119 -3643933.300125461 + 355159.4102572119 -3640979.365750046 + 355159.4102572119 -3638025.431374633 + 355159.4102572119 -3635071.496999219 + 355159.4102572119 -3632117.562623804 + 355159.4102572119 -3629163.628248391 + 355159.4102572119 -3626209.693872977 + 355159.4102572119 -3623255.759497562 + 355159.4102572119 -3620301.825122148 + 355159.4102572119 -3617347.890746734 + 355159.4102572119 -3614393.956371320 + 355159.4102572119 -3611440.021995906 + 355159.4102572119 -3608486.087620492 + 355159.4102572119 -3605532.153245078 + 355159.4102572119 -3602578.218869664 + 355159.4102572119 -3599624.284494250 + 355159.4102572119 -3596670.350118836 + 355159.4102572119 -3593716.415743422 + 355159.4102572119 -3590762.481368008 + 355159.4102572119 -3587808.546992593 + 355159.4102572119 -3584854.612617180 + 355159.4102572119 -3581900.678241765 + 355159.4102572119 -3578946.743866351 + 355159.4102572119 -3575992.809490938 + 355159.4102572119 -3573038.875115523 + 355159.4102572119 -3570084.940740108 + 355159.4102572119 -3567131.006364696 + 355159.4102572119 -3564177.071989281 + 355159.4102572119 -3561223.137613867 + 355159.4102572119 -3558269.203238453 + 355159.4102572119 -3555315.268863039 + 355159.4102572119 -3552361.334487624 + 355159.4102572119 -3549407.400112211 + 355159.4102572119 -3546453.465736797 + 355159.4102572119 -3543499.531361382 + 355159.4102572119 -3540545.596985968 + 355159.4102572119 -3537591.662610555 + 355159.4102572119 -3534637.728235140 + 355159.4102572119 -3531683.793859726 + 129 + 355159.4102572119 -3531683.793859726 + 352205.4758817978 -3531683.793859726 + 349251.5415063837 -3531683.793859726 + 346297.6071309697 -3531683.793859726 + 343343.6727555557 -3531683.793859727 + 340389.7383801416 -3531683.793859726 + 337435.8040047275 -3531683.793859726 + 334481.8696293134 -3531683.793859726 + 331527.9352538994 -3531683.793859726 + 328574.0008784853 -3531683.793859726 + 325620.0665030712 -3531683.793859726 + 322666.1321276572 -3531683.793859726 + 319712.1977522431 -3531683.793859726 + 316758.2633768291 -3531683.793859727 + 313804.3290014150 -3531683.793859726 + 310850.3946260009 -3531683.793859726 + 307896.4602505869 -3531683.793859726 + 304942.5258751728 -3531683.793859726 + 301988.5914997587 -3531683.793859726 + 299034.6571243446 -3531683.793859726 + 296080.7227489306 -3531683.793859726 + 293126.7883735165 -3531683.793859726 + 290172.8539981025 -3531683.793859726 + 287218.9196226884 -3531683.793859726 + 284264.9852472743 -3531683.793859726 + 281311.0508718602 -3531683.793859726 + 278357.1164964461 -3531683.793859726 + 275403.1821210322 -3531683.793859726 + 272449.2477456180 -3531683.793859726 + 269495.3133702039 -3531683.793859726 + 266541.3789947899 -3531683.793859726 + 263587.4446193759 -3531683.793859726 + 260633.5102439618 -3531683.793859726 + 257679.5758685477 -3531683.793859726 + 254725.6414931336 -3531683.793859726 + 251771.7071177196 -3531683.793859726 + 248817.7727423055 -3531683.793859726 + 245863.8383668915 -3531683.793859726 + 242909.9039914774 -3531683.793859726 + 239955.9696160633 -3531683.793859727 + 237002.0352406492 -3531683.793859726 + 234048.1008652352 -3531683.793859727 + 231094.1664898211 -3531683.793859726 + 228140.2321144070 -3531683.793859726 + 225186.2977389930 -3531683.793859726 + 222232.3633635789 -3531683.793859726 + 219278.4289881649 -3531683.793859726 + 216324.4946127508 -3531683.793859726 + 213370.5602373368 -3531683.793859726 + 210416.6258619227 -3531683.793859726 + 207462.6914865086 -3531683.793859727 + 204508.7571110945 -3531683.793859726 + 201554.8227356804 -3531683.793859726 + 198600.8883602664 -3531683.793859726 + 195646.9539848523 -3531683.793859726 + 192693.0196094383 -3531683.793859726 + 189739.0852340242 -3531683.793859726 + 186785.1508586101 -3531683.793859726 + 183831.2164831961 -3531683.793859726 + 180877.2821077820 -3531683.793859727 + 177923.3477323679 -3531683.793859726 + 174969.4133569539 -3531683.793859726 + 172015.4789815398 -3531683.793859726 + 169061.5446061257 -3531683.793859726 + 166107.6102307116 -3531683.793859726 + 163153.6758552977 -3531683.793859726 + 160199.7414798836 -3531683.793859726 + 157245.8071044694 -3531683.793859726 + 154291.8727290554 -3531683.793859726 + 151337.9383536413 -3531683.793859726 + 148384.0039782273 -3531683.793859726 + 145430.0696028132 -3531683.793859726 + 142476.1352273992 -3531683.793859726 + 139522.2008519851 -3531683.793859726 + 136568.2664765710 -3531683.793859726 + 133614.3321011569 -3531683.793859726 + 130660.3977257429 -3531683.793859726 + 127706.4633503288 -3531683.793859726 + 124752.5289749147 -3531683.793859726 + 121798.5945995008 -3531683.793859727 + 118844.6602240866 -3531683.793859726 + 115890.7258486726 -3531683.793859726 + 112936.7914732585 -3531683.793859726 + 109982.8570978445 -3531683.793859726 + 107028.9227224304 -3531683.793859726 + 104074.9883470163 -3531683.793859726 + 101121.0539716022 -3531683.793859726 + 98167.11959618813 -3531683.793859726 + 95213.18522077415 -3531683.793859726 + 92259.25084535999 -3531683.793859726 + 89305.31646994594 -3531683.793859726 + 86351.38209453190 -3531683.793859726 + 83397.44771911786 -3531683.793859726 + 80443.51334370382 -3531683.793859726 + 77489.57896828966 -3531683.793859726 + 74535.64459287561 -3531683.793859726 + 71581.71021746157 -3531683.793859726 + 68627.77584204753 -3531683.793859726 + 65673.84146663337 -3531683.793859726 + 62719.90709121933 -3531683.793859726 + 59765.97271580528 -3531683.793859726 + 56812.03834039124 -3531683.793859726 + 53858.10396497720 -3531683.793859726 + 50904.16958956304 -3531683.793859726 + 47950.23521414906 -3531683.793859726 + 44996.30083873495 -3531683.793859726 + 42042.36646332091 -3531683.793859726 + 39088.43208790687 -3531683.793859726 + 36134.49771249277 -3531683.793859726 + 33180.56333707873 -3531683.793859726 + 30226.62896166462 -3531683.793859726 + 27272.69458625058 -3531683.793859726 + 24318.76021083648 -3531683.793859726 + 21364.82583542250 -3531683.793859726 + 18410.89146000834 -3531683.793859726 + 15456.95708459435 -3531683.793859726 + 12503.02270918025 -3531683.793859726 + 9549.088333766151 -3531683.793859726 + 6595.153958352108 -3531683.793859726 + 3641.219582938007 -3531683.793859726 + 687.2852075239643 -3531683.793859726 + -2266.649167890078 -3531683.793859726 + -5220.583543304121 -3531683.793859726 + -8174.517918718222 -3531683.793859726 + -11128.45229413221 -3531683.793859726 + -14082.38666954637 -3531683.793859726 + -17036.32104496041 -3531683.793859726 + -19990.25542037445 -3531683.793859726 + -22944.18979578849 -3531683.793859726 diff --git a/Include/bathy.h b/Include/bathy.h new file mode 100644 index 0000000..8934520 --- /dev/null +++ b/Include/bathy.h @@ -0,0 +1,37 @@ +#include "gridparam.h" + integer L, M, Lp, Mp, L2d + parameter ( L=Lm+1, M=Mm+1, Lp=Lm+2, Mp=Mm+2 ) + parameter ( L2d=Lp*Mp ) +! lcflag tells which color bar to use, 1 - 6 (so far). If negative +! then black outlines are drawn over the color contour regions. +! 5 is shades of grey, 2 is John's Gebco chart attempt. + integer lcflag + parameter ( lcflag=-2 ) + real x_v(0:Lm+3,0:Mm+3), y_v(0:Lm+3,0:Mm+3) + common /xxyys/ x_v, y_v + BIGREAL xp(L,M), yp(L,M), xr(0:L,0:M), yr(0:L,0:M), & + & xu(L,0:M), yu(L,0:M), xv(0:L,M), yv(0:L,M), & + & xl, el + real xmin, ymin, xmax, ymax + common /grdpts/ xp, yp, xr, yr, xu, yu, xv, yv, xl, el, & + & xmin, ymin, xmax, ymax + BIGREAL f(0:L,0:M), h(0:L,0:M) + common /parm/ f, h + BIGREAL pm(0:L,0:M), pn(0:L,0:M), & + & dndx(0:L,0:M), dmde(0:L,0:M) + common /pmpn/ pm, pn, dndx, dmde + BIGREAL lat_psi(L,M), lon_psi(L,M), & + & lat_rho(0:L,0:M), lon_rho(0:L,0:M), & + & lat_u(L,0:M), lon_u(L,0:M), & + & lat_v(0:L,M), lon_v(0:L,M) + common /latlon/ lat_psi, lon_psi, lat_rho, lon_rho, & + & lat_u, lon_u, lat_v, lon_v + BIGREAL mask_rho(0:L,0:M), mask_u(L,0:M), & + & mask_v(0:L,M), mask_psi(L,M) + common /rmask/ mask_rho, mask_u, mask_v, mask_psi + BIGREAL angle(0:L,0:M) + common /angles/ angle + integer*2 depthmin, depthmax + common /hmins/ depthmin, depthmax + logical spherical + common /logic/ spherical diff --git a/Include/coast.h b/Include/coast.h new file mode 100644 index 0000000..d6d0fbf --- /dev/null +++ b/Include/coast.h @@ -0,0 +1,9 @@ + integer IBIG + parameter ( IBIG = 300) + real clat(IBIG), clong(IBIG) + common /coast/ clat, clong +! backward is a logical variable which is true if you read in the +! data in the direction opposite to the direction it should be +! written out for the grid program. + logical backward + parameter ( backward = .false. ) diff --git a/Include/grid.h b/Include/grid.h new file mode 100644 index 0000000..e4181c0 --- /dev/null +++ b/Include/grid.h @@ -0,0 +1,75 @@ +#include "griddefs.h" +#include "bathy.h" + integer ITMAX, IBIG + parameter ( ITMAX=8, IBIG=400 ) +! ITMAX is the number of iterations to perform +! IBIG is the largest number of points to be read in for one +! boundary. +! +! original distribution of x,y points is preserved on boundary kb1 +! and kb2: + integer kb1, kb2 + parameter ( kb1 = 1, kb2 = 4 ) + + integer L2, M2, L2big, M2big, nwrk + integer N, N1, N2, N3, N4 + parameter ( L2=2*(L-1), M2=2*(M-1) ) + parameter ( L2big=2*Lm, M2big=2*Mm ) + parameter ( N1=M2, N2=M2+L2, N3=M2+L2+M2, & + & N4=M2+L2+M2+L2, N=N4 ) + integer KK + parameter ( KK = 9 ) + parameter ( nwrk = 2*(KK-2)*(2**(KK+1)) + KK + 10*M2big + & + & 12*L2big + 27 ) + BIGREAL sxi(0:L2big), seta(0:M2big) + common / xiej / sxi, seta + BIGREAL x1spl(IBIG),x2spl(IBIG),x3spl(IBIG),x4spl(IBIG), & + & y1spl(IBIG),y2spl(IBIG),y3spl(IBIG),y4spl(IBIG), & + & s1spl(IBIG),s2spl(IBIG),s3spl(IBIG),s4spl(IBIG), & + & b1spl(IBIG),b2spl(IBIG),b3spl(IBIG),b4spl(IBIG), & + & c1spl(IBIG),c2spl(IBIG),c3spl(IBIG),c4spl(IBIG) + integer nb1pts,nb2pts,nb3pts,nb4pts + common / bdata/ x1spl, x2spl, x3spl, x4spl, & + & y1spl, y2spl, y3spl, y4spl, & + & s1spl, s2spl, s3spl, s4spl, & + & b1spl, b2spl, b3spl, b4spl, & + & c1spl, c2spl, c3spl, c4spl, & + & nb1pts, nb2pts, nb3pts, nb4pts +! The boundary values are read from stdin for edges which have +! rbnd true. For boundaries which are read in, the grid spacing +! is proportional to distance along the boundary if even? is true. +! Otherwise, it is proportional to the spacing of the supplied +! boundary points. + logical rbnd1, rbnd2, rbnd3, rbnd4, & + & even1, even2, even3, even4 + parameter ( rbnd1=.true., rbnd2=.true., & + & rbnd3=.true., rbnd4=.true., & + & even1=.false., even2=.true., & + & even3=.true., even4=.true. ) + +! The following are used when you need to fit a boundary with +! bumps on opposite sides and need to make intermediate partial +! grids. Set pleft1 or pbot1 to true to print out the boundaries +! of a partial left or bottom grid. Set pleft2 or pbot2 to true +! to print out the new left or bottom boundary. Lmiddle or Mmiddle +! gives the position of the interior boundary for the intermediate +! grid. The boundaries are written out to iout1 or iout2. +! +! Don't forget to adjust the evenx flags, kb1 and kb2 accordingly. + logical pleft1, pleft2, pbot1, pbot2 + integer Lmiddle, Mmiddle, iout1, iout2 + parameter ( pleft1=.false., pleft2=.false., & + & pbot1=.false., pbot2=.false., & + & Lmiddle=49, Mmiddle=25, & + & iout1=13, iout2=14 ) + +! These variables are used for writing out a subset of the psi points +! to be used in generating a nested domain. + logical subset + integer Lwest, Least, Msouth, Mnorth, iout3 + parameter ( subset = .false., Lwest = 10, Least = 20, & + & Msouth = 10, Mnorth = 20, iout3 = 15 ) + +! xpots unit numbers + integer ipot1, ipot2, ipot3, ipot4 + parameter ( ipot1=41, ipot2=42, ipot3=43, ipot4=44 ) diff --git a/Include/griddefs.h b/Include/griddefs.h new file mode 100644 index 0000000..bd0aa93 --- /dev/null +++ b/Include/griddefs.h @@ -0,0 +1,53 @@ +! define as 1 for ETOPO5 bathymetry +#undef ETOPO5 +! define as 1 for ETOPO2 bathymetry +#undef ETOPO2 +#define GEBCO 1 + +! for 64-bit output +#define DBLEPREC 1 + +! to draw coastlines on some plots +#define DRAW_COASTS 1 + +! to keep ellipsoidal terms in Earth's shape +#define ELLIPSOID 1 + +! for averaging bathymetry in gridbox (for EW/NS grids only) +#undef IMG_AVG + +#define KEEP_SHALLOW 1 + +! for NCAR graphics (3.2 or better) */ +#define PLOTS 1 +! for X windows rather than metafile */ +#undef X_WIN + +#undef SYS_POTS /* unimplimented system calls */ +#undef XPOTS1 /* read ipot1 file */ +#undef XPOTS2 /* read ipot2 file */ +#undef XPOTS3 /* read ipot3 file */ +#undef XPOTS4 /* read ipot4 file */ + +#ifdef cray +#undef DCOMPLEX +#define DBLEPREC 1 /* for 64-bit output */ +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#else +#if DBLEPREC +#define DCOMPLEX 1 /* for compilers which support complex*16 */ +#define SMALLREAL real +#define BIGREAL real*8 +#define BIGCOMPLEX complex*16 +#define FLoaT dfloat +#else +#undef DCOMPLEX +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#endif /* DBLEPREC */ +#endif /* cray */ diff --git a/Include/gridid.h b/Include/gridid.h new file mode 100644 index 0000000..675d613 --- /dev/null +++ b/Include/gridid.h @@ -0,0 +1,6 @@ +! gridid is an 80 character string, the first 40 of which are +! used as a plot label. +! gridfile is the name of the netCDF file produced by the +! grid/sqgrid programs + gridid = 'Gulf of Mexico #1' + gridfile = 'grid_gom.nc' diff --git a/Include/gridparam.h b/Include/gridparam.h new file mode 100644 index 0000000..4523f04 --- /dev/null +++ b/Include/gridparam.h @@ -0,0 +1,2 @@ + integer Lm, Mm + parameter ( Lm=72 , Mm=42 ) diff --git a/Include/ncgrid.h b/Include/ncgrid.h new file mode 100644 index 0000000..a384f77 --- /dev/null +++ b/Include/ncgrid.h @@ -0,0 +1,43 @@ +! +!======================================================================= +! Include file "ncscrum.h" +!======================================================================= +! +! maxvar Maximum number of variables for input NetCDF files. +! ncgridid NetCDF ID for grid file. +! nvars Number of variables defined in current input NetCDF file. +! nvdims Number of dimensions for each variables in current input +! NetCDF file. +! rcode Error code returned by NetCDF library (0 for no errors). +! bathsize Size of unlimited time record dimension in current input +! NetCDF file. +! varid Generic ID for arbitrary variables in NetCDF files. +! varnam Names of all variables in current input NetCDF file. +! vdims Dimension IDs for each of the variables in current input +! NetCDF file. +! +!======================================================================= +! + integer maxvar + parameter (maxvar=100) +! + integer bathindex, nvdims(maxvar), & + & vdims(5,maxvar), nvars, ncgridid, rcode, & + & varid, vartyp, bathsize + common /incgrid/ bathindex, nvdims, vdims, nvars, & + & ncgridid, rcode, varid, vartyp, & + & bathsize +! + character*5 version + integer patchlevel, stdout + parameter ( version='5.3 ' ) + parameter ( patchlevel=0 ) + parameter ( stdout=6 ) + + character*44 date_str + character*120 history + character*15 varnam(maxvar) + common /cncgrid/ date_str, history, varnam + character*1024 CPPoptions + character*80 gridfile, grid1_file, gridid, type + common /strings/ CPPoptions, gridfile, grid1_file, gridid, type diff --git a/Include/proj.h b/Include/proj.h new file mode 100644 index 0000000..c174c20 --- /dev/null +++ b/Include/proj.h @@ -0,0 +1,9 @@ + character*2 JPRJ, JLTS + real PLAT, PLONG, ROTA, P1, P2, P3, P4, XOFF, YOFF + integer JGRD + parameter ( JPRJ = 'ME', PLAT = 0.000000, & + & PLONG = -80.000000, ROTA = 0.000000, & + & JLTS = 'CO', P1 = 5.000000, & + & P2 = -100.000000, P3 = 33.000000, & + & P4 = -57.000000, JGRD = 10) + parameter ( XOFF = 0., YOFF = 0.) diff --git a/Include/sphereflags.h b/Include/sphereflags.h new file mode 100644 index 0000000..2cf3cb6 --- /dev/null +++ b/Include/sphereflags.h @@ -0,0 +1,14 @@ +! ******************************************************************* +! Logicals: +! hflat - true for constant depth of h0 - don't read in topography. +! spherical - true for spherical geometry in pm's and pn's or false +! for planar geometry. +! colour - true for colour fill plots (false gives contours) +! grover - true to draw grid over colour filled plots +! readlat - true to read in the lat, long file produced by tolat. +! ******************************************************************* + spherical = .true. + hflat = .false. + colour = .true. + grover = .false. + readlat = .true. diff --git a/Obsolete/README b/Obsolete/README new file mode 100644 index 0000000..f1b9d76 --- /dev/null +++ b/Obsolete/README @@ -0,0 +1,71 @@ +*** In gridpak version 5.4 ***** April 27, 2000 ***************** + Kate Hedstrom (kate@ahab.rutgers.edu) + John Wilkin (jl.wilkin@auckland.ac.nz) +******************************************************************** + +New in 5.4: + +Fixed up stretch to use with the netCDF file. It now reads one grid +file and writes another one. In order to use it, you need to edit +gridparam.h and add 1 to L, you need to edit gridid.h to make +grid1_file point to the old file and gridfile point to the new file, +and you need to edit opencdf.F to cut out the dimension checks on L and +LP. + +Changed mapbath to use the netCDF bathymetry files. + +See ../proj for double precision Coast and Tolat. + +New in 5.3: + +Added KEEP_SHALLOW option - see the manual. +Fixed a few bugs. +Took out MUD2 option and added sepeli to gridpak, so we no longer need +to link to spemlib.a. + +New in 5.2: + +Updated to netcdf 3.4 interface - change Fortran names to lower case. + +New in 5.1: + +Updated to netcdf 3.3 interface - just to try it out. + +New in 5.0: + +Here is the new, improved gridpak. The following programs now all +write to the same netCDF file which gets created by either grid or +sqgrid. A variable called hraw is used for the working bathymetry. +hraw has an unlimited dimension so that a number of different +smoothing options can be tried. + +bathtub now reads a netCDF version of the entire etopo5 file. We +are assuming that you are using a machine with sufficient memory for +this. + +grid: computes an orthogonal boundary fitted grid by conformal mapping + reads from stdin + creates the netCDF grid file and + writes pm,pn,x_psi,y_psi,x_rho,y_rho,x_u,y_u,x_v,y_v +sqgrid: computes a rectangular grid + reads from stdin + creates the netCDF grid file and + writes pm,pn,x_psi,y_psi,x_rho,y_rho,x_u,y_u,x_v,y_v +tolat: converts the cartesian grid coordinates back to lat,lon +bathtub: inTerpolate User Bathymetry from etopo5 at lan,lon points +bathsoap: Smooth Over All Points using a Shapiro filter +bathsuds: User Defined Smoothing using a modified Shapiro filter +sphere: recalculates pm,pn and f if required on a sphere, writes + the requested version of hraw into the h variable in + the netCDF file. +mask_fill: read the rho mask and write out consistent u,v,psi masks. +mapbath: read the bathymetry file (etopo5) and find one contour, + write out the lat, lon values of that contour to fort.58. +stretch: reads a grid file and writes a new one which has L=L+1 + and is periodic (assuming the original one matched at the edges + + +These programs have not been updated: + +coast: converts lat,lon points to x,y coordinates + reads from stdin diff --git a/Obsolete/README.4 b/Obsolete/README.4 new file mode 100644 index 0000000..1fe8d07 --- /dev/null +++ b/Obsolete/README.4 @@ -0,0 +1,132 @@ +New in version 4.0: + +1. This directory now follows the convension of using .F as the + filename extension and using the C preprocessor. Also, there are + Makefiles for the computer architectures to which I have access. + It now passes the "implicit none" compiler flags. + +2. The bathsuds smoother is included. This is an attempt at reducing + the slope parameter defined in Beckmann and Haidvogel while + retaining as much structure as possible. The general wisdom on + bathymetry smoothing is that you just do whatever (cheating) is + required to get the model to run. Note that this filter retains + some 2 delta x signal, which you probably want to remove with a + pass of bathsoap. + +3. bathsoap, bathsuds, and sphere now have an option to draw the + coastlines from the xcoast 2.0 database. + +4. grid now uses a 64 bit precision mud2 version 3.0 or sepeli. The + sepeli option requires a spemlib dated 20 Feb. 1995 or newer. + The double precision means that you will no longer need to + generate a single precision spemlib just for the grid package. + + sepeli allows you to make a grid with any value of L, M as long + as both are larger than 5. sepeli also requires 64 bits of + precision for non-trivial grids. + +5. tolat now has a flag for using maptri instead of mapinv, if you + have NCAR graphics version 3.2. maptri is *much* more reliable + and flexible than mapinv. + +6. found and fixed a bug in grid.F when L!=M and when using the + Lsmall!=L option. This should make it easier to generate grids + that are too fine for rect to handle, but not too fine for the + elliptic solver to handle. + +Not yet all there: +7. xpots stuff in grid. Actually, it works but not as nicely as in + Rich Signell's version. This option allows you to control the + grid spacing along two boundaries more easily, using the xpots + X11 program. xpots.tar is in the pub/util directory on ahab. + Example: + + (1) #define XPOTS1 and XPOTS4 to control the grid spacing on sides 1 + and 4. + + (2) run xpots with appropriate arguments. If L=129,M=97 then you + need "-N 257" and "-N 193". + + xpots -F fort.41 -N 193 & # writes fort.41 for side 1 + xpots -F fort.44 -N 257 & # writes fort.44 for side 4 + + (3) set the sliders the way you want. You will just have to try + this and iterate. Click on the "write" button. + + (4) make and run grid. Look at the plots and go back to step (3) + if not satisfied. + + Note: my xpots files are read before rect is called. Rich has + his set up to call rect ITMAX times and then iterate on a loop + containing the xpots read, use the values, and plot. I'll fix + it next time I need a complex grid. + + +8. examples. + +9. a manual. + + +New in version 3.0: + +1. There are now a number of include files, into which we have + isolated most of the variables that a user would be likely to + modify. + +2. We have broken out subroutines which are shared by more than one of + these programs into separate files, so that they only have to be + maintained in one place. + +3. To organize all the include files and shared subroutines, a + Makefile is provided. If you are running on a non-Unix system you + are on your own. + +4. There is a bathymetry dataset in IEEE integer*2 format which can be + read by the bathers program on at least a Sun and an Iris. The + bathymetry file is 18662400 bytes. + +5. bathsoap and sphere now produce color (colour) contour plots if so + desired. + +6. There are now example files for several grids, from which you + should be able to create the grids and the SPEM files (possibly + without bathymetry). Each example has its files in a subdirectory + of this one. Just copy the files to this directory, edit the + Makefile for your system, and run 'make'. The examples are: + + a. The original California coast lat, lon file with a conformal + conic projection. The stereographic inversion in tolat is so + nasty that only the bold should try it. If you need a + stereographic projection, the USGS has a map projection package + which you should look into. A manual for this package is + available from: + + Gerry Evenden + U.S. Geological Survey + Quissett Campus + Woods Hole, MA 02543 + + gctp: available via anonymous ftp + ftp to nmdpow9.er.usgs.gov (128.128.19.24) + cd pub/software/current_software/gctp + + + b. A Tasman sea grid with a Mercator projection. + + c. A rectangular grid used for a periodic channel run. No + projections are used. + Use grid, sphere, and stretch. + + d. A North Atlantic basin grid. The classic example of why this + gridding scheme is not flexible enough. We ran this with a flat + bottom. + + e. A Northeast Atlantic grid. + +7. sphere will now optionally recalculate the pm and pn arrays for a + spherical geometry. This is only valid if you are using a conformal + projection such as Mercator, conformal conic, or stereographic. + +Future improvements: + +1. Bathymetry smoothing in matlab. diff --git a/Obsolete/README.Compilers b/Obsolete/README.Compilers new file mode 100644 index 0000000..9f972c1 --- /dev/null +++ b/Obsolete/README.Compilers @@ -0,0 +1,21 @@ +Sun: + +The grid program uses complex arithmetic and is quite a challenge +for some compilers. I have been having trouble with the current +version of the Sun Solaris f77 - the grid program reports a "tracking +error" for perfectly good inputs. I have been building grids under +SunOS instead, but have also built a grid on Solaris using Sun's +f90. Gnu Fortran (g77) also works. + +Dec: + +One user reported that she needed to "limit stacksize 32m" before +running bathtub. Otherwise, she got "signal Segmentation fault" when +running the very first executable line. + +Gnu: + +Note that with g77, you need to build the netCDF libraries with g77 in +order to link with them. Be sure to use the -Df2cFortran option in +CFLAGS when compiling the netCDF library. If you #define PLOTS, you +also need to build the NCAR graphics libraries with g77. diff --git a/Obsolete/automask b/Obsolete/automask new file mode 100755 index 0000000..c281b0f --- /dev/null +++ b/Obsolete/automask @@ -0,0 +1,111 @@ +#!/work/kate/bin/perl -w +# +# Tool for creating a ROMS landmask from a coastline file. +# For now, we want to work in the longitude range 0 <= lon < 360. + +use strict; +use PDL; +use PDL::NetCDF; + +#my $grid_file = ">tiny.nc"; +my $grid_file = ">PWS_grid_2.nc"; +my $coast_file = $ENV{'XCOASTDATA'}; + +# Read the lat, lon values +my $ncobj = PDL::NetCDF->new($grid_file); +my $grid_lat = $ncobj->get('lat_rho'); +my $grid_lon = $ncobj->get('lon_rho'); +# check longitude range +$grid_lon += 360*($grid_lon < 0); + +my $mask_rho = ones($grid_lat); +my $dims = pdl $grid_lat->dims; +my $imax = $dims->at(0); +my $jmax = $dims->at(1); + +print "coastline = $coast_file\n"; + +# Read the coastline, one chunk at a time +my (@latc, @lonc); + +my $count; +open (COAST, $coast_file); +while () { + my ($lat, $lon) = split(); + if ($lat <= 90.) { + if ($lon < 0) { $lon += 360.; } + push(@latc, $lat); + push(@lonc, $lon); + } else { +# don't want first and last point to be the same + if ($latc[0] == $latc[$#latc] && $lonc[0] == $lonc[$#lonc]) { + $#lonc--; + $#latc--; + } + my ($i, $j); + for ($i = 0; $i < $imax; $i++) { + for ($j = 0; $j < $jmax; $j++) { + my $glat = $grid_lat->at($i,$j); + my $glon = $grid_lon->at($i,$j); + my $in = inside($glon, $glat, \@lonc, \@latc); + if ($in) { + my $mask = $mask_rho->slice("$i,$j"); + $mask .= 0; + } + } + } + $#latc = -1; + $#lonc = -1; + $count++; + print "Done with chunk $count\n"; + } +} + +$ncobj->put('mask_rho', ['eta_rho', 'xi_rho'], $mask_rho); +my $mask_u = $mask_rho->slice("0:-2,:") * $mask_rho->slice("1:-1,:"); +my $mask_v = $mask_rho->slice(":,0:-2") * $mask_rho->slice(":,1:-1"); +my $mask_psi = $mask_rho->slice("0:-2,0:-2") + * $mask_rho->slice("0:-2,1:-1") + * $mask_rho->slice("1:-1,0:-2") + * $mask_rho->slice("1:-1,1:-1"); +$ncobj->put('mask_u', ['eta_u', 'xi_u'], $mask_u); +$ncobj->put('mask_v', ['eta_v', 'xi_v'], $mask_v); +$ncobj->put('mask_psi', ['eta_psi', 'xi_psi'], $mask_psi); + +# end of main + +sub inside { + my ($x, $y, $xr, $yr) = @_; + my @xb = @$xr; + my @yb = @$yr; + if ($#xb < 2) { return 0;} + + my $nc = 0; + my @yc; + for (my $k=0; $k <= $#xb; $k++) { + my $kp1 = int($k + 1 - ($k)*int(($k)/$#xb)); + my $kw = $k; + next if ($xb[$k] == $xb[$kp1]); + if ($xb[$k] > $xb[$kp1]) { + $kw = $kp1; + } + my $ke = $k + $kp1 - $kw; + next if ($x > $xb[$ke]); + next if ($x < $xb[$ke] and $x <= $xb[$kw]); + my $slope = ($yb[$ke] - $yb[$kw]) / ($xb[$ke] - $xb[$kw]); + $yc[$nc] = $yb[$kw] + ($x - $xb[$kw])*$slope; + $nc++; + } + +# count the number of times that the boundary cut sthe meridian +# through ($x,$y) south of ($x,$y). An odd count indicates the point +# is inside, even indicates outside. + + my $ind = 0; + if ($nc > 0) { + for (my $k=0; $k < $nc; $k++) { + if ($yc[$k] < $y) { $ind = (1-$ind); } + } + } + $ind; +} diff --git a/Obsolete/bloc.F b/Obsolete/bloc.F new file mode 100644 index 0000000..99ddd7c --- /dev/null +++ b/Obsolete/bloc.F @@ -0,0 +1,80 @@ +#include "griddefs.h" + program bloc_data +c +#include "bathy.h" +#include "ncgrid.h" + integer incri, incrj, ibloc, jbloc + parameter(incri=22,incrj=33) + parameter(ibloc=4,jbloc=2) + BIGREAL tmp(0:L,0:M) + integer jmin, jmax, imin, imax, nblocj + integer i, j, nbloc + +#include "gridid.h" + +c Lecture de la bathymetrie + call get_h + +c Division par 10 de la bathymetrie + do i=0,L + do j=0,M + tmp(i,j) = h(i,j)/10. + enddo + enddo + +c Ecriture des blocs + open(15,file='Bloc_data.h100m.br',form='formatted') +cm open(15,file='Bloc_mask.etopo5',form='formatted') + jmin=0 + jmax=incrj + nblocj=1 + do while(jmin .lt. jbloc*incrj) + nbloc=nblocj + imin=0 + imax=incri + do while (imin .lt. ibloc*incri) + write(15,99)nbloc + write(15,100)imin,imax + write(15,101)jmin,jmax + write(15,102)(i,i=imin,imax) + write(15,*)' ' + do j = jmax, jmin,-1 + write(15,990) j,(tmp(i,j),i=imin,imax) + enddo + write(15,*)' ' + imin=imax + imax=imax+incri + nbloc=nbloc+1 + if (imax.gt.L) imax=L + enddo + jmin=jmax + jmax=jmax+incrj + nblocj=nbloc + if (jmax.gt.M) jmax=M + enddo + close(15) +99 format('Donnees du bloc No',i3) +100 format('imin=',i3,x,'imax=',i3) +101 format('jmin=',i3,x,'jmax=',i3) +102 format(2x,31(x,i4)) +990 format(x,i3,31(x,f4.0)) +cm --------------------------- +c + call crash(' ', 0) + end + +c ******************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end diff --git a/Obsolete/combbathy.F b/Obsolete/combbathy.F new file mode 100644 index 0000000..7e04d60 --- /dev/null +++ b/Obsolete/combbathy.F @@ -0,0 +1,145 @@ +#include "griddefs.h" + program combl_bathy + +c Ce programme permet de combler : +c - le Gulf du mexique a depthgm +c - la mer des antilles a depthgm +c - le pacifique a depthmin + +#include "bathy.h" +#include "ncgrid.h" + real depthmin, depthgm + parameter (depthmin=200.,depthgm=3000.) +!* Mediterranee + integer imedmin1, imedmax1, jmedmin1, jmedmax1 + parameter (imedmin1=183,imedmax1=L,jmedmin1=48,jmedmax1=70) +!* Pacifique + integer ipmin, ipmax, jpmin, jpmax + parameter (ipmin=0,ipmax=41,jpmin=0,jpmax=78) +!* Gulf du mexique + integer igmmin, igmmax, jgmmin, jgmmax + parameter (igmmin=0,igmmax=35,jgmmin=28,jgmmax=47) +!* Mer des Antilles 1 + integer imamin1, imamax1, jmamin1, jmamax1 + parameter (imamin1=16,imamax1=55,jmamin1=8,jmamax1=27) +!* Mer des Antilles 2 + integer imamin2, imamax2, jmamin2, jmamax2 + parameter (imamin2=56,imamax2=69,jmamin2=8,jmamax2=23) + integer i, j, imax0, jmax0, imaxj + logical pacific_auto + +#include "gridid.h" + + pacific_auto=.true. + +c Lecture des donnees. + call get_h + +c GULF DU MEXIQUE a mettre a 3000 m maxi +c lat : 20N ---> 30N +c lon : 99.8W ---> 80W + do i=igmmin,igmmax + do j=jgmmin,jgmmax + if (h(i,j).gt.depthgm) h(i,j)=depthgm + enddo + enddo + +c MER DES ANTILLES a mettre a 3000 m maxi +c premier cadran +c lat : 10N ---> 20N +c lon : 90W ---> 70W + do i=imamin1,imamax1 + do j=jmamin1,jmamax1 + if (h(i,j).gt.depthgm) h(i,j)=depthgm + enddo + enddo +c deuxieme cadran +c lat : 10N ---> 18N +c lon : 70W ---> 63W + do i=imamin2,imamax2 + do j=jmamin2,jmamax2 + if (h(i,j).gt.depthgm) h(i,j)=depthgm + enddo + enddo + +c DOMAINE DE LA MEDITERRANNEE a mettre a depthmin +c premier cadran +c lat : 30N ---> 40N +c lon : 6W ---> 0W + do i=imedmin1,imedmax1 + do j=jmedmin1,jmedmax1 + if (h(i,j).gt.depthmin) h(i,j)=depthmin + enddo + enddo +c deuxieme cadran +c lat : 30N ---> 45N +c lon : 0W ---> 17.8W +! do i=imedmin2,imedmax2 +! do j=jmedmin2,jmedmax2 +! if (h(i,j).gt.depthmin) h(i,j)=depthmin +! enddo +! enddo + +c DOMAINE DU PACIFIQUE a mettre a 200 m (ou 100m) +c lat : 17.7S ---> 8N +c lon : 99.8W ---> 60W + if (pacific_auto.eq..false.) then + print*,'pacific_auto est faux ' + do i=ipmin,ipmax + do j=jpmin,jpmax + h(i,j)=depthmin + enddo + enddo + + else + + do j=0,M + if(h(0,j).le.depthmin) then + jmax0=j + goto 11 + endif + enddo + 11 print *,'jmax0=',jmax0 + do i=0,L + if(h(i,0).le.depthmin) then + imax0=i + goto 13 + endif + enddo + 13 print *,'imax0=',imax0 + do j=0,jmax0 + do i=0,imax0 + if (h(i,j).le.depthmin) then + imaxj = i +c print*,'imaxj = ',imaxj + goto 22 + endif + enddo + 22 do i=0,imaxj + h(i,j)=depthmin + enddo + enddo + + endif ! pacific_auto + +c Sortie de la bathymetrie comblee + call wrt_h + + call crash(' ', 0) + end + +c ******************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end diff --git a/Obsolete/lectgrid.F b/Obsolete/lectgrid.F new file mode 100644 index 0000000..a48a0d2 --- /dev/null +++ b/Obsolete/lectgrid.F @@ -0,0 +1,51 @@ + program lectgrid +#include "griddefs.h" +#include "bathy.h" +#include "ncgrid.h" + integer i, j + +#include "gridid.h" + + call get_lat + + print*,'rholat(',L,',',M,')=',lat_rho(L,M) + print*,'rholon(0,0)=',lon_rho(0,0) + print*,'psilat(',L,',',M,')=',lat_psi(L,M) + print*,'psilon(1,1)=',lon_psi(1,1) + + open(1,file='rlon.ce',form='formatted') + write(1,110) + do i=0,L + write(1,210) i,lon_rho(i,M) + enddo + do j=0,M + write(1,211) j,lat_rho(L,j) + enddo + close(1) + +100 format('Latitude (degre) des points T : " rholat(j) j=1,353"') +110 format('Longitude (degre) des points T : "rholon(i) i=0,353"') +200 format(7(x,f10.5)) +210 format('i=',i3,2x,'rholon=',f11.4) +211 format('i=',i3,2x,'rholat=',f11.4) +220 continue + + call crash(' ', 0) + end + +c ****************************************************************** + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + return + end + diff --git a/Obsolete/mapbath.F b/Obsolete/mapbath.F new file mode 100644 index 0000000..8854767 --- /dev/null +++ b/Obsolete/mapbath.F @@ -0,0 +1,444 @@ + program mapbath +! ******************************************************************* +! From Ichiro Fukumori, edited by Kate Hedstrom to change +! input file +! +! Map out bathymetry using NCAR contour routine STLINE-DRLINE +! This is accomplished by replacing NCAR's FRSTD, VECTD, LASTD +! to user supplied routines that just print out latitude, +! longitude data to file. Note also that user supplied FX, FY +! functions that map data location to coordinate is needed. +! Output is written to file 59. (58 is scratch file) +! Format is number of points followed by that number of lat, +! long pairs. +! +! Bathymetry data is subset of etopo5 as done by bathers +! +! ******************************************************************* + +#include "griddefs.h" +#include "bath2.h" + +! Bathymetry data + integer*2 bathy(ILON,ILAT) + real bot(ILON,ILAT) + +! Common for functions fx, fy + integer i, j + real depth + +!--------------------------------------------------------------------- + + call extract(lon,lat,bathy,ILON,ILAT) + +! parameters describing grid of bot + xlonmi = lon(1) + xlonma = lon(ILON) + ylatmi = lat(1) + ylatma = lat(ILAT) + + do j=1,ILAT + do i=1,ILON + bot(i,j) = bathy(i,j) + enddo + enddo + + print *,'Print depth of contour (positive is above sea level): ' + read *,depth +! depth = -depth + +! Start NCAR graphics + call opngks + +! Contour + call stline (bot,ILON,ILON,ILAT,depth) + +! End NCAR + call clsgks + +#if NO_EXIT + stop +#else + call exit(0) +#endif /* NO_EXIT */ + 210 call crash('read or write error while outputing solution', 0) + 9999 call crash(' Error reading in topography file ', 1) + end + +!---------------------------------------------------------------------- + + subroutine crash(icrash,ierr) + character*(*) icrash + integer ierr + + print *,icrash + if (ierr .gt. 1) print *,'ierr = ',ierr +#if NO_EXIT + stop +#else + call exit(ierr) +#endif /* NO_EXIT */ + return + end + +!---------------------------------------------------------------------- + + real function fx(x,y) + real x, y +! +#include "bath2.h" + real xlon, ylat + integer i, j +! + if (evenflag) then + xlon=xlonmi+(xlonma-xlonmi)*(x-1.)/(float(ILON)-1.) + ylat=ylatmi+(ylatma-ylatmi)*(y-1.)/(float(ILAT)-1.) + else + i = x + j = y + if (i .eq. ILON) then + xlon = lon(ILON) + else + xlon = lon(i) + (lon(i+1)-lon(i))*(x-i) + ylat = lat(j) + (lat(j+1)-lat(j))*(y-j) + endif + endif + fx=xlon + return + end +!---------------------------------------------------------------------- + real function fy(x,y) + real x, y +! +#include "bath2.h" + real xlon, ylat + integer i, j +! + if (evenflag) then + xlon=xlonmi+(xlonma-xlonmi)*(x-1.)/(float(ILON)-1.) + ylat=ylatmi+(ylatma-ylatmi)*(y-1.)/(float(ILAT)-1.) + else + i = x + j = y + if (j .eq. ILAT) then + ylat = lat(ILAT) + else + xlon = lon(i) + (lon(i+1)-lon(i))*(x-i) + ylat = lat(j) + (lat(j+1)-lat(j))*(y-j) + endif + endif + fy=ylat + return + end +!---------------------------------------------------------------------- + subroutine frstd (x,y) + real x, y + write (58,5901) y,x + 5901 format (2f9.3) + return + end + subroutine vectd (x,y) + real x, y + write (58,5901) y,x + 5901 format (2f9.3) + return + end + subroutine lastd + write (58,5903) + 5903 format (' 999.99 999.99') + return + end +!---------------------------------------------------------------------- + subroutine drline (Z,L,MM,NN) + save + integer L, MM, NN + real Z(L,NN) +! +! THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +! TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +! FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +! X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +! Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +! + integer IX, IY, IDX, IDY, IS, ISS, NP, INX(8), INY(8), & + & IR(50000), NR + real CV + common /conre2/ IX ,IY ,IDX ,IDY , & + & IS ,ISS ,NP ,CV , & + & INX ,INY ,IR ,NR + integer IOFFP + real SPVAL + common /conre1/ IOFFP ,SPVAL + integer IXBITS ,IYBITS + common /conre3/ IXBITS ,IYBITS + logical IPEN ,IPENO + integer IXX, IYY, ishift, M, N, JUMP1, JUMP2, IX0, IY0, & + & IS0, IX2, IY2, ISUB, ISBIG, IX3, IY3, IX4, IY4, & + & IXYPAK + real P1, P2, X, Y, C, fx, fy, XOLD, YOLD +! +! +! STATEMENT FUNCTIONS TO BE REPLACED IF NON-IDENTITY +! TRANSFORMATIONS ARE DESIRED. +! +! fX(X,Y) = X +! fy(X,Y) = Y +! + IXYPAK(IXX,IYY) = ishift(IXX,IYBITS)+IYY + C(P1,P2) = (P1-CV)/(P1-P2) +! + DATA IPEN,IPENO/.TRUE.,.TRUE./ +! + M = MM + N = NN + if (IOFFP .EQ. 0) GO TO 101 + assign 110 to JUMP1 + assign 115 to JUMP2 + go to 102 + 101 assign 112 to JUMP1 + assign 117 to JUMP2 + 102 IX0 = IX + IY0 = IY + IS0 = IS + if (IOFFP .eq. 0) go to 103 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).ne.SPVAL .and. Z(IX2,IY2).ne.SPVAL + IPENO = IPEN + 103 if (IDX .eq. 0) go to 104 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*float(IDX)+float(IX) + GO TO 105 + 104 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*float(IDY)+float(IY) + 105 call frstd (fx(X,Y),fy(X,Y)) + 106 IS = IS+1 + if (IS .gt. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + if (ISS .ne. 0) go to 107 + if (IX2.gt.M .or. IY2.gt.N .or. IX2.lt.1 .or. IY2.lt.1) go to 120 + 107 if (CV-Z(IX2,IY2)) 108,108,109 + 108 IS = IS+4 + IX = IX2 + IY = IY2 + go to 106 + 109 if (IS/2*2 .eq. IS) go to 106 + go to JUMP1,(110,112) + 110 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + if (ISS .ne. 0) go to 111 + if (IX3.gt.M .or. IY3.gt.N .or. IX3.LT.1 .or. IY3.LT.1) go to 120 + if (IX4.gt.M .or. IY4.gt.N .or. IX4.LT.1 .or. IY4.LT.1) go to 120 + 111 IPEN = Z(IX,IY).ne.SPVAL .and. Z(IX2,IY2).ne.SPVAL .and. & + & Z(IX3,IY3).ne.SPVAL .and. Z(IX4,IY4).ne.SPVAL + 112 if (IDX .eq. 0) go to 113 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*float(IDX)+float(IX) + go to 114 + 113 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*float(IDY)+float(IY) + 114 go to JUMP2,(115,117) + 115 if (.not.IPEN) go to 118 + if (IPENO) go to 116 +! +! END OF LINE SEGMENT +! + call lastd + call frstd (fx(XOLD,YOLD),fy(XOLD,YOLD)) +! +! CONTINUE LINE SEGMENT +! + 116 continue + 117 call vectd (fx(X,Y),fy(X,Y)) + 118 XOLD = X + YOLD = Y + if (IS .ne. 1) go to 119 + NP = NP+1 + if (NP .gt. NR) go to 120 + IR(NP) = IXYPAK(IX,IY) + 119 if (ISS .eq. 0) go to 106 + if (IX.ne.IX0 .or. IY.ne.IY0 .or. IS.ne.IS0) go to 106 +! +! END OF LINE +! + 120 call lastd + return + end +!---------------------------------------------------------------------- + subroutine stline (Z,LL,MM,NN,CONV) + save + integer LL, MM, NN + real Z(LL,NN), CONV +! +! THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +! FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +! LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +! THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +! TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +! CONV. +! + integer IX, IY, IDX, IDY, IS, ISS, NP, INX(8), INY(8), & + & IR(50000), NR + real CV + common /conre2/ IX ,IY ,IDX ,IDY , & + & IS ,ISS ,NP ,CV , & + & INX ,INY ,IR ,NR + integer IXBITS ,IYBITS + common /conre3/ IXBITS ,IYBITS + integer IXX, IYY, I, J, K, L, M, N, IP1, JP1, IXY, & + & IXYPAK, LTYPE, ishift, IUNIT, i1mach + real VXA, VXB, VYA, VYB, XA, XB, YA, YB, X, Y +! +! +! +! +! +! + IXYPAK(IXX,IYY) = ishift(IXX,IYBITS)+IYY +! + L = LL + M = MM + N = NN + CV = CONV + NP = 0 + ISS = 0 + do 102 IP1=2,M + I = IP1-1 + if (Z(I,1).ge.CV .or. Z(IP1,1).lt.CV) go to 101 + IX = IP1 + IY = 1 + IDX = -1 + IDY = 0 + IS = 1 + call drline (Z,L,M,N) + 101 if (Z(IP1,N).ge.CV .or. Z(I,N).lt.CV) go to 102 + IX = I + IY = N + IDX = 1 + IDY = 0 + IS = 5 + call drline (Z,L,M,N) + 102 continue + do 104 JP1=2,N + J = JP1-1 + if (Z(M,J).ge.CV .or. Z(M,JP1).lt.CV) go to 103 + IX = M + IY = JP1 + IDX = 0 + IDY = -1 + IS = 7 + call drline (Z,L,M,N) + 103 if (Z(1,JP1).ge.CV .or. Z(1,J).lt.CV) go to 104 + IX = 1 + IY = J + IDX = 0 + IDY = 1 + IS = 3 + call drline (Z,L,M,N) + 104 continue + ISS = 1 + do 108 JP1=3,N + J = JP1-1 + do 107 IP1=2,M + I = IP1-1 + if (Z(I,J).ge.CV .or. Z(IP1,J).lt.CV) go to 107 + IXY = IXYPAK(IP1,J) + if (NP .eq. 0) go to 106 + do 105 K=1,NP + if (IR(K) .eq. IXY) go to 107 + 105 continue + 106 NP = NP+1 + if (NP .gt. NR) then +! +! THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE +! STLINE HAS AN OVERFLOW +! THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR +! UNIT +! + IUNIT = i1mach(4) + write(IUNIT,2000) + 2000 format( & + &' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') + call getset(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) + Y = (YB - YA) / 2. + X = (XB - XA) / 2. + call pwrit(X,Y, & + &'**WARNING--PICTURE INCOMPLETE**', & + & 31,3,0,0) + Y = Y * .7 + call pwrit(X,Y, & + &'WORK ARRAY OVERFLOW IN STLINE', & + & 29,3,0,0) + return + endif + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + call drline (Z,L,M,N) + 107 continue + 108 continue + return + end + blockdata conbd + integer IOFFP + real SPVAL + common /conre1/ IOFFP ,SPVAL + integer IX, IY, IDX, IDY, IS, ISS, NP, INX(8), INY(8), & + & IR(50000), NR + real CV + common /conre2/ IX ,IY ,IDX ,IDY , & + & IS ,ISS ,NP ,CV , & + & INX ,INY ,IR ,NR + integer ISIZEL ,ISIZEM ,ISIZEP ,NREP , & + & NCRT ,ILAB ,NULBLL ,IOFFD , & + & IOFFM ,ISOLID ,NLA ,NLM + real EXT, XLT, YBT, SIDE + common /conre4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , & + & NCRT ,ILAB ,NULBLL ,IOFFD , & + & EXT ,IOFFM ,ISOLID ,NLA , & + & NLM ,XLT ,YBT ,SIDE + integer IRECMJ ,IRECMN ,IRECTX + common /RECINT/ IRECMJ ,IRECMN ,IRECTX + data IOFFP,SPVAL/1,99999./ + data ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ & + & 0 , 0, 0, 16, 40,.05,.05, .9, 1023, 6, 4 / + data EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,2,1,0/ + data INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ & + & -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + data INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ & + & 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + data NR/50000/ + data IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ +! +! REVISION HISTORY--- +! +! JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +! FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +! +! MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +! SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +! DOCUMENTATION CLARIFIED AND CORRECTED. +! +! JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +! +! JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO +! WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN +! BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. +!------------------------------------------------------------------- +! + end + diff --git a/Obsolete/maptst.F b/Obsolete/maptst.F new file mode 100644 index 0000000..a65eb51 --- /dev/null +++ b/Obsolete/maptst.F @@ -0,0 +1,349 @@ + program maptst + +c *** In gridpak version 5.4 ***** October 18, 2001 **************** +c Kate Hedstrom (kate@arsc.edu) +c John Wilkin (wilkin@imcs.rutgers.edu) +c ****************************************************************** +c +c This is a program to convert from the coordinate system in coast.f +c to back to latitude and longitude. If you change the parameters +c in coast.f you have to change them here as well, including HINIT +c and DH. This program writes out the four lat,long grids on unit 62. +c ****************************************************************** + +#include "proj.h" +#include "gridparam.h" + parameter ( REarth = 6.3708e6 ) + character*40 ident + character*80 gridid + + data DTOR / .017453292519943 / + data RTOD / 57.2957795130823 / + + call opngks + +c Initialize the mapping variables + + call pcseti('QUALITY',1) +#include "gridid.h" + write(ident,100) gridid(1:40) + 100 format(40a) + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(0.5,0.98,ident,.012,0.,0.) + call mapsti('GR',JGRD) + call mapstc('OU','PS') + call maproj(JPRJ,PLAT,PLONG,ROTA) + call mapset(JLTS,P1,P2,P3,P4) + call mapdrw + call maptrn(PLAT+.5,PLONG,U2,V2) + call maptrn(PLAT-.5,PLONG,U1,V1) + udeg = sqrt((U2-U1)*(U2-U1) + (V2-V1)*(V2-V1)) + +c Calculate the lat,long of the psi points + + hlat = HINIT + do i=1,100 + print *,'Lat: ' + read *,rmlat + if (rmlat .gt. 90) goto 120 + print *,'Long: ' + read *,rmlon + call maptrn(rmlat,rmlon,u,v) + print *, 'u,v ',u,v + call mapinv(u,v,psilat,psilon,hlat-DH,hlat+DH) + print *, 'lat, long ', psilat, psilon + enddo + 120 continue + call frame + call clsgks + + call exit(0) + 250 call crash('read or write error while outputing solution', 0) + call exit(1) + end + +C---------------------------------------------------------------------- + + subroutine crash(icrash,ierr) + character*(*) icrash + print *,icrash + if (ierr .ne. 0) print *,'ierr = ',ierr + call exit(1) + return + end + +C---------------------------------------------------------------------- + + subroutine fx(A,f,dfdx) + common /MAPKH1/ r + save /MAPKH1/ + + if (A .LE. .0001) then + f = sin(A)/2. - r + dfdx = cos(A)/2. + else + f = (1-cos(A))/sin(A) - r + dfdx = (1-cos(A))/(sin(A)*sin(A)) + end if + return + end + +C---------------------------------------------------------------------- + + subroutine funcd1(lat,f,dfdx) + real lat + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + SAVE /MAPCM1/ + common /MAPKH2/ A,B + save /MAPKH2/ + + f = sin(lat)*coso - sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)))*cos(lat)*sino - cos(B)*sin(A) + dfdx = cos(lat)*coso + sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)))*sin(lat)*sino + & + sin(lat)*sino/sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat))) *(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)) + return + end + +C---------------------------------------------------------------------- + + subroutine funcd2(lat,f,dfdx) + real lat + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + SAVE /MAPCM1/ + common /MAPKH2/ A,B + save /MAPKH2/ + + f = sin(lat)*sino + sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)))*cos(lat)*coso - cos(A) + dfdx = cos(lat)*sino - sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)))*sin(lat)*coso + & - sin(lat)*coso/sqrt(1-(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat))) *(sin(A)*sin(A)*sin(B)*sin(B) + & /cos(lat)/cos(lat)) + return + end + +C---------------------------------------------------------------------- + + subroutine gx(A,f,dfdx) + common /MAPKH1/ r + save /MAPKH1/ + + f = (1+cos(A))/sin(A) - r + dfdx = (1+cos(A))/(sin(A)*sin(A)) + return + end + +C---------------------------------------------------------------------- + + subroutine mapinv (u,v,rlat,rlon,MINLAT,MAXLAT) + real MINLAT,MAXLAT + +c Inverse of MAPTRN. Only works for some map projections - +c IPRJ = 1,2,4,5,6,11. +c IPRJ corresponds to the projections as follows: + +C IPRJ PROJECTION TYPE +c 1 Lambert conformal conic conic +c 2 Stereographic azimuthal +c 3 Orthographic or Satellite-view +c 4 Lambert equal area +c 5 Gnomonic +c 6 Azimuthal equidistant +c 7 Cylindrical equidistant cylindrical +c 8 Mercator +c 9 Mollweide +c 10 Fast-path cylindrical equidistant +c 11 Fast-path Mercator +c 12 Fast-path Mollweide + +C Declare required common blocks. See MAPBD for descriptions of these +C common blocks and the variables in them. + + parameter (pi=3.1415926536) + common /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + save /MAPCM1/ + common /MAPCMB/ IIER + save /MAPCMB/ + common /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + & PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + & ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + logical INTF,LBLF,PRMF,ELPF + save /MAPCM4/ + common /MAPKH1/ r + save /MAPKH1/ + common /MAPKH2/ A,B + save /MAPKH2/ + external fx,gx,funcd1,funcd2 + real lat + +C Define required constants. DTOR is pi over 180, DTRH is half of DTOR +C or pi over 360, and TOPI is 2 over pi. + + data DTOR / .017453292519943 / + data DTRH / .008726646259971 / + data RTOD / 57.2957795130823 / + data TOPI / .636619772367581 / + data PIOT / 1.570796327 / + + if (iprj .eq. 11) then +c Fast-path Mercator. + + print *, 'PHOC ', PHOC, PHIO, PHIA + ph = u + PHIO*DTOR + lat = -PIOT + 2*atan(exp(v)) + + else if (iprj .eq. 1) then +c Lambert Conformal Conic + + tlon = atan(-sino*u/v) + r = sqrt(v*v + u*u) + rlon = RTOD*tlon/coso + chi = 2*RTOD*atan(r**(1/coso)) + rlat = (90-chi)/sino +c Clip to PHOC +- 180 degrees + rlon = rlon-sign(180.,rlon+180.)+sign(180.,180-rlon) + PHOC + return + + else +c Azimuthal projections. + +c Find the radius and angle of the point. + + r = sqrt(u*u + v*v) + B = atan2(u,v) - ROTA*DTOR + + if (iprj .eq. 2) then +C Stereographic. + + if (r .lt. .0001) then + A = asin(2.*r) + else + A = rtsafe(fx,.00001,pi-.00001,.00001) + end if + + else if (iprj .eq. 4) then +C Lambert equal area. + + r = sqrt(4/(r*r) - 1) + A = rtsafe(gx,.0001,pi-.00001,.00001) + if (abs(COS(A)+1.).lt.1.e-6) go to 100 + + else if (iprj .eq. 5) then +C Gnomonic. + + A = atan(R) + + else if (iprj .eq. 6) then +C Azimuthal equidistant. + + A=R + + else +C Projection not allowed + goto 110 + end if + +C rlon is a longitude, in degrees, between -180. and +180., +C inclusive, and rlat is a latitude, in degrees. ph and lat are +C phase (lon) and latitude in radians. + +c Look for North Pole. Change if you need both poles (sorry). + +c if ((abs(B) .le. .0001) .and. abs(SINO - cos(A)) .le .0001) then +c lat = 1./TOPI +c ph = 0. +c else + lat = rtsafe(funcd1,MINLAT*DTOR,MAXLAT*DTOR,.00001) + if (lat .eq. 1.e20) then + lat = rtsafe(funcd2,MINLAT*DTOR,MAXLAT*DTOR,.00001) + if (lat .eq. 1.e20) + & call crash('We have a problem in mapinv', 0) + end if + ph = asin(sin(B)*sin(A)/cos(lat)) +c end if + +c End of Spherical projections + end if + + rlat = RTOD*lat + tmp = RTOD*ph +c Clip to PHOC +- 180 degrees + rlon = tmp - sign(180.,tmp+180.) + sign(180.,180.-tmp) + PHOC + + return + +C Projection of point is invisible or undefined. + + 100 rlat = 90. + rlon = 361. + return + +C Error exit. + + 110 if (IIER.ne.0) go to 100 + IIER=16 + call seter (' mapinv - attempt to use non-existent projection', + & IIER,1) + go to 100 + + end + +C---------------------------------------------------------------------- + + FUNCTION RTSAFE(FUNCD,X1,X2,XACC) + PARAMETER (MAXIT=100) + CALL FUNCD(X1,FL,DF) + CALL FUNCD(X2,FH,DF) +c IF (FL*FH .GE. 0.) PAUSE 'root must be bracketed' + IF (FL*FH .GE. 0.) then +c bogus value - flag that there was a problem + rtsafe = 1.e20 + return + end if + IF (FL .LT. 0.) THEN + XL=X1 + XH=X2 + ELSE + XH=X1 + XL=X2 + SWAP=FL + FL=FH + FH=SWAP + ENDIF + RTSAFE=.5*(X1+X2) + DXOLD=ABS(X2-X1) + DX=DXOLD + CALL FUNCD(RTSAFE,F,DF) + DO 100 J=1,MAXIT + IF(((RTSAFE-XH)*DF-F)*((RTSAFE-XL)*DF-F).GE.0. + & .OR. ABS(2.*F).GT.ABS(DXOLD*DF) ) THEN + DXOLD=DX + DX=0.5*(XH-XL) + RTSAFE=XL+DX + IF(XL.EQ.RTSAFE)RETURN + ELSE + DXOLD=DX + DX=F/DF + TEMP=RTSAFE + RTSAFE=RTSAFE-DX + IF(TEMP.EQ.RTSAFE)RETURN + ENDIF + IF(ABS(DX).LT.XACC) RETURN + CALL FUNCD(RTSAFE,F,DF) + IF(F.LT.0.) THEN + XL=RTSAFE + FL=F + ELSE + XH=RTSAFE + FH=F + ENDIF + 100 CONTINUE + PAUSE 'RTSAFE exceeding maximum iterations' + RETURN + END + +C---------------------------------------------------------------------- diff --git a/USwest/bathy.h b/USwest/bathy.h new file mode 100644 index 0000000..94b8024 --- /dev/null +++ b/USwest/bathy.h @@ -0,0 +1,36 @@ +#include "gridparam.h" + integer Lm, Mm, Lp, Mp, L2d + parameter ( Lm=L-1 , Mm=M-1 , Lp=L+1, Mp=M+1 ) + parameter ( L2d=Lp*Mp ) +! lcflag tells which color bar to use, 1 - 3 (so far). If negative +! then black outlines are drawn over the color contour regions. + integer lcflag + parameter ( lcflag=-5 ) + real x_v(0:L+2,0:M+2), y_v(0:L+2,0:M+2) + common /xxyys/ x_v, y_v + BIGREAL xp(L,M), yp(L,M), xr(0:L,0:M), yr(0:L,0:M), & + & xu(L,0:M), yu(L,0:M), xv(0:L,M), yv(0:L,M), & + & xl, el + real xmin, ymin, xmax, ymax + common /grdpts/ xp, yp, xr, yr, xu, yu, xv, yv, xl, el, & + & xmin, ymin, xmax, ymax + BIGREAL f(0:L,0:M), h(0:L,0:M) + common /parm/ f, h + BIGREAL pm(0:L,0:M), pn(0:L,0:M), & + & dndx(0:L,0:M), dmde(0:L,0:M) + common /pmpn/ pm, pn, dndx, dmde + BIGREAL lat_psi(L,M), lon_psi(L,M), & + & lat_rho(0:L,0:M), lon_rho(0:L,0:M), & + & lat_u(L,0:M), lon_u(L,0:M), & + & lat_v(0:L,M), lon_v(0:L,M) + common /latlon/ lat_psi, lon_psi, lat_rho, lon_rho, & + & lat_u, lon_u, lat_v, lon_v + BIGREAL mask_rho(0:L,0:M), mask_u(L,0:M), & + & mask_v(0:L,M), mask_psi(L,M) + common /rmask/ mask_rho, mask_u, mask_v, mask_psi + BIGREAL angle(0:L,0:M) + common /angles/ angle + integer*2 depthmin, depthmax + common /hmins/ depthmin, depthmax + logical spherical + common /logic/ spherical diff --git a/USwest/grid.h b/USwest/grid.h new file mode 100644 index 0000000..bb02a86 --- /dev/null +++ b/USwest/grid.h @@ -0,0 +1,75 @@ +#include "griddefs.h" +#include "bathy.h" + integer ITMAX, IBIG + parameter ( ITMAX=6, IBIG=400 ) +! ITMAX is the number of iterations to perform +! IBIG is the largest number of points to be read in for one +! boundary. +! +! original distribution of x,y points is preserved on boundary kb1 +! and kb2: + integer kb1, kb2 + parameter ( kb1 = 1, kb2 = 2 ) + + integer L2, M2, L2big, M2big, nwrk + integer N, N1, N2, N3, N4 + parameter ( L2=2*(L-1), M2=2*(M-1) ) + parameter ( L2big=2*Lm, M2big=2*Mm ) + parameter ( N1=M2, N2=M2+L2, N3=M2+L2+M2, & + & N4=M2+L2+M2+L2, N=N4 ) + integer KK + parameter ( KK = 9 ) + parameter ( nwrk = 2*(KK-2)*(2**(KK+1)) + KK + 10*M2big + & + & 12*L2big + 27 ) + BIGREAL sxi(0:L2big), seta(0:M2big) + common / xiej / sxi, seta + BIGREAL x1spl(IBIG),x2spl(IBIG),x3spl(IBIG),x4spl(IBIG), & + & y1spl(IBIG),y2spl(IBIG),y3spl(IBIG),y4spl(IBIG), & + & s1spl(IBIG),s2spl(IBIG),s3spl(IBIG),s4spl(IBIG), & + & b1spl(IBIG),b2spl(IBIG),b3spl(IBIG),b4spl(IBIG), & + & c1spl(IBIG),c2spl(IBIG),c3spl(IBIG),c4spl(IBIG) + integer nb1pts,nb2pts,nb3pts,nb4pts + common / bdata/ x1spl, x2spl, x3spl, x4spl, & + & y1spl, y2spl, y3spl, y4spl, & + & s1spl, s2spl, s3spl, s4spl, & + & b1spl, b2spl, b3spl, b4spl, & + & c1spl, c2spl, c3spl, c4spl, & + & nb1pts, nb2pts, nb3pts, nb4pts +! The boundary values are read from stdin for edges which have +! rbnd true. For boundaries which are read in, the grid spacing +! is proportional to distance along the boundary if even? is true. +! Otherwise, it is proportional to the spacing of the supplied +! boundary points. + logical rbnd1, rbnd2, rbnd3, rbnd4, & + & even1, even2, even3, even4 + parameter ( rbnd1=.true., rbnd2=.true., & + & rbnd3=.true., rbnd4=.true., & + & even1=.true., even2=.true., & + & even3=.true., even4=.true. ) + +! The following are used when you need to fit a boundary with +! bumps on opposite sides and need to make intermediate partial +! grids. Set pleft1 or pbot1 to true to print out the boundaries +! of a partial left or bottom grid. Set pleft2 or pbot2 to true +! to print out the new left or bottom boundary. Lmiddle or Mmiddle +! gives the position of the interior boundary for the intermediate +! grid. The boundaries are written out to iout1 or iout2. +! +! Don't forget to adjust the evenx flags, kb1 and kb2 accordingly. + logical pleft1, pleft2, pbot1, pbot2 + integer Lmiddle, Mmiddle, iout1, iout2 + parameter ( pleft1=.false., pleft2=.false., & + & pbot1=.false., pbot2=.false., & + & Lmiddle=49, Mmiddle=25, & + & iout1=13, iout2=14 ) + +! These variables are used for writing out a subset of the psi points +! to be used in generating a nested domain. + logical subset + integer Lwest, Least, Msouth, Mnorth, iout3 + parameter ( subset = .false., Lwest = 144, Least = 272, & + & Msouth = 160, Mnorth = 248, iout3 = 15 ) + +! xpots unit numbers + integer ipot1, ipot2, ipot3, ipot4 + parameter ( ipot1=41, ipot2=42, ipot3=43, ipot4=44 ) diff --git a/USwest/grid.in b/USwest/grid.in new file mode 100644 index 0000000..daa14a4 --- /dev/null +++ b/USwest/grid.in @@ -0,0 +1,50 @@ +8 + -432031.9 -6541430.3 + -432031.9 -6674953.0 + -425184.6 -6890643.3 + -452573.8 -7120028.3 + -438879.2 -7503477.9 + -312203.9 -7880080.1 + -31464.0 -8242987.7 + 372527.4 -8701757.7 +2 + 372527.4 -8701757.7 + 786789.9 -8345697.4 +34 + 786789.9 -8345697.4 + 749129.7 -8290918.9 + 732011.4 -8239564.0 + 721740.4 -8212174.8 + 673809.2 -8171090.9 + 598488.8 -8119736.1 + 547133.9 -8102617.8 + 499202.7 -8082075.8 + 458118.9 -8078652.2 + 375951.1 -7979366.1 + 307478.0 -7862961.8 + 266394.1 -7791065.0 + 218462.9 -7715744.6 + 184226.3 -7691779.0 + 163684.4 -7647271.4 + 139718.8 -7626729.5 + 115753.2 -7599340.3 + 108905.9 -7575374.7 + 102058.6 -7547985.4 + 105482.2 -7527443.5 + 102058.6 -7513748.8 + 84940.3 -7452123.0 + 78093.0 -7311753.1 + 64398.3 -7256974.6 + 50703.7 -7188501.5 + 47280.1 -7133722.9 + 67822.0 -7058402.5 + 74669.3 -6962540.1 + 81516.6 -6835864.8 + 81516.6 -6777662.7 + 64398.3 -6685223.9 + 43856.4 -6623598.1 + 23314.5 -6585937.9 + 19890.8 -6541430.3 +2 + 19890.8 -6541430.3 + -432031.9 -6541430.3 diff --git a/USwest/griddefs.h b/USwest/griddefs.h new file mode 100644 index 0000000..fbd8553 --- /dev/null +++ b/USwest/griddefs.h @@ -0,0 +1,67 @@ +! define as 1 for ETOPO5 bathymetry +#undef ETOPO5 +! define as 1 for ETOPO2 bathymetry +#undef ETOPO2 +#undef GEBCO + +! for 64-bit output +#define DBLEPREC 1 + +! to draw coastlines on some plots +#define DRAW_COASTS 1 + +! to keep ellipsoidal terms in Earth's shape +#undef ELLIPSOID + +! for averaging bathymetry in gridbox (for EW/NS grids only) +#undef IMG_AVG + +#define KEEP_SHALLOW 1 + +! for NCAR graphics (3.2 or better) */ +#define PLOTS 1 +! for X windows rather than metafile */ +#undef X_WIN + +#undef SYS_POTS /* unimplimented system calls */ +#undef XPOTS1 /* read ipot1 file */ +#undef XPOTS2 /* read ipot2 file */ +#undef XPOTS3 /* read ipot3 file */ +#undef XPOTS4 /* read ipot4 file */ + +#ifdef cray +#undef DCOMPLEX +#define DBLEPREC 1 /* for 64-bit output */ +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#else +#if DBLEPREC +#define DCOMPLEX 1 /* for compilers which support complex*16 */ +#define SMALLREAL real +#define BIGREAL real*8 +#define BIGCOMPLEX complex*16 +#define FLoaT dfloat +#else +#undef DCOMPLEX +#define BIGREAL real +#define SMALLREAL real +#define BIGCOMPLEX complex +#define FLoaT float +#endif /* DBLEPREC */ +#endif /* cray */ + +#if DBLEPREC +#define nf_get_var_FLoaT nf_get_var_double +#define nf_get_vara_FLoaT nf_get_vara_double +#define nf_put_att_FLoaT nf_put_att_double +#define nf_put_var_FLoaT nf_put_var_double +#define nf_put_vara_FLoaT nf_put_vara_double +#else +#define nf_get_var_FLoaT nf_get_var_real +#define nf_get_vara_FLoaT nf_get_vara_real +#define nf_put_att_FLoaT nf_put_att_real +#define nf_put_var_FLoaT nf_put_var_real +#define nf_put_vara_FLoaT nf_put_vara_real +#endif /* DBLEPREC */ diff --git a/USwest/gridid.h b/USwest/gridid.h new file mode 100644 index 0000000..7ca21b7 --- /dev/null +++ b/USwest/gridid.h @@ -0,0 +1,6 @@ +! gridid is an 80 character string, the first 40 of which are +! used as a plot label. +! gridfile is the name of the netCDF file produced by the +! grid/sqgrid programs + gridid = 'West Coast of US #1' + gridfile = 'usw_grid_1.nc' diff --git a/USwest/gridparam.h b/USwest/gridparam.h new file mode 100644 index 0000000..7dd2135 --- /dev/null +++ b/USwest/gridparam.h @@ -0,0 +1,12 @@ + integer L, M + parameter ( L=63 , M=255 ) +! +! mud2 requires that these values satisfy +! +! L = NXL*2**(NSTEP-1)+1 +! M = NYL*2**(NSTEP-1)+1 +! +! where NXL, NYL and NSTEP are integers. Try to have NSTEP as large as +! possible (see mud2 documentation). +! +! subroutine 'factor' now takes care of passing NXL, NYL and NSTEP to mud2. diff --git a/USwest/proj.h b/USwest/proj.h new file mode 100644 index 0000000..cecd80b --- /dev/null +++ b/USwest/proj.h @@ -0,0 +1,9 @@ + character*2 JPRJ, JLTS + real PLAT, PLONG, ROTA, P1, P2, P3, P4, XOFF, YOFF + integer JGRD + parameter ( JPRJ = 'LC', PLAT = 35.500000, & + & PLONG = -125.000000, ROTA = 45.500000, & + & JLTS = 'CO', P1 = 28.000000, & + & P2 = -132.000000, P3 = 50.000000, & + & P4 = -110.000000, JGRD = 5) + parameter ( XOFF = 0., YOFF = 0.) diff --git a/USwest/sandwell-6.2.nc b/USwest/sandwell-6.2.nc new file mode 100644 index 0000000..5eb9114 Binary files /dev/null and b/USwest/sandwell-6.2.nc differ diff --git a/USwest/uswest_1 b/USwest/uswest_1 new file mode 100644 index 0000000..9aaaade --- /dev/null +++ b/USwest/uswest_1 @@ -0,0 +1,39 @@ +#XCOAST 3.0 +450 2 +1 35.500000 -125.000000 45.500000 +28.000000 -135.000000 50.000000 -112.000000 +2 1 0 2 -1 0.000 2 + 5625.000000 1080.000000 3645.000000 1080.000000 +2 1 0 2 -1 0.000 2 + 7170.000000 10545.000000 8985.000000 8985.000000 +3 2 0 2 -1 0.000 8 + 3645.000000 1080.000000 3645.000000 1665.000000 3675.000000 2610.000000 3555.000000 3615.000000 3615.000000 5295.000000 4170.000000 6945.000000 + 5400.000000 8535.000000 7170.000000 10545.000000 + 0.000 0.000 3643.410 1418.775 3643.410 1565.025 3648.420 1880.430 + 3684.435 2393.340 3664.890 2841.930 3564.645 3382.965 3538.980 4000.395 + 3544.680 4908.765 3687.825 5694.975 3976.560 6583.620 4393.365 7362.300 + 5108.070 8181.450 5691.720 8888.280 6134.220 9390.780 0.000 0.000 +3 2 0 2 -1 0.000 34 + 8985.000000 8985.000000 8820.000000 8745.000000 8745.000000 8520.000000 8700.000000 8400.000000 8490.000000 8220.000000 8160.000000 7995.000000 + 7935.000000 7920.000000 7725.000000 7830.000000 7545.000000 7815.000000 7185.000000 7380.000000 6885.000000 6870.000000 6705.000000 6555.000000 + 6495.000000 6225.000000 6345.000000 6120.000000 6255.000000 5925.000000 6150.000000 5835.000000 6045.000000 5715.000000 6015.000000 5610.000000 + 5985.000000 5490.000000 6000.000000 5400.000000 5985.000000 5340.000000 5910.000000 5070.000000 5880.000000 4455.000000 5820.000000 4215.000000 + 5760.000000 3915.000000 5745.000000 3675.000000 5835.000000 3345.000000 5865.000000 2925.000000 5895.000000 2370.000000 5895.000000 2115.000000 + 5820.000000 1710.000000 5730.000000 1440.000000 5640.000000 1275.000000 5625.000000 1080.000000 + 0.000 0.000 8883.960 8850.600 8842.710 8790.600 8795.340 8695.484 + 8763.045 8570.955 8735.250 8492.460 8718.015 8425.740 8661.135 8344.440 + 8540.205 8258.445 8417.490 8164.485 8243.400 8036.340 8110.470 7970.460 + 7985.610 7939.245 7886.250 7901.459 7777.080 7842.960 7683.825 7819.755 + 7588.365 7837.650 7409.445 7744.200 7259.415 7486.125 7107.015 7268.790 + 6952.620 6986.610 6843.540 6798.495 6747.735 6625.815 6658.935 6478.650 + 6559.470 6292.380 6464.820 6193.455 6373.980 6154.680 6310.995 6079.320 + 6286.140 5966.190 6234.945 5898.480 6172.530 5857.305 6124.020 5809.290 + 6063.375 5748.765 6032.415 5691.870 6021.435 5634.045 6007.710 5582.775 + 5986.185 5519.580 5984.130 5468.175 6000.870 5421.825 5999.415 5385.210 + 5988.600 5353.620 5968.710 5278.260 5920.305 5133.960 5887.335 4929.450 + 5900.760 4595.370 5871.660 4398.600 5832.375 4270.020 5804.700 4146.960 + 5769.075 3984.495 5752.860 3860.385 5739.240 3731.265 5753.190 3594.960 + 5821.755 3422.700 5851.305 3249.360 5859.000 3020.745 5872.935 2798.625 + 5891.580 2496.690 5896.575 2311.875 5900.370 2173.440 5886.330 2020.620 + 5843.565 1801.380 5803.710 1646.850 5756.130 1500.015 5712.750 1400.370 + 5652.810 1318.260 5629.995 1241.235 5626.245 1192.485 0.000 0.000 diff --git a/USwest/uswest_1.M b/USwest/uswest_1.M new file mode 100644 index 0000000..3b4e208 --- /dev/null +++ b/USwest/uswest_1.M @@ -0,0 +1,50 @@ +2 + 19890.8 -6541430.3 + -432031.9 -6541430.3 +2 + 372527.4 -8701757.7 + 786789.9 -8345697.4 +8 + -432031.9 -6541430.3 + -432031.9 -6674953.0 + -425184.6 -6890643.3 + -452573.8 -7120028.3 + -438879.2 -7503477.9 + -312203.9 -7880080.1 + -31464.0 -8242987.7 + 372527.4 -8701757.7 +34 + 786789.9 -8345697.4 + 749129.7 -8290918.9 + 732011.4 -8239564.0 + 721740.4 -8212174.8 + 673809.2 -8171090.9 + 598488.8 -8119736.1 + 547133.9 -8102617.8 + 499202.7 -8082075.8 + 458118.9 -8078652.2 + 375951.1 -7979366.1 + 307478.0 -7862961.8 + 266394.1 -7791065.0 + 218462.9 -7715744.6 + 184226.3 -7691779.0 + 163684.4 -7647271.4 + 139718.8 -7626729.5 + 115753.2 -7599340.3 + 108905.9 -7575374.7 + 102058.6 -7547985.4 + 105482.2 -7527443.5 + 102058.6 -7513748.8 + 84940.3 -7452123.0 + 78093.0 -7311753.1 + 64398.3 -7256974.6 + 50703.7 -7188501.5 + 47280.1 -7133722.9 + 67822.0 -7058402.5 + 74669.3 -6962540.1 + 81516.6 -6835864.8 + 81516.6 -6777662.7 + 64398.3 -6685223.9 + 43856.4 -6623598.1 + 23314.5 -6585937.9 + 19890.8 -6541430.3 diff --git a/USwest/uswest_1.proj b/USwest/uswest_1.proj new file mode 100644 index 0000000..6e3b093 --- /dev/null +++ b/USwest/uswest_1.proj @@ -0,0 +1,9 @@ + character*2 JPRJ, JLTS + real PLAT, PLONG, ROTA, P1, P2, P3, P4, XOFF, YOFF + integer JGRD + parameter ( JPRJ = 'LC', PLAT = 35.500000, + & PLONG = -125.000000, ROTA = 45.500000, + & JLTS = 'CO', P1 = 28.000000, + & P2 = -135.000000, P3 = 50.000000, + & P4 = -112.000000, JGRD = 5) + parameter ( XOFF = 0., YOFF = 0.) diff --git a/USwest/uswest_1.uv b/USwest/uswest_1.uv new file mode 100644 index 0000000..02f1441 --- /dev/null +++ b/USwest/uswest_1.uv @@ -0,0 +1,53 @@ +LC +35.500000 -125.000000 45.500000 +28.000000 -135.000000 50.000000 -112.000000 + 0.001620 -0.532733 + -0.035185 -0.532733 +1000. 1000. + 0.030339 -0.708669 + 0.064076 -0.679672 +1000. 1000. + -0.035185 -0.532733 + -0.035185 -0.543607 + -0.034627 -0.561173 + -0.036858 -0.579854 + -0.035742 -0.611082 + -0.025426 -0.641752 + -0.002562 -0.671307 + 0.030339 -0.708669 +1000. 1000. + 0.064076 -0.679672 + 0.061009 -0.675211 + 0.059615 -0.671028 + 0.058778 -0.668798 + 0.054875 -0.665452 + 0.048741 -0.661270 + 0.044558 -0.659876 + 0.040655 -0.658203 + 0.037309 -0.657924 + 0.030617 -0.649838 + 0.025041 -0.640358 + 0.021695 -0.634503 + 0.017792 -0.628369 + 0.015003 -0.626417 + 0.013330 -0.622792 + 0.011379 -0.621119 + 0.009427 -0.618889 + 0.008869 -0.616937 + 0.008312 -0.614706 + 0.008590 -0.613033 + 0.008312 -0.611918 + 0.006918 -0.606899 + 0.006360 -0.595468 + 0.005245 -0.591007 + 0.004129 -0.585430 + 0.003850 -0.580969 + 0.005523 -0.574835 + 0.006081 -0.567028 + 0.006639 -0.556711 + 0.006639 -0.551971 + 0.005245 -0.544443 + 0.003572 -0.539424 + 0.001899 -0.536357 + 0.001620 -0.532733 +1000. 1000. diff --git a/Utility/Module.mk b/Utility/Module.mk new file mode 100644 index 0000000..6dd1060 --- /dev/null +++ b/Utility/Module.mk @@ -0,0 +1,8 @@ +local_sub := Utility + +local_lib := libUTIL.a +local_src := $(wildcard $(local_sub)/*.F) + +$(eval $(call make-library,$(local_lib),$(local_src))) + +$(eval $(compile-rules)) diff --git a/Utility/blktri.F b/Utility/blktri.F new file mode 100644 index 0000000..3269598 --- /dev/null +++ b/Utility/blktri.F @@ -0,0 +1,1556 @@ + + subroutine blktri (iflg,np,n,an,bn,cn,mp,m,am,bm,cm,idimy,y, & + & ierror,w) +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! +! dimension of an(n),bn(n),cn(n),am(m),bm(m),cm(m),y(idimy,n), +! arguments w(see argument list) +! +! latest revision november 1988 +! +! usage call blktri (iflg,np,n,an,bn,cn,mp,m,am,bm, +! cm,idimy,y,ierror,w) +! +! purpose blktri solves a system of linear equations +! of the form +! +! an(j)*x(i,j-1) + am(i)*x(i-1,j) + +! (bn(j)+bm(i))*x(i,j) + cn(j)*x(i,j+1) + +! cm(i)*x(i+1,j) = y(i,j) +! +! for i = 1,2,...,m and j = 1,2,...,n. +! +! i+1 and i-1 are evaluated modulo m and +! j+1 and j-1 modulo n, i.e., +! +! x(i,0) = x(i,n), x(i,n+1) = x(i,1), +! x(0,j) = x(m,j), x(m+1,j) = x(1,j). +! +! these equations usually result from the +! discretization of separable elliptic +! equations. boundary conditions may be +! dirichlet, neumann, or periodic. +! +! arguments +! +! on input iflg +! +! = 0 initialization only. +! certain quantities that depend on np, +! n, an, bn, and cn are computed and +! stored in the work array w. +! +! = 1 the quantities that were computed +! in the initialization are used +! to obtain the solution x(i,j). +! +! note: +! a call with iflg=0 takes +! approximately one half the time +! as a call with iflg = 1. +! however, the initialization does +! not have to be repeated unless np, +! n, an, bn, or cn change. +! +! np +! = 0 if an(1) and cn(n) are not zero, +! which corresponds to periodic +! bounary conditions. +! +! = 1 if an(1) and cn(n) are zero. +! +! n +! the number of unknowns in the j-direction. +! n must be greater than 4. +! the operation count is proportional to +! mnlog2(n), hence n should be selected +! less than or equal to m. +! +! an,bn,cn +! one-dimensional arrays of length n +! that specify the coefficients in the +! linear equations given above. +! +! mp +! = 0 if am(1) and cm(m) are not zero, +! which corresponds to periodic +! boundary conditions. +! +! = 1 if am(1) = cm(m) = 0 . +! +! m +! the number of unknowns in the i-direction. +! m must be greater than 4. +! +! am,bm,cm +! one-dimensional arrays of length m that +! specify the coefficients in the linear +! equations given above. +! +! idimy +! the row (or first) dimension of the +! two-dimensional array y as it appears +! in the program calling blktri. +! this parameter is used to specify the +! variable dimension of y. +! idimy must be at least m. +! +! y +! a two-dimensional array that specifies +! the values of the right side of the linear +! system of equations given above. +! y must be dimensioned at least m*n. +! +! w +! a one-dimensional array that must be +! provided by the user for work space. +! if np=1 define k=int(log2(n))+1 and +! set l=2**(k+1) then w must have dimension +! (k-2)*l+k+5+max(2n,6m) +! +! if np=0 define k=int(log2(n-1))+1 and +! set l=2**(k+1) then w must have dimension +! (k-2)*l+k+5+2n+max(2n,6m) +! +! **important** +! for purposes of checking, the required +! dimension of w is computed by blktri and +! stored in w(1) in floating point format. +! +! arguments +! +! on output y +! contains the solution x. +! +! ierror +! an error flag that indicates invalid +! input parameters. except for number zer0, +! a solution is not attempted. +! +! = 0 no error. +! = 1 m is less than 5 +! = 2 n is less than 5 +! = 3 idimy is less than m. +! = 4 blktri failed while computing results +! that depend on the coefficient arrays +! an, bn, cn. check these arrays. +! = 5 an(j)*cn(j-1) is less than 0 for some j. +! +! possible reasons for this condition are +! 1. the arrays an and cn are not correct +! 2. too large a grid spacing was used +! in the discretization of the elliptic +! equation. +! 3. the linear equations resulted from a +! partial differential equation which +! was not elliptic. +! +! w +! contains intermediate values that must +! not be destroyed if blktri will be called +! again with iflg=1. w(1) contains the +! number of locations required by w in +! floating point format. +! +! +! special conditions the algorithm may fail if abs(bm(i)+bn(j)) +! is less than abs(am(i))+abs(an(j))+ +! abs(cm(i))+abs(cn(j)) +! for some i and j. the algorithm will also +! fail if an(j)*cn(j-1) is less than zero for +! some j. +! see the description of the output parameter +! ierror. +! +! i/o none +! +! precision single +! +! required library comf from fishpak +! files +! +! language fortran +! +! history written by paul swarztrauber at ncar in the +! early 1970's. rewritten and released in +! january, 1980. +! +! algorithm generalized cyclic reduction +! +! portability fortran 77. approximate machine accuracy +! is computed in function epmach. +! +! references swarztrauber,p. and r. sweet, 'efficient +! fortran subprograms for the solution of +! elliptic equations' +! ncar tn/ia-109, july, 1975, 138 pp. +! +! swarztrauber p. n.,a direct method for +! the discrete solution of separable +! elliptic equations, s.i.a.m. +! j. numer. anal.,11(1974) pp. 1136-1150. +!*********************************************************************** +#include "griddefs.h" + integer iflg ,np ,n ,mp , & + & m ,idimy ,ierror + BIGREAL an(*) ,bn(*) ,cn(*) ,am(*) , & + & bm(*) ,cm(*) ,y(idimy,1) ,w(*) + external prod ,prodp ,cprod ,cprodp + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + +! local variables + integer nh ,nl ,iwah ,iw1 , & + & iwbh ,iw2 ,iw3 ,iwd , & + & iww ,iwu +! +! test m and n for the proper form +! + nm = n + ierror = 0 + if (m-5) 101,102,102 + 101 ierror = 1 + go to 119 + 102 if (nm-3) 103,104,104 + 103 ierror = 2 + go to 119 + 104 if (idimy-m) 105,106,106 + 105 ierror = 3 + go to 119 + 106 nh = n + npp = np + if (npp) 107,108,107 + 107 nh = nh+1 + 108 ik = 2 + k = 1 + 109 ik = ik+ik + k = k+1 + if (nh-ik) 110,110,109 + 110 nl = ik + ik = ik+ik + nl = nl-1 + iwah = (k-2)*ik+k+6 + if (npp) 111,112,111 +! +! divide w into working sub arrays +! + 111 iw1 = iwah + iwbh = iw1+nm + w(1) = float(iw1-1+max0(2*nm,6*m)) + go to 113 + 112 iwbh = iwah+nm+nm + iw1 = iwbh + w(1) = float(iw1-1+max0(2*nm,6*m)) + nm = nm-1 +! +! subroutine comp b computes the roots of the b polynomials +! + 113 if (ierror) 119,114,119 + 114 iw2 = iw1+m + iw3 = iw2+m + iwd = iw3+m + iww = iwd+m + iwu = iww+m + if (iflg) 116,115,116 + 115 call compb (nl,ierror,an,bn,cn,w(2),w(iwah),w(iwbh)) + go to 119 + 116 if (mp) 117,118,117 +! +! subroutine blktr1 solves the linear system +! + 117 call blktr1 (nl,an,bn,cn,m,am,bm,cm,idimy,y,w(2),w(iw1),w(iw2), & + & w(iw3),w(iwd),w(iww),w(iwu),prod,cprod) + go to 119 + 118 call blktr1 (nl,an,bn,cn,m,am,bm,cm,idimy,y,w(2),w(iw1),w(iw2), & + & w(iw3),w(iwd),w(iww),w(iwu),prodp,cprodp) + 119 continue + return + end + subroutine blktr1 (n,an,bn,cn,m,am,bm,cm,idimy,y,b,w1,w2,w3,wd, & + & ww,wu,prdct,cprdct) +! +! blktr1 solves the linear system +! +! b contains the roots of all the b polynomials +! w1,w2,w3,wd,ww,wu are all working arrays +! prdct is either prodp or prod depending on whether the boundary +! conditions in the m direction are periodic or not +! cprdct is either cprodp or cprod which are the complex versions +! of prodp and prod. these are called in the event that some +! of the roots of the b sub p polynomial are complex +! +! + integer n ,m ,idimy + BIGREAL an(*) ,bn(*) ,cn(*) ,am(*) , & + & bm(*) ,cm(*) ,b(*) ,w1(*) , & + & w2(*) ,w3(*) ,wd(*) ,ww(*) , & + & wu(*) ,y(idimy,n) + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + integer kdo ,l ,i2 ,ir , & + & im2 ,nm2 ,i1 ,irm1 , & + & im3 ,nm3 ,i3 ,im1 , & + & nm1 ,if ,i ,i4 , & + & idxa ,idxc ,nc ,na , & + & ipi1 ,ipi2 ,ipi3 ,ip1 , & + & ip2 ,ip3 ,np1 ,np2 , & + & np3 ,j ,iz ,nz , & + & izr ,ll ,ifd ,ip , & + & np ,imi1 ,imi2 + BIGREAL dum + external prdct ,cprdct +! +! begin reduction phase +! + kdo = k-1 + do 109 l=1,kdo + ir = l-1 + i2 = 2**ir + i1 = i2/2 + i3 = i2+i1 + i4 = i2+i2 + irm1 = ir-1 + call indxb (i2,ir,im2,nm2) + call indxb (i1,irm1,im3,nm3) + call indxb (i3,irm1,im1,nm1) + call prdct (nm2,b(im2),nm3,b(im3),nm1,b(im1),0,dum,y(1,i2),w3, & + & m,am,bm,cm,wd,ww,wu) + if = 2**k + do 108 i=i4,if,i4 + if (i-nm) 101,101,108 + 101 ipi1 = i+i1 + ipi2 = i+i2 + ipi3 = i+i3 + call indxc (i,ir,idxc,nc) + if (i-if) 102,108,108 + 102 call indxa (i,ir,idxa,na) + call indxb (i-i1,irm1,im1,nm1) + call indxb (ipi2,ir,ip2,np2) + call indxb (ipi1,irm1,ip1,np1) + call indxb (ipi3,irm1,ip3,np3) + call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w3,w1,m,am, & + & bm,cm,wd,ww,wu) + if (ipi2-nm) 105,105,103 + 103 do 104 j=1,m + w3(j) = 0. + w2(j) = 0. + 104 continue + go to 106 + 105 call prdct (np2,b(ip2),np1,b(ip1),np3,b(ip3),0,dum, & + & y(1,ipi2),w3,m,am,bm,cm,wd,ww,wu) + call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w3,w2,m,am, & + & bm,cm,wd,ww,wu) + 106 do 107 j=1,m + y(j,i) = w1(j)+w2(j)+y(j,i) + 107 continue + 108 continue + 109 continue + if (npp) 132,110,132 +! +! the periodic case is treated using the capacitance matrix method +! + 110 if = 2**k + i = if/2 + i1 = i/2 + call indxb (i-i1,k-2,im1,nm1) + call indxb (i+i1,k-2,ip1,np1) + call indxb (i,k-1,iz,nz) + call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,y(1,i),w1,m,am, & + & bm,cm,wd,ww,wu) + izr = i + do 111 j=1,m + w2(j) = w1(j) + 111 continue + do 113 ll=2,k + l = k-ll+1 + ir = l-1 + i2 = 2**ir + i1 = i2/2 + i = i2 + call indxc (i,ir,idxc,nc) + call indxb (i,ir,iz,nz) + call indxb (i-i1,ir-1,im1,nm1) + call indxb (i+i1,ir-1,ip1,np1) + call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w1,w1,m,am,bm, & + & cm,wd,ww,wu) + do 112 j=1,m + w1(j) = y(j,i)+w1(j) + 112 continue + call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w1,w1,m,am, & + & bm,cm,wd,ww,wu) + 113 continue + do 118 ll=2,k + l = k-ll+1 + ir = l-1 + i2 = 2**ir + i1 = i2/2 + i4 = i2+i2 + ifd = if-i2 + do 117 i=i2,ifd,i4 + if (i-i2-izr) 117,114,117 + 114 if (i-nm) 115,115,118 + 115 call indxa (i,ir,idxa,na) + call indxb (i,ir,iz,nz) + call indxb (i-i1,ir-1,im1,nm1) + call indxb (i+i1,ir-1,ip1,np1) + call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w2,w2,m,am, & + & bm,cm,wd,ww,wu) + do 116 j=1,m + w2(j) = y(j,i)+w2(j) + 116 continue + call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w2,w2,m, & + & am,bm,cm,wd,ww,wu) + izr = i + if (i-nm) 117,119,117 + 117 continue + 118 continue + 119 do 120 j=1,m + y(j,nm+1) = y(j,nm+1)-cn(nm+1)*w1(j)-an(nm+1)*w2(j) + 120 continue + call indxb (if/2,k-1,im1,nm1) + call indxb (if,k-1,ip,np) + if (ncmplx) 121,122,121 + 121 call cprdct (nm+1,b(ip),nm1,b(im1),0,dum,0,dum,y(1,nm+1), & + & y(1,nm+1),m,am,bm,cm,w1,w3,ww) + go to 123 + 122 call prdct (nm+1,b(ip),nm1,b(im1),0,dum,0,dum,y(1,nm+1), & + & y(1,nm+1),m,am,bm,cm,wd,ww,wu) + 123 do 124 j=1,m + w1(j) = an(1)*y(j,nm+1) + w2(j) = cn(nm)*y(j,nm+1) + y(j,1) = y(j,1)-w1(j) + y(j,nm) = y(j,nm)-w2(j) + 124 continue + do 126 l=1,kdo + ir = l-1 + i2 = 2**ir + i4 = i2+i2 + i1 = i2/2 + i = i4 + call indxa (i,ir,idxa,na) + call indxb (i-i2,ir,im2,nm2) + call indxb (i-i2-i1,ir-1,im3,nm3) + call indxb (i-i1,ir-1,im1,nm1) + call prdct (nm2,b(im2),nm3,b(im3),nm1,b(im1),0,dum,w1,w1,m,am, & + & bm,cm,wd,ww,wu) + call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w1,w1,m,am,bm, & + & cm,wd,ww,wu) + do 125 j=1,m + y(j,i) = y(j,i)-w1(j) + 125 continue + 126 continue +! + izr = nm + do 131 l=1,kdo + ir = l-1 + i2 = 2**ir + i1 = i2/2 + i3 = i2+i1 + i4 = i2+i2 + irm1 = ir-1 + do 130 i=i4,if,i4 + ipi1 = i+i1 + ipi2 = i+i2 + ipi3 = i+i3 + if (ipi2-izr) 127,128,127 + 127 if (i-izr) 130,131,130 + 128 call indxc (i,ir,idxc,nc) + call indxb (ipi2,ir,ip2,np2) + call indxb (ipi1,irm1,ip1,np1) + call indxb (ipi3,irm1,ip3,np3) + call prdct (np2,b(ip2),np1,b(ip1),np3,b(ip3),0,dum,w2,w2,m, & + & am,bm,cm,wd,ww,wu) + call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w2,w2,m,am, & + & bm,cm,wd,ww,wu) + do 129 j=1,m + y(j,i) = y(j,i)-w2(j) + 129 continue + izr = i + go to 131 + 130 continue + 131 continue +! +! begin back substitution phase +! + 132 do 144 ll=1,k + l = k-ll+1 + ir = l-1 + irm1 = ir-1 + i2 = 2**ir + i1 = i2/2 + i4 = i2+i2 + ifd = if-i2 + do 143 i=i2,ifd,i4 + if (i-nm) 133,133,143 + 133 imi1 = i-i1 + imi2 = i-i2 + ipi1 = i+i1 + ipi2 = i+i2 + call indxa (i,ir,idxa,na) + call indxc (i,ir,idxc,nc) + call indxb (i,ir,iz,nz) + call indxb (imi1,irm1,im1,nm1) + call indxb (ipi1,irm1,ip1,np1) + if (i-i2) 134,134,136 + 134 do 135 j=1,m + w1(j) = 0. + 135 continue + go to 137 + 136 call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),y(1,imi2), & + & w1,m,am,bm,cm,wd,ww,wu) + 137 if (ipi2-nm) 140,140,138 + 138 do 139 j=1,m + w2(j) = 0. + 139 continue + go to 141 + 140 call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),y(1,ipi2), & + & w2,m,am,bm,cm,wd,ww,wu) + 141 do 142 j=1,m + w1(j) = y(j,i)+w1(j)+w2(j) + 142 continue + call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w1,y(1,i), & + & m,am,bm,cm,wd,ww,wu) + 143 continue + 144 continue + return + end + BIGREAL function bsrh (xll,xrr,iz,c,a,bh,f,sgn) + integer iz + BIGREAL a(*) ,c(*) ,bh(*) ,xll , & + & xrr ,f ,sgn + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + BIGREAL xl ,xr ,dx ,x + xl = xll + xr = xrr + dx = .5*abs(xr-xl) + 101 x = .5*(xl+xr) + if (sgn*f(x,iz,c,a,bh)) 103,105,102 + 102 xr = x + go to 104 + 103 xl = x + 104 dx = .5*dx + if (dx-cnv) 105,105,101 + 105 bsrh = .5*(xl+xr) + return + end + subroutine compb (n,ierror,an,bn,cn,b,ah,bh) +! +! compb computes the roots of the b polynomials using subroutine +! tevls which is a modification the eispack program tqlrat. +! ierror is set to 4 if either tevls fails or if a(j+1)*c(j) is +! less than zero for some j. ah,bh are temporary work arrays. +! + integer n ,ierror + BIGREAL an(*) ,bn(*) ,cn(*) ,b(*) , & + & ah(*) ,bh(*) + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + BIGREAL dum ,epmach ,bnorm ,tmp , & + & arg ,d1 ,d2 ,d3 + integer j ,if ,kdo ,l , & + & i2 ,ir ,ipl ,i4 , & + & i ,ifd ,ib ,nb , & + & ls ,js ,jf ,lh , & + & nmp ,l1 ,l2 ,j1 , & + & j2 ,n2m2 + eps = epmach(dum) + bnorm = abs(bn(1)) + do 102 j=2,nm + tmp = abs(bn(j)) + bnorm = max(bnorm,tmp) + arg = an(j)*cn(j-1) + if (arg) 119,101,101 + 101 b(j) = sign(sqrt(arg),an(j)) + 102 continue + cnv = eps*bnorm + if = 2**k + kdo = k-1 + do 108 l=1,kdo + ir = l-1 + i2 = 2**ir + i4 = i2+i2 + ipl = i4-1 + ifd = if-i4 + do 107 i=i4,ifd,i4 + call indxb (i,l,ib,nb) + if (nb) 108,108,103 + 103 js = i-ipl + jf = js+nb-1 + ls = 0 + do 104 j=js,jf + ls = ls+1 + bh(ls) = bn(j) + ah(ls) = b(j) + 104 continue + call tevls (nb,bh,ah,ierror) + if (ierror) 118,105,118 + 105 lh = ib-1 + do 106 j=1,nb + lh = lh+1 + b(lh) = -bh(j) + 106 continue + 107 continue + 108 continue + do 109 j=1,nm + b(j) = -bn(j) + 109 continue + if (npp) 117,110,117 + 110 nmp = nm+1 + nb = nm+nmp + do 112 j=1,nb + l1 = mod(j-1,nmp)+1 + l2 = mod(j+nm-1,nmp)+1 + arg = an(l1)*cn(l2) + if (arg) 119,111,111 + 111 bh(j) = sign(sqrt(arg),-an(l1)) + ah(j) = -bn(l1) + 112 continue + call tevls (nb,ah,bh,ierror) + if (ierror) 118,113,118 + 113 call indxb (if,k-1,j2,lh) + call indxb (if/2,k-1,j1,lh) + j2 = j2+1 + lh = j2 + n2m2 = j2+nm+nm-2 + 114 d1 = abs(b(j1)-b(j2-1)) + d2 = abs(b(j1)-b(j2)) + d3 = abs(b(j1)-b(j2+1)) + if ((d2 .lt. d1) .and. (d2 .lt. d3)) go to 115 + b(lh) = b(j2) + j2 = j2+1 + lh = lh+1 + if (j2-n2m2) 114,114,116 + 115 j2 = j2+1 + j1 = j1+1 + if (j2-n2m2) 114,114,116 + 116 b(lh) = b(n2m2+1) + call indxb (if,k-1,j1,j2) + j2 = j1+nmp+nmp + call ppadd (nm+1,ierror,an,cn,b(j1),b(j1),b(j2)) + 117 return + 118 ierror = 4 + return + 119 ierror = 5 + return + end + subroutine cprod (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,yy,m,a,b,c,d,w,y) +! +! prod applies a sequence of matrix operations to the vector x and +! stores the result in yy (complex case) +! aa array containing scalar multipliers of the vector x +! nd,nm1,nm2 are the lengths of the arrays bd,bm1,bm2 respectively +! bd,bm1,bm2 are arrays containing roots of certian b polynomials +! na is the length of the array aa +! x,yy the matrix operations are applied to x and the result is yy +! a,b,c are arrays which contain the tridiagonal matrix +! m is the order of the matrix +! d,w,y are working arrays +! isgn determines whether or not a change in sign is made +! + integer nd ,nm1 ,nm2 ,na , & + & m + BIGCOMPLEX y(*) ,d(*) ,w(*) ,bd(*) , & + & crt ,den ,y1 ,y2 + BIGREAL a(*) ,b(*) ,c(*) ,x(*) , & + & bm1(*) ,bm2(*) ,aa(*) ,yy(*) + integer j ,mm ,id ,m1 , & + & m2 ,ia ,iflg ,k + BIGREAL rt ,zero + zero = 0. + do 101 j=1,m + y(j) = cmplx(x(j),zero) + 101 continue + mm = m-1 + id = nd + m1 = nm1 + m2 = nm2 + ia = na + 102 iflg = 0 + if (id) 109,109,103 + 103 crt = bd(id) + id = id-1 +! +! begin solution to system +! + d(m) = a(m)/(b(m)-crt) + w(m) = y(m)/(b(m)-crt) + do 104 j=2,mm + k = m-j + den = b(k+1)-crt-c(k+1)*d(k+2) + d(k+1) = a(k+1)/den + w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den + 104 continue + den = b(1)-crt-c(1)*d(2) +#if DBLEPREC + if (cdabs(den)) 105,106,105 +#else + if (cabs(den)) 105,106,105 +#endif /* DBLEPREC */ + 105 y(1) = (y(1)-c(1)*w(2))/den + go to 107 + 106 y(1) = (1.,0.) + 107 do 108 j=2,m + y(j) = w(j)-d(j)*y(j-1) + 108 continue + 109 if (m1) 110,110,112 + 110 if (m2) 121,121,111 + 111 rt = bm2(m2) + m2 = m2-1 + go to 117 + 112 if (m2) 113,113,114 + 113 rt = bm1(m1) + m1 = m1-1 + go to 117 + 114 if (abs(bm1(m1))-abs(bm2(m2))) 116,116,115 + 115 rt = bm1(m1) + m1 = m1-1 + go to 117 + 116 rt = bm2(m2) + m2 = m2-1 + 117 y1 = (b(1)-rt)*y(1)+c(1)*y(2) + if (mm-2) 120,118,118 +! +! matrix multiplication +! + 118 do 119 j=2,mm + y2 = a(j)*y(j-1)+(b(j)-rt)*y(j)+c(j)*y(j+1) + y(j-1) = y1 + y1 = y2 + 119 continue + 120 y(m) = a(m)*y(m-1)+(b(m)-rt)*y(m) + y(m-1) = y1 + iflg = 1 + go to 102 + 121 if (ia) 124,124,122 + 122 rt = aa(ia) + ia = ia-1 + iflg = 1 +! +! scalar multiplication +! + do 123 j=1,m + y(j) = rt*y(j) + 123 continue + 124 if (iflg) 125,125,102 + 125 do 126 j=1,m +#if DBLEPREC + yy(j) = dble(y(j)) +#else + yy(j) = real(y(j)) +#endif /* DBLEPREC */ + 126 continue + return + end + subroutine cprodp (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,yy,m,a,b,c,d,u,y) +! +! prodp applies a sequence of matrix operations to the vector x and +! stores the result in yy periodic boundary conditions +! and complex case +! +! bd,bm1,bm2 are arrays containing roots of certian b polynomials +! nd,nm1,nm2 are the lengths of the arrays bd,bm1,bm2 respectively +! aa array containing scalar multipliers of the vector x +! na is the length of the array aa +! x,yy the matrix operations are applied to x and the result is yy +! a,b,c are arrays which contain the tridiagonal matrix +! m is the order of the matrix +! d,u,y are working arrays +! isgn determines whether or not a change in sign is made +! + integer nd ,nm1 ,nm2 ,na , & + & m + BIGCOMPLEX y(*) ,d(*) ,u(*) ,v , & + & den ,bh ,ym ,am , & + & y1 ,y2 ,yh ,bd(*) , & + & crt + BIGREAL a(*) ,b(*) ,c(*) ,x(*) , & + & bm1(*) ,bm2(*) ,aa(*) ,yy(*) + integer j ,mm ,mm2 ,id , & + & m1 ,m2 ,ia ,iflg + integer k + BIGREAL rt ,zero + zero = 0. + do 101 j=1,m + y(j) = cmplx(x(j),zero) + 101 continue + mm = m-1 + mm2 = m-2 + id = nd + m1 = nm1 + m2 = nm2 + ia = na + 102 iflg = 0 + if (id) 111,111,103 + 103 crt = bd(id) + id = id-1 + iflg = 1 +! +! begin solution to system +! + bh = b(m)-crt + ym = y(m) + den = b(1)-crt + d(1) = c(1)/den + u(1) = a(1)/den + y(1) = y(1)/den +#if DBLEPREC + v = dcmplx(c(m),zero) +#else + v = cmplx(c(m),zero) +#endif /* DBLEPREC */ + if (mm2-2) 106,104,104 + 104 do 105 j=2,mm2 + den = b(j)-crt-a(j)*d(j-1) + d(j) = c(j)/den + u(j) = -a(j)*u(j-1)/den + y(j) = (y(j)-a(j)*y(j-1))/den + bh = bh-v*u(j-1) + ym = ym-v*y(j-1) + v = -v*d(j-1) + 105 continue + 106 den = b(m-1)-crt-a(m-1)*d(m-2) + d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den + y(m-1) = (y(m-1)-a(m-1)*y(m-2))/den + am = a(m)-v*d(m-2) + bh = bh-v*u(m-2) + ym = ym-v*y(m-2) + den = bh-am*d(m-1) +#if DBLEPREC + if (cdabs(den)) 107,108,107 +#else + if (cabs(den)) 107,108,107 +#endif /* DBLEPREC */ + 107 y(m) = (ym-am*y(m-1))/den + go to 109 + 108 y(m) = (1.,0.) + 109 y(m-1) = y(m-1)-d(m-1)*y(m) + do 110 j=2,mm + k = m-j + y(k) = y(k)-d(k)*y(k+1)-u(k)*y(m) + 110 continue + 111 if (m1) 112,112,114 + 112 if (m2) 123,123,113 + 113 rt = bm2(m2) + m2 = m2-1 + go to 119 + 114 if (m2) 115,115,116 + 115 rt = bm1(m1) + m1 = m1-1 + go to 119 + 116 if (abs(bm1(m1))-abs(bm2(m2))) 118,118,117 + 117 rt = bm1(m1) + m1 = m1-1 + go to 119 + 118 rt = bm2(m2) + m2 = m2-1 +! +! matrix multiplication +! + 119 yh = y(1) + y1 = (b(1)-rt)*y(1)+c(1)*y(2)+a(1)*y(m) + if (mm-2) 122,120,120 + 120 do 121 j=2,mm + y2 = a(j)*y(j-1)+(b(j)-rt)*y(j)+c(j)*y(j+1) + y(j-1) = y1 + y1 = y2 + 121 continue + 122 y(m) = a(m)*y(m-1)+(b(m)-rt)*y(m)+c(m)*yh + y(m-1) = y1 + iflg = 1 + go to 102 + 123 if (ia) 126,126,124 + 124 rt = aa(ia) + ia = ia-1 + iflg = 1 +! +! scalar multiplication +! + do 125 j=1,m + y(j) = rt*y(j) + 125 continue + 126 if (iflg) 127,127,102 + 127 do 128 j=1,m +#if DBLEPREC + yy(j) = dble(y(j)) +#else + yy(j) = real(y(j)) +#endif /* DBLEPREC */ + 128 continue + return + end + subroutine indxa (i,ir,idxa,na) + integer i ,ir ,idxa ,na + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + na = 2**ir + idxa = i-na+1 + if (i-nm) 102,102,101 + 101 na = 0 + 102 return + end + subroutine indxb (i,ir,idx,idp) +! +! b(idx) is the location of the first root of the b(i,ir) polynomial +! + integer i ,ir ,idx ,idp + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + integer izh ,ipl ,id + idp = 0 + if (ir) 107,101,103 + 101 if (i-nm) 102,102,107 + 102 idx = i + idp = 1 + return + 103 izh = 2**ir + id = i-izh-izh + idx = id+id+(ir-1)*ik+ir+(ik-i)/izh+4 + ipl = izh-1 + idp = izh+izh-1 + if (i-ipl-nm) 105,105,104 + 104 idp = 0 + return + 105 if (i+ipl-nm) 107,107,106 + 106 idp = nm+ipl-i+1 + 107 return + end + subroutine indxc (i,ir,idxc,nc) + integer i ,ir ,idxc ,nc + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + nc = 2**ir + idxc = i + if (idxc+nc-1-nm) 102,102,101 + 101 nc = 0 + 102 return + end + subroutine ppadd (n,ierror,a,c,cbp,bp,bh) +! +! ppadd computes the eigenvalues of the periodic tridiagonal matrix +! with coefficients an,bn,cn +! +! n is the order of the bh and bp polynomials +! on output bp contians the eigenvalues +! cbp is the same as bp except type complex +! bh is used to temporarily store the roots of the b hat polynomial +! which enters through bp +! + integer n ,ierror + BIGCOMPLEX cf ,cx ,fsg ,hsg , & + & dd ,f ,fp ,fpp , & + & cdis ,r1 ,r2 ,r3 , & + & cbp(*) + BIGREAL a(*) ,c(*) ,bp(*) ,bh(*) + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL eps ,cnv + common /cblkt/ npp ,k ,eps ,cnv , & + & nm ,ncmplx ,ik + external psgf ,ppspf ,ppsgf + BIGREAL scnv ,xl ,db ,psgf , & + & bsrh ,xr ,psg ,xm + integer iz ,j ,nt ,modiz , & + & is ,ig ,if ,it , & + & icv ,i2 ,i3 ,nhalf , & + & izm ,izm2 + BIGREAL sgn ,ppsgf ,zero + zero = 0. + scnv = sqrt(cnv) + iz = n + izm = iz-1 + izm2 = iz-2 + if (bp(n)-bp(1)) 101,142,103 + 101 do 102 j=1,n + nt = n-j + bh(j) = bp(nt+1) + 102 continue + go to 105 + 103 do 104 j=1,n + bh(j) = bp(j) + 104 continue + 105 ncmplx = 0 + modiz = mod(iz,2) + is = 1 + if (modiz) 106,107,106 + 106 if (a(1)) 110,142,107 + 107 xl = bh(1) + db = bh(3)-bh(1) + 108 xl = xl-db + if (psgf(xl,iz,c,a,bh)) 108,108,109 + 109 sgn = -1. + cbp(1) = cmplx(bsrh(xl,bh(1),iz,c,a,bh,psgf,sgn),zero) + is = 2 + 110 if = iz-1 + if (modiz) 111,112,111 + 111 if (a(1)) 112,142,115 + 112 xr = bh(iz) + db = bh(iz)-bh(iz-2) + 113 xr = xr+db + if (psgf(xr,iz,c,a,bh)) 113,114,114 + 114 sgn = 1. + cbp(iz) = cmplx(bsrh(bh(iz),xr,iz,c,a,bh,psgf,sgn),zero) + if = iz-2 + 115 do 136 ig=is,if,2 + xl = bh(ig) + xr = bh(ig+1) + sgn = -1. + xm = bsrh(xl,xr,iz,c,a,bh,ppspf,sgn) + psg = psgf(xm,iz,c,a,bh) + if (abs(psg)-eps) 118,118,116 + 116 if (psg*ppsgf(xm,iz,c,a,bh)) 117,118,119 +! +! case of a real zero +! + 117 sgn = 1. + cbp(ig) = cmplx(bsrh(bh(ig),xm,iz,c,a,bh,psgf,sgn),zero) + sgn = -1. + cbp(ig+1) = cmplx(bsrh(xm,bh(ig+1),iz,c,a,bh,psgf,sgn),zero) + go to 136 +! +! case of a multiple zero +! + 118 cbp(ig) = cmplx(xm,zero) + cbp(ig+1) = cmplx(xm,zero) + go to 136 +! +! case of a complex zero +! + 119 it = 0 + icv = 0 + cx = cmplx(xm,zero) + 120 fsg = (1.,0.) + hsg = (1.,0.) + fp = (0.,0.) + fpp = (0.,0.) + do 121 j=1,iz + dd = 1./(cx-bh(j)) + fsg = fsg*a(j)*dd + hsg = hsg*c(j)*dd + fp = fp+dd + fpp = fpp-dd*dd + 121 continue + if (modiz) 123,122,123 + 122 f = (1.,0.)-fsg-hsg + go to 124 + 123 f = (1.,0.)+fsg+hsg + 124 i3 = 0 +#if DBLEPREC + if (cdabs(fp)) 126,126,125 +#else + if (cabs(fp)) 126,126,125 +#endif /* DBLEPREC */ + 125 i3 = 1 + r3 = -f/fp + 126 i2 = 0 +#if DBLEPREC + if (cdabs(fpp)) 132,132,127 +#else + if (cabs(fpp)) 132,132,127 +#endif /* DBLEPREC */ + 127 i2 = 1 +#if DBLEPREC + cdis = cdsqrt(fp**2-2.*f*fpp) +#else + cdis = csqrt(fp**2-2.*f*fpp) +#endif /* DBLEPREC */ + r1 = cdis-fp + r2 = -fp-cdis +#if DBLEPREC + if (cdabs(r1)-cdabs(r2)) 129,129,128 +#else + if (cabs(r1)-cabs(r2)) 129,129,128 +#endif /* DBLEPREC */ + 128 r1 = r1/fpp + go to 130 + 129 r1 = r2/fpp + 130 r2 = 2.*f/fpp/r1 +#if DBLEPREC + if (cdabs(r2) .lt. cdabs(r1)) r1 = r2 +#else + if (cabs(r2) .lt. cabs(r1)) r1 = r2 +#endif /* DBLEPREC */ + if (i3) 133,133,131 +#if DBLEPREC + 131 if (cdabs(r3) .lt. cdabs(r1)) r1 = r3 +#else + 131 if (cabs(r3) .lt. cabs(r1)) r1 = r3 +#endif /* DBLEPREC */ + go to 133 + 132 r1 = r3 + 133 cx = cx+r1 + it = it+1 + if (it .gt. 50) go to 142 +#if DBLEPREC + if (cdabs(r1) .gt. scnv) go to 120 +#else + if (cabs(r1) .gt. scnv) go to 120 +#endif /* DBLEPREC */ + if (icv) 134,134,135 + 134 icv = 1 + go to 120 + 135 cbp(ig) = cx + cbp(ig+1) = conjg(cx) + 136 continue +#if DBLEPREC + if (cdabs(cbp(n))-cdabs(cbp(1))) 137,142,139 +#else + if (cabs(cbp(n))-cabs(cbp(1))) 137,142,139 +#endif /* DBLEPREC */ + 137 nhalf = n/2 + do 138 j=1,nhalf + nt = n-j + cx = cbp(j) + cbp(j) = cbp(nt+1) + cbp(nt+1) = cx + 138 continue + 139 ncmplx = 1 + do 140 j=2,iz +#if DBLEPREC + if (dimag(cbp(j))) 143,140,143 +#else + if (aimag(cbp(j))) 143,140,143 +#endif /* DBLEPREC */ + 140 continue + ncmplx = 0 + do 141 j=2,iz +#if DBLEPREC + bp(j) = dble(cbp(j)) +#else + bp(j) = real(cbp(j)) +#endif /* DBLEPREC */ + 141 continue + go to 143 + 142 ierror = 4 + 143 continue + return + end + subroutine prod (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,y,m,a,b,c,d,w,u) +! +! prod applies a sequence of matrix operations to the vector x and +! stores the result in y +! bd,bm1,bm2 are arrays containing roots of certian b polynomials +! nd,nm1,nm2 are the lengths of the arrays bd,bm1,bm2 respectively +! aa array containing scalar multipliers of the vector x +! na is the length of the array aa +! x,y the matrix operations are applied to x and the result is y +! a,b,c are arrays which contain the tridiagonal matrix +! m is the order of the matrix +! d,w,u are working arrays +! is determines whether or not a change in sign is made +! + integer nd ,nm1 ,nm2 ,na , & + & m + BIGREAL a(*) ,b(*) ,c(*) ,x(*) , & + & y(*) ,d(*) ,w(*) ,bd(*) , & + & bm1(*) ,bm2(*) ,aa(*) ,u(*) + integer j ,mm ,id ,ibr , & + & m1 ,m2 ,ia ,k + BIGREAL rt ,den + do 101 j=1,m + w(j) = x(j) + y(j) = w(j) + 101 continue + mm = m-1 + id = nd + ibr = 0 + m1 = nm1 + m2 = nm2 + ia = na + 102 if (ia) 105,105,103 + 103 rt = aa(ia) + if (nd .eq. 0) rt = -rt + ia = ia-1 +! +! scalar multiplication +! + do 104 j=1,m + y(j) = rt*w(j) + 104 continue + 105 if (id) 125,125,106 + 106 rt = bd(id) + id = id-1 + if (id .eq. 0) ibr = 1 +! +! begin solution to system +! + d(m) = a(m)/(b(m)-rt) + w(m) = y(m)/(b(m)-rt) + do 107 j=2,mm + k = m-j + den = b(k+1)-rt-c(k+1)*d(k+2) + d(k+1) = a(k+1)/den + w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den + 107 continue + den = b(1)-rt-c(1)*d(2) + w(1) = 1. + if (den) 108,109,108 + 108 w(1) = (y(1)-c(1)*w(2))/den + 109 do 110 j=2,m + w(j) = w(j)-d(j)*w(j-1) + 110 continue + if (na) 113,113,102 + 111 do 112 j=1,m + y(j) = w(j) + 112 continue + ibr = 1 + go to 102 + 113 if (m1) 114,114,115 + 114 if (m2) 111,111,120 + 115 if (m2) 117,117,116 + 116 if (abs(bm1(m1))-abs(bm2(m2))) 120,120,117 + 117 if (ibr) 118,118,119 + 118 if (abs(bm1(m1)-bd(id))-abs(bm1(m1)-rt)) 111,119,119 + 119 rt = rt-bm1(m1) + m1 = m1-1 + go to 123 + 120 if (ibr) 121,121,122 + 121 if (abs(bm2(m2)-bd(id))-abs(bm2(m2)-rt)) 111,122,122 + 122 rt = rt-bm2(m2) + m2 = m2-1 + 123 do 124 j=1,m + y(j) = y(j)+rt*w(j) + 124 continue + go to 102 + 125 return + end + subroutine prodp (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,y,m,a,b,c,d,u,w) +! +! prodp applies a sequence of matrix operations to the vector x and +! stores the result in y periodic boundary conditions +! +! bd,bm1,bm2 are arrays containing roots of certian b polynomials +! nd,nm1,nm2 are the lengths of the arrays bd,bm1,bm2 respectively +! aa array containing scalar multipliers of the vector x +! na is the length of the array aa +! x,y the matrix operations are applied to x and the result is y +! a,b,c are arrays which contain the tridiagonal matrix +! m is the order of the matrix +! d,u,w are working arrays +! is determines whether or not a change in sign is made +! + integer nd ,nm1 ,nm2 ,na , & + & m + BIGREAL a(*) ,b(*) ,c(*) ,x(*) , & + & y(*) ,d(*) ,u(*) ,bd(*) , & + & bm1(*) ,bm2(*) ,aa(*) ,w(*) + integer j ,mm ,mm2 ,id , & + & ibr ,m1 ,m2 ,ia , & + & k + BIGREAL rt ,ym ,den ,v , & + & bh ,am + do 101 j=1,m + y(j) = x(j) + w(j) = y(j) + 101 continue + mm = m-1 + mm2 = m-2 + id = nd + ibr = 0 + m1 = nm1 + m2 = nm2 + ia = na + 102 if (ia) 105,105,103 + 103 rt = aa(ia) + if (nd .eq. 0) rt = -rt + ia = ia-1 + do 104 j=1,m + y(j) = rt*w(j) + 104 continue + 105 if (id) 128,128,106 + 106 rt = bd(id) + id = id-1 + if (id .eq. 0) ibr = 1 +! +! begin solution to system +! + bh = b(m)-rt + ym = y(m) + den = b(1)-rt + d(1) = c(1)/den + u(1) = a(1)/den + w(1) = y(1)/den + v = c(m) + if (mm2-2) 109,107,107 + 107 do 108 j=2,mm2 + den = b(j)-rt-a(j)*d(j-1) + d(j) = c(j)/den + u(j) = -a(j)*u(j-1)/den + w(j) = (y(j)-a(j)*w(j-1))/den + bh = bh-v*u(j-1) + ym = ym-v*w(j-1) + v = -v*d(j-1) + 108 continue + 109 den = b(m-1)-rt-a(m-1)*d(m-2) + d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den + w(m-1) = (y(m-1)-a(m-1)*w(m-2))/den + am = a(m)-v*d(m-2) + bh = bh-v*u(m-2) + ym = ym-v*w(m-2) + den = bh-am*d(m-1) + if (den) 110,111,110 + 110 w(m) = (ym-am*w(m-1))/den + go to 112 + 111 w(m) = 1. + 112 w(m-1) = w(m-1)-d(m-1)*w(m) + do 113 j=2,mm + k = m-j + w(k) = w(k)-d(k)*w(k+1)-u(k)*w(m) + 113 continue + if (na) 116,116,102 + 114 do 115 j=1,m + y(j) = w(j) + 115 continue + ibr = 1 + go to 102 + 116 if (m1) 117,117,118 + 117 if (m2) 114,114,123 + 118 if (m2) 120,120,119 + 119 if (abs(bm1(m1))-abs(bm2(m2))) 123,123,120 + 120 if (ibr) 121,121,122 + 121 if (abs(bm1(m1)-bd(id))-abs(bm1(m1)-rt)) 114,122,122 + 122 rt = rt-bm1(m1) + m1 = m1-1 + go to 126 + 123 if (ibr) 124,124,125 + 124 if (abs(bm2(m2)-bd(id))-abs(bm2(m2)-rt)) 114,125,125 + 125 rt = rt-bm2(m2) + m2 = m2-1 + 126 do 127 j=1,m + y(j) = y(j)+rt*w(j) + 127 continue + go to 102 + 128 return + end + subroutine tevls (n,d,e2,ierr) +! + integer i ,j ,l ,m , & + & n ,ii ,l1 ,mml , & + & ierr + BIGREAL d(n) ,e2(n) + BIGREAL b ,c ,f ,g , & + & h ,p ,r ,s +! +! real sqrt,abs,sign +! + integer npp ,k ,nm ,ncmplx , & + & ik + BIGREAL machep ,cnv + common /cblkt/ npp ,k ,machep ,cnv , & + & nm ,ncmplx ,ik + integer nhalf ,ntop + BIGREAL dhold +! +! this subroutine is a modification of the eispack subroutine tqlrat +! algorithm 464, comm. acm 16, 689(1973) by reinsch. +! +! this subroutine finds the eigenvalues of a symmetric +! tridiagonal matrix by the rational ql method. +! +! on input- +! +! n is the order of the matrix, +! +! d contains the diagonal elements of the input matrix, +! +! e2 contains the subdiagonal elements of the +! input matrix in its last n-1 positions. e2(1) is arbitrary. +! +! on output- +! +! d contains the eigenvalues in ascending order. if an +! error exit is made, the eigenvalues are correct and +! ordered for indices 1,2,...ierr-1, but may not be +! the smallest eigenvalues, +! +! e2 has been destroyed, +! +! ierr is set to +! zero for normal return, +! j if the j-th eigenvalue has not been +! determined after 30 iterations. +! +! questions and comments should be directed to b. s. garbow, +! applied mathematics division, argonne national laboratory +! +! +! ********** machep is a machine dependent parameter specifying +! the relative precision of floating point arithmetic. +! +! ********** +! + ierr = 0 + if (n .eq. 1) go to 115 +! + do 101 i=2,n + e2(i-1) = e2(i)*e2(i) + 101 continue +! + f = 0.0 + b = 0.0 + e2(n) = 0.0 +! + do 112 l=1,n + j = 0 + h = machep*(abs(d(l))+sqrt(e2(l))) + if (b .gt. h) go to 102 + b = h + c = b*b +! +! ********** look for small squared sub-diagonal element ********** +! + 102 do 103 m=l,n + if (e2(m) .le. c) go to 104 +! +! ********** e2(n) is always zero, so there is no exit +! through the bottom of the loop ********** +! + 103 continue +! + 104 if (m .eq. l) go to 108 + 105 if (j .eq. 30) go to 114 + j = j+1 +! +! ********** form shift ********** +! + l1 = l+1 + s = sqrt(e2(l)) + g = d(l) + p = (d(l1)-g)/(2.0*s) + r = sqrt(p*p+1.0) + d(l) = s/(p+sign(r,p)) + h = g-d(l) +! + do 106 i=l1,n + d(i) = d(i)-h + 106 continue +! + f = f+h +! +! ********** rational ql transformation ********** +! + g = d(m) + if (g .eq. 0.0) g = b + h = g + s = 0.0 + mml = m-l +! +! ********** for i=m-1 step -1 until l do -- ********** +! + do 107 ii=1,mml + i = m-ii + p = g*h + r = p+e2(i) + e2(i+1) = s*r + s = e2(i)/r + d(i+1) = h+s*(h+d(i)) + g = d(i)-e2(i)/g + if (g .eq. 0.0) g = b + h = g*p/r + 107 continue +! + e2(l) = s*g + d(l) = h +! +! ********** guard against underflowed h ********** +! + if (h .eq. 0.0) go to 108 + if (abs(e2(l)) .le. abs(c/h)) go to 108 + e2(l) = h*e2(l) + if (e2(l) .ne. 0.0) go to 105 + 108 p = d(l)+f +! +! ********** order eigenvalues ********** +! + if (l .eq. 1) go to 110 +! +! ********** for i=l step -1 until 2 do -- ********** +! + do 109 ii=2,l + i = l+2-ii + if (p .ge. d(i-1)) go to 111 + d(i) = d(i-1) + 109 continue +! + 110 i = 1 + 111 d(i) = p + 112 continue +! + if (abs(d(n)) .ge. abs(d(1))) go to 115 + nhalf = n/2 + do 113 i=1,nhalf + ntop = n-i + dhold = d(i) + d(i) = d(ntop+1) + d(ntop+1) = dhold + 113 continue + go to 115 +! +! ********** set error -- no convergence to an +! eigenvalue after 30 iterations ********** +! + 114 ierr = l + 115 return +! +! ********** last card of tqlrat ********** +! +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +!----------------------------------------------------------------------- + end diff --git a/Utility/checkdefs.F b/Utility/checkdefs.F new file mode 100644 index 0000000..6201a38 --- /dev/null +++ b/Utility/checkdefs.F @@ -0,0 +1,105 @@ + + subroutine checkdefs +#include "grid.h" +#include "ncgrid.h" + + integer is + + CPPoptions=' ' + write(stdout,10) + 10 format(/,' Activated C-preprocessing Options:',/) + 20 format(2x,a,t20,a) + +#if DCOMPLEX + write(stdout,20) 'DCOMPLEX', & + & 'Double complex' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+10)=' DCOMPLEX,' +#endif /* DCOMPLEX */ +#if DBLEPREC + write(stdout,20) 'DBLEPREC', & + & 'Double precision' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+10)=' DBLEPREC,' +#endif /* DBLEPREC */ +#if ELLIPSOID + write(stdout,20) 'ELLIPSOID', & + & 'Distances computed with ellipsoidal terms' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+11)=' ELLIPSOID,' +#endif /* ELLIPSOID */ +#if ETOPO5 + write(stdout,20) 'ETOPO5', & + & 'ETOPO5 bathymetry' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' ETOPO5,' +#endif /* ETOPO5 */ +#if ETOPO2 + write(stdout,20) 'ETOPO2', & + & 'ETOPO2 bathymetry' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' ETOPO2,' +#endif /* ETOPO2 */ +#if DRAW_COASTS + write(stdout,20) 'DRAW_COASTS', & + & 'Draw the coastlines on some plots' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+13)=' DRAW_COASTS,' +#endif /* DRAW_COASTS */ +#if IMG_AVG + write(stdout,20) 'IMG_AVG', & + & 'Average bathymetry within a gridbox' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+9)=' IMG_AVG,' +#endif /* IMG_AVG */ +#if KEEP_SHALLOW + write(stdout,20) 'KEEP_SHALLOW', & + & 'Keep shallow areas shallow' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+14)=' KEEP_SHALLOW,' +#endif /* KEEP_SHALLOW */ +#if PLOTS + write(stdout,20) 'PLOTS', & + & 'Write out NCAR graphics plots' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+7)=' PLOTS,' +#endif /* PLOTS */ +#if SYS_POTS + write(stdout,20) 'SYS_POTS', & + & 'System call to run xpots (not working)' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+10)=' SYS_POTS,' +#endif /* SYS_POTS */ +#if X_WIN + write(stdout,20) 'X_WIN', & + & 'X windows instead of a metafile' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+7)=' X_WIN,' +#endif /* X_WIN */ +#if XPOTS1 + write(stdout,20) 'XPOTS1', & + & 'Read xpots file number 1' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' XPOTS1,' +#endif /* XPOTS1 */ +#if XPOTS2 + write(stdout,20) 'XPOTS2', & + & 'Read xpots file number 2' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' XPOTS2,' +#endif /* XPOTS2 */ +#if XPOTS3 + write(stdout,20) 'XPOTS3', & + & 'Read xpots file number 3' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' XPOTS3,' +#endif /* XPOTS3 */ +#if XPOTS4 + write(stdout,20) 'XPOTS4', & + & 'Read xpots file number 4' + is=LEN_TRIM(CPPoptions)+1 + CPPoptions(is:is+8)=' XPOTS4,' +#endif /* XPOTS4 */ + + return + end diff --git a/Utility/comf.F b/Utility/comf.F new file mode 100644 index 0000000..cda6d18 --- /dev/null +++ b/Utility/comf.F @@ -0,0 +1,206 @@ +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! package comf the entries in this package are lowlevel +! entries, supporting fishpak entries blktri +! and cblktri. that is, these routines are +! not called directly by users, but rather +! by entries within blktri and cblktri. +! description of entries epmach and pimach +! follow below. +! +! latest revision november 1988 +! +! special conditions none +! +! i/o none +! +! precision single +! +! required library none +! files +! +! language fortran +! ******************************************************************** +! +! function epmach (dum) +! +! purpose to compute an approximate machine accuracy +! epsilon according to the following definition: +! epsilon is the smallest number such that +! (1.+epsilon).gt.1.) +! +! usage eps = epmach (dum) +! +! arguments +! on input dum +! dummy value +! +! arguments +! on output none +! +! history the original version, written when the +! blktri package was converted from the +! cdc 7600 to run on the cray-1, calculated +! machine accuracy by successive divisions +! by 10. use of this constant caused blktri +! to compute solutions on the cray-1 with four +! fewer places of accuracy than the version +! on the 7600. it was found that computing +! machine accuracy by successive divisions +! of 2 produced a machine accuracy 29% less +! than the value generated by successive +! divisions by 10, and that use of this +! machine constant in the blktri package +! recovered the accuracy that appeared to +! be lost on conversion. +! +! algorithm computes machine accuracy by successive +! divisions of two. +! +! portability this code will execute on machines other +! than the cray1, but the returned value may +! be unsatisfactory. see history above. +! ******************************************************************** +! +! function pimach (dum) +! +! purpose to supply the value of the constant pi +! correct to machine precision where +! pi=3.141592653589793238462643383279502884197 +! 1693993751058209749446 +! +! usage pi = pimach (dum) +! +! arguments +! on input dum +! dummy value +! +! arguments +! on output none +! +! algorithm the value of pi is set to 4.*atan(1.0) +! +! portability this entry is portable, but users should +! check to see whether greater accuracy is +! required. +! +!*********************************************************************** +#include "griddefs.h" + + BIGREAL function epmach (dum) + BIGREAL dum + + BIGREAL v + common /value/ v + BIGREAL eps + eps = 1. + 101 eps = eps/2. + call strwrd (eps+1.) + if (v-1.) 102,102,101 + 102 epmach = 100.*eps + return + end + + subroutine strwrd (x) + BIGREAL x + BIGREAL v + common /value/ v + v = x + return + end + + BIGREAL function pimach (dum) + BIGREAL dum +! pi=3.1415926535897932384626433832795028841971693993751058209749446 +! +#if DBLEPREC + pimach = 4.d0*datan(1.0d0) +#else + pimach = 4.*atan(1.0) +#endif /* dbleprec */ + return + end + + BIGREAL function ppsgf (x,iz,c,a,bh) + integer iz + BIGREAL x, a(*) ,c(*) ,bh(*) + BIGREAL sum + integer j + sum = 0. + do 101 j=1,iz + sum = sum-1./(x-bh(j))**2 + 101 continue + ppsgf = sum + return + end + + BIGREAL function ppspf (x,iz,c,a,bh) + integer iz + BIGREAL x, a(*) ,c(*) ,bh(*) + BIGREAL sum + integer j + sum = 0. + do 101 j=1,iz + sum = sum+1./(x-bh(j)) + 101 continue + ppspf = sum + return + end + + BIGREAL function psgf (x,iz,c,a,bh) + integer iz + BIGREAL x, a(*) ,c(*) ,bh(*) + BIGREAL fsg, hsg, dd + integer j + fsg = 1. + hsg = 1. + do 101 j=1,iz + dd = 1./(x-bh(j)) + fsg = fsg*a(j)*dd + hsg = hsg*c(j)*dd + 101 continue + if (mod(iz,2)) 103,102,103 + 102 psgf = 1.-fsg-hsg + return + 103 psgf = 1.+fsg+hsg + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +! june 1993 BIGREAL stuff added +!----------------------------------------------------------------------- + end + diff --git a/Utility/cpsfill.F b/Utility/cpsfill.F new file mode 100644 index 0000000..0828ad2 --- /dev/null +++ b/Utility/cpsfill.F @@ -0,0 +1,514 @@ +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! +! emulate our old modified conrec - with some hints from cpcnrc +! +! modification: John Wilkin, 16 December, 1991 +! Enabled hardwiring of contour levels for use with plothist +! ******************************************************************* + + subroutine cpshift(zdat,K,M,N,finc,shift,scalel) + logical shift + integer K, M, N +#include "griddefs.h" + real zdat(K,*), finc, scalel + +! dimensions of work arrays + integer lrwk, liwk, lama + parameter ( lrwk=5000, liwk=2000, lama=12000 ) + integer iwrk(liwk), iama(lama) + real rwrk(lrwk), ciu, clev, spval + +! Declare the contour-line drawing routine + external cpdrpl + + logical colour, tallflg, mapflag + integer lcflag, ncontr + common / cpflg / colour, tallflg, lcflag, ncontr, mapflag + integer i, ncl, iclu, llpf + +! Extra parameters if we decide to hardwire the contour levels + real cpmin, cpmax, clevel + integer nclevels + common / cfix / cpmin, cpmax, nclevels + +! if colour is true we actually want colour fill plots so +! divert to cpsfill + + if (colour) then + call cpsfill(zdat,K,M,N,ncontr,lcflag,tallflg,.false.) + return + endif + + spval = 1.e+20 + +! turn on drawing of thick edge of plot + call cpseti('PAI - array index',-1) + call cpseti('CLU - contour level use',1) + call cpsetr('CLL - contour line width',2.) + +! turn on drawing of thick edge of special values + call cpseti('PAI - array index',-2) + call cpseti('CLU - contour level use',1) + call cpsetr('CLL - contour line width',2.) + +! arrange for selection of contour levels + + if (nclevels .eq. 0) then + +! default scheme -- cpshift follows contour level selection hints +! from input argument list + + if (finc .lt. 0.) then + call cpseti('CLS - contour level selector',max(1,int(-finc))) + call cpsetr('CIS - contour interval selector',0.) + else if (finc .eq. 0.) then + call cpseti('CLS - contour level selector',16) + call cpsetr('CIS - contour interval selector',0.) + else + call cpseti('CLS - contour level selector',1) + call cpsetr('CIS - contour interval selector',finc) + end if + + else + +! override selection hints +! cpmin, cpmax and nclevels are input to plothist + + call cpseti('CLS - contour level selector',0) + call cpseti('NCL - number of contour levels',nclevels+1) + do i=1,nclevels+1 + clevel = cpmin + float(i-1)/float(nclevels)*(cpmax-cpmin) + call cpseti('PAI - array index',i) + call cpsetr('CLV - contour level',clevel) + call cpseti('CLU - line type',3) + enddo + + endif + + +! we will call set + call cpseti('SET',0) + +! don't label highs and lows + call cpsetc('HLT - high/low label',' ') + +! initialize CONPACK + call cprect(zdat,K,M,N,rwrk,lrwk,iwrk,liwk) + call cppkcl(zdat,rwrk,iwrk) + +! go through the contours, set dash patterns, and shift if desired + call cpgetr('CIU - contour interval used',ciu) + call cpgeti('NCL - number of contour levels',ncl) + + do 100 i=1,ncl + call cpseti('PAI - array index',i) + call cpgeti('CLU - contour level use flag',iclu) + call cpgetr('CLV - contour level',clev) + if (shift) then + clev = clev + .5*ciu + end if + call cpsetr('CLV - contour level',clev) + if (clev .lt. 0.) then + if (scalel .gt. 1.5) then + call cpseti('CLD - contour line dash pattern',13107) + else + call cpseti('CLD - contour line dash pattern',21845) + end if + else + call cpseti('CLD - contour line dash pattern',65535) + end if + call cpseti('CLU - contour level use flag',iclu) + 100 continue + call cpsetr('CIU - contour interval used',ciu) + call cpsetr('ILS - information label size',.012*scalel) + + call cpseti('LLP',1) + call cpgeti('LLP - line label positioning flag',llpf) + +! draw the contour lines, masking them if necessary. + if (llpf.le.1) then + call cpcldr (zdat,rwrk,iwrk) + else + call arinam (iama,lama) + call cplbam (zdat,rwrk,iwrk,iama) + call cpcldm (zdat,rwrk,iwrk,iama,cpdrpl) + end if + +! draw labels + call gsclip(0) + call cplbdr(zdat,rwrk,iwrk) + call gsclip(1) + + return + end + +! ******************************************************************* + + subroutine cpsfill(zdat,K,M,N,ncontr,lcflag,tallflg,fixflag) + +! John Wilkin (wilkin@flood.ml.csiro.au) +! Kate Hedstrom (kate@ahab.rutgers.edu) +! Produces colour fill plots + +! abs(lcflag) determines which colour bar to use +! If lcflag < 0 solid contour lines are overplotted on the colours + +! This version is presently set-up to request 'ncontr' contour levels +! splitting the range into 'ncontr+1' equal bands + +! tallflg added for vertical label bars + +! PROBLEMS: +! Since conpack can end up selecting more than ncontr contours (see the +! documentation on conpack parameter CLS) problems can arise +! when more levels are selected than entries defined in the colour table +! In this event a warning is printed that cpsfill ran out of colours + +! To add more colours increase ncolor in cpsfill, defclr and colram, +! and add more rgb colour triplets to the data statements in defclr. +! Don't get caught by the fortran limit on 19 continuations! + +! ********************************************************************** + + integer K, M, N, ncontr, lcflag + real zdat(K,*) + logical tallflg, fixflag + +! dimensions of work arrays + integer lrwk, liwk, lawk, nlevb, lcra + parameter ( lrwk=100000, liwk=100000, lawk=2000000, nlevb=30, & + & lcra=100000 ) + integer iwrk(liwk), iama(lawk), iara(12), igra(nlevb) + real rwrk(lrwk), xcra(lcra), ycra(lcra) + integer iasf(13) + + integer ncolor + parameter ( ncolor=17 ) + real cdepth(ncolor) + real ciu, clev, spval + real fl, fr, fb, ft, ul, ur, ub, ut + integer i, ncl, ncused, iclu, ll + external colram + +! labels and indicies for labelbar + character*9 llbs(ncolor-1) + integer lfin(ncolor) + +! Extra parameters if we decide to hardwire the contour levels + real cpmin, cpmax, clevel + integer nclevels + common / cfix / cpmin, cpmax, nclevels + + data iasf / 13*1 / + data cdepth / 20, 30, 40, 50, 60, 100, 200, 400, 600, 800, & + & 1000, 1500, 2000, 2500, 3000, 4000, 5000 / +! data cdepth / 19, 50, 75, 100, 150, 200, 400, 600, 800, +! & 1000, 1500, 2000, 2500, 3000, 3500, 4000, 4500 / + + spval = 1.e+20 + +! we will call set + call cpseti('SET',0) + +! set all aspect source flags to "individual" + call gsasf(iasf) + +! force solid fill + call gsfais(1) + +! define colour indicies + call defclr(lcflag) + +! define the list of indicies required by the labelbar routine + do i=1,ncolor + lfin(i)=i+1 + end do + +! don't label highs and lows or lines + call cpsetc('HLT - high/low label',' ') + call cpseti('LLP - line label position',0) + +! kludge for NCAR version 3.1.3 + call cpseti('PAI - parameter array identifier ',-1) + call cpseti('AIA - AREA identifier outside grid',-1) + +! turn on drawing of thick edge of plot (will be drawn if contour lines +! requested -- lcflag < 0 ) + call cpseti('PAI - array index',-1) + call cpseti('CLU - contour level use',1) + call cpsetr('CLL - contour line width',2.) + +! arrange for selection of contour levels + + if (fixflag) then + call cpseti('CLS - contour level selector',0) + call cpseti('NCL - number of contour levels', ncontr) + + do i=1,ncontr + call cpseti('PAI - array index',i) + call cpsetr('CLV - contour level',cdepth(i)) + call cpseti('CLU - line type',3) + enddo + else + if (nclevels .eq. 0) then + +! default scheme -- request conpack find ncontr "nice" contour levels + if (ncontr .ge. ncolor) then + print *,' cpsfill: ncontr > ncolors ... trouble ahead' + endif + call cpseti('CLS - contour level selector',ncontr) + call cpsetr('CIS - contour interval selector',0.) + + else + +! override selection hints +! cpmin, cpmax and nclevels are input to plothist + + call cpseti('CLS - contour level selector',0) + call cpseti('NCL - number of contour levels',nclevels+1) + do i=1,nclevels+1 + clevel = cpmin + float(i-1)/float(nclevels)*(cpmax-cpmin) + call cpseti('PAI - array index',i) + call cpsetr('CLV - contour level',clevel) + call cpseti('CLU - line type',3) + enddo + + endif + endif + +! initialize CONPACK + call cprect(zdat,K,M,N,rwrk,lrwk,iwrk,liwk) + +! draw contour plot + call arinam(iama,lawk) + call cpclam(zdat,rwrk,iwrk,iama) + call arscam(iama,xcra,ycra,lcra,iara,igra,nlevb,colram) + +! find contour levels and enter these in labels for labelbar + call cpgetr('CIU - contour interval used',ciu) + call cpgeti('NCL - number of contour levels',ncl) + if (ncl .gt. ncolor-1) then + print *,' cpsfill: warning -- ran out of colours' + endif + ncused = min(ncolor-1,ncl) + + do 110 i=1,ncused + call cpseti('PAI - array index',i) + call cpgeti('CLU - contour level use flag',iclu) + call cpgetr('CLV - contour level',clev) + write(llbs(i),100)clev + 100 format(1pg9.2) + 110 continue + +! create labelbar + + call sfseti('TYPE of FILL',0) + + call getset(fl,fr,fb,ft,ul,ur,ub,ut,ll) + if (tallflg) then + call lblbar(1,fr+0.01,fr+0.09,fb,ft,ncused+1,.15,1.,lfin,0, & + & llbs,ncused,1) + else + call lblbar(0,fl,fr,fb-0.05,fb-0.01,ncused+1,1.,.333,lfin,0, & + & llbs,ncused,1) + end if + + call gsplci(1) + +! put black contour lines over the colored map + if (lcflag .lt. 0) call cpcldr(zdat,rwrk,iwrk) + +! draw labels +! call gsclip(0) +! call cplbdr(zdat,rwrk,iwrk) +! call gsclip(1) + +! reset min, max + call cpsetr('CMN - contour min',1.) + call cpsetr('CMX - contour max',0.) + + return + end + +! ******************************************************************** + + subroutine defclr(lcflag) + integer lcflag + +! defines the colour indicies + + integer ncolor, krgb, i + parameter ( ncolor=17 ) + real rgb(3,ncolor,6) + real rgb1(3,ncolor),rgb2(3,ncolor),rgb3(3,ncolor), & + & rgb4(3,ncolor),rgb5(3,ncolor),rgb6(3,ncolor) + equivalence (rgb(1,1,1),rgb1(1,1)),(rgb(1,1,2),rgb2(1,1)) + equivalence (rgb(1,1,3),rgb3(1,1)),(rgb(1,1,4),rgb4(1,1)) + equivalence (rgb(1,1,5),rgb5(1,1)),(rgb(1,1,6),rgb6(1,1)) + +! Kate's colors (red to blue) + data rgb1 / 0.00, 0.25, 1.00, & + & 0.00, 0.50, 1.00, & + & 0.00, 0.75, 1.00, & + & 0.00, 1.00, 1.00, & + & 0.25, 1.00, 1.00, & + & 0.50, 1.00, 1.00, & + & 0.90, 0.90, 0.90, & + & 1.00, 0.63, 0.63, & + & 1.00, 0.50, 0.50, & + & 1.00, 0.38, 0.38, & + & 1.00, 0.25, 0.25, & + & 1.00, 0.13, 0.13, & + & 1.00, 0.00, 0.00, & + & 1.00, 0.00, 0.00, & + & 1.00, 0.00, 0.00, & + & 1.00, 0.00, 0.00, & + & 1.00, 0.00, 0.00 / +! John's colours (grey to blue like GEBCO bathymetry charts) +! second attempt -- not so dark on the Tek printer + data rgb2 / 0.65, 0.60, 0.60, & + & 0.65, 0.75, 0.75, & + & 0.65, 0.90, 0.90, & + & 0.60, 1.00, 1.00, & + & 0.50, 1.00, 1.00, & + & 0.40, 1.00, 1.00, & + & 0.25, 1.00, 1.00, & + & 0.10, 1.00, 1.00, & + & 0.05, 0.95, 1.00, & + & 0.00, 0.85, 1.00, & + & 0.00, 0.75, 1.00, & + & 0.00, 0.65, 1.00, & + & 0.00, 0.50, 1.00, & + & 0.00, 0.40, 0.85, & + & 0.00, 0.30, 0.75, & + & 0.00, 0.20, 0.60, & + & 0.00, 0.00, 0.50 / +! John's colours (modified for Dale's printer) + data rgb3 / 0.65, 0.60, 0.60, & + & 0.65, 0.75, 0.75, & + & 0.65, 0.90, 0.90, & + & 0.60, 1.00, 1.00, & + & 0.50, 1.00, 1.00, & + & 0.40, 1.00, 1.00, & + & 0.20, 1.00, 1.00, & + & 0.00, 1.00, 1.00, & + & 0.05, 0.95, 1.00, & + & 0.00, 0.80, 1.00, & + & 0.00, 0.60, 1.00, & + & 0.00, 0.40, 1.00, & + & 0.00, 0.20, 1.00, & + & 0.00, 0.00, 1.00, & + & 0.00, 0.00, 0.80, & + & 0.00, 0.00, 0.60, & + & 0.00, 0.00, 0.40 / +! Kate's colours (for Arctic psi) + data rgb4 / 0.10, 1.00, 0.10, & + & 0.32, 1.00, 0.30, &! -8 to -6 + & 0.47, 1.00, 0.42, & + & 0.62, 1.00, 0.54, &! -4 to -2 + & 0.77, 1.00, 0.66, & + & 1.00, 0.97, 0.70, &! 0 to 2 + & 1.00, 0.84, 0.50, & + & 1.00, 0.72, 0.30, &! 4 to 6 + & 0.90, 0.60, 0.30, & + & 0.86, 0.54, 0.40, &! 8 to 10 + & 0.77, 0.47, 0.50, & + & 0.69, 0.45, 0.64, &! 12 to 14 + & 0.62, 0.41, 0.74, & + & 0.58, 0.32, 0.80, &! 16 to 18 + & 0.50, 0.28, 0.84, & + & 0.44, 0.20, 0.88, &! not used + & 0.00, 0.00, 0.60 / +! shades of grey - light to dark + data rgb5 / 0.94, 0.94, 0.94, & + & 0.88, 0.88, 0.88, & + & 0.82, 0.82, 0.82, & + & 0.76, 0.76, 0.76, & + & 0.70, 0.70, 0.70, & + & 0.64, 0.64, 0.64, & + & 0.58, 0.58, 0.58, & + & 0.52, 0.52, 0.52, & + & 0.46, 0.46, 0.46, & + & 0.40, 0.40, 0.40, & + & 0.34, 0.34, 0.34, & + & 0.28, 0.28, 0.28, & + & 0.22, 0.22, 0.22, & + & 0.16, 0.16, 0.16, & + & 0.10, 0.10, 0.10, & + & 0.05, 0.05, 0.05, & + & 0.00, 0.00, 0.00 / +! shades of grey - dark to light + data rgb6 / 0.16, 0.16, 0.16, & + & 0.22, 0.22, 0.22, & + & 0.28, 0.28, 0.28, & + & 0.34, 0.34, 0.34, & + & 0.40, 0.40, 0.40, & + & 0.46, 0.46, 0.46, & + & 0.52, 0.52, 0.52, & + & 0.58, 0.58, 0.58, & + & 0.64, 0.64, 0.64, & + & 0.70, 0.70, 0.70, & + & 0.76, 0.76, 0.76, & + & 0.82, 0.82, 0.82, & + & 0.88, 0.88, 0.88, & + & 0.94, 0.94, 0.94, & + & 0.96, 0.96, 0.96, & + & 0.98, 0.98, 0.98, & + & 1.00, 1.00, 1.00 / + + krgb = abs(lcflag) + if (krgb .gt. 6) call crash(' cpsfill: invalid lcflag',lcflag) + + do 100 i=1,ncolor + call gscr(1,i+1,rgb(1,i,krgb),rgb(2,i,krgb),rgb(3,i,krgb)) + 100 continue + + return + end + + +! ******************************************************************** + + subroutine colram(xcra,ycra,ncra,iaia,igia,naia) + real xcra(*), ycra(*) + integer iaia(*), igia(*) + integer ncolor, ncra, naia, ifll, i + parameter ( ncolor=17 ) + +! The arrays xcra and ycra, for indices 1 to ncra, contain the x +! and y coordinates of points defining a polygon. The area +! identifiers in the array iaia, each with an associated group +! identifier in the array igia, tell us whether the polygon +! is to be color-filled or not. + + ifll = 1 + +! if any of the area identifiers is negative, don't fill the +! polygon. + do 100 i=1,naia + if (iaia(i) .lt. 0) ifll = 0 + 100 continue + +! otherwise, fill the polygon in the color implied by its area +! identifier relative to edge group 3 (the contour-line group) + + if (ifll .ne. 0) then + ifll = 0 + do 110 i=1,naia + if (igia(i) .eq. 3) ifll = iaia(i) + 110 continue + if (ifll .gt. 0 .and. ifll .le. ncolor) then + call gsfaci(ifll+1) + call gfa(ncra-1, xcra, ycra) + end if + end if +! print *,'in colram' +! do i=1,naia +! print *,'iaia ', i, iaia(i), igia(i) +! enddo +! print *,'ifll', ifll + + return + end diff --git a/Utility/def_grid.F b/Utility/def_grid.F new file mode 100644 index 0000000..09e6a3a --- /dev/null +++ b/Utility/def_grid.F @@ -0,0 +1,572 @@ +#include "griddefs.h" + subroutine def_grid +! +!======================================================================= +! === +! This routine creates a Gridpak NetCDF file, it defines its === +! dimensions, attributes, and variables. === +! === +! === +! Calls: crash, opencdf, plus NetCDF library === +! === +! WARNING: The character argument to the NetCDF routines are === +! (upper/lower) case sensitive. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +#include "grid.h" +#include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + integer bathdim, epdim, erdim, eudim, evdim, & + & onedim, twodim, xpdim, xrdim, xudim, xvdim + integer h2dgrd(3), p2dgrd(2), t2dgrd(2), & + & u2dgrd(2), v2dgrd(2) + BIGREAL c0, c1 + parameter ( c0=0.d0, c1=1.d0 ) + character (len=1) :: char1 +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!======================================================================= +! Create a new grid NetCDF file. +!======================================================================= +! + rcode = nf90_create(TRIM(gridfile), nf90_clobber, ncgridid) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('DEF_GRID',1) + endif +! +!----------------------------------------------------------------------- +! Define the dimensions of staggered fields. +!----------------------------------------------------------------------- +! + rcode = nf90_def_dim(ncgridid,'xi_psi',L,xpdim) + rcode = nf90_def_dim(ncgridid,'xi_rho',Lp,xrdim) + rcode = nf90_def_dim(ncgridid,'xi_u',L,xudim) + rcode = nf90_def_dim(ncgridid,'xi_v',Lp,xvdim) + rcode = nf90_def_dim(ncgridid,'eta_psi',M,epdim) + rcode = nf90_def_dim(ncgridid,'eta_rho',Mp,erdim) + rcode = nf90_def_dim(ncgridid,'eta_u',Mp,eudim) + rcode = nf90_def_dim(ncgridid,'eta_v',M,evdim) + rcode = nf90_def_dim(ncgridid,'one',1,onedim) + rcode = nf90_def_dim(ncgridid,'two',2,twodim) + rcode = nf90_def_dim(ncgridid,'bath',nf90_unlimited,bathdim) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Define dimension vectors for staggered 2D psi type +! variables. +! + p2dgrd(1)=xpdim + p2dgrd(2)=epdim +! +! Define dimension vectors for staggered 2D tracer type +! variables. +! + t2dgrd(1)=xrdim + t2dgrd(2)=erdim + h2dgrd(1)=xrdim + h2dgrd(2)=erdim + h2dgrd(3)=bathdim +! +! Define dimension vectors for staggered 2D u-momemtum type +! variables. +! + u2dgrd(1)=xudim + u2dgrd(2)=eudim +! +! Define dimension vectors for staggered 2D v-momemtum type +! variables. +! + v2dgrd(1)=xvdim + v2dgrd(2)=evdim +! +!----------------------------------------------------------------------- +! Define type of floating-point variables: single or double precision. +!----------------------------------------------------------------------- +! +#if DBLEPREC || defined cray + vartyp=nf90_double +#else + vartyp=nf90_float +#endif /* DBLEPREC */ +! +!----------------------------------------------------------------------- +! Create history attribute. +!----------------------------------------------------------------------- +! + call get_date (date_str) + if (LEN_TRIM(date_str).gt.0) then + history='Gridpak, Version '//version//', '//TRIM(date_str) + else + history='Gridpak, Version '//version + endif + rcode = nf90_put_att(ncgridid,nf90_global,'type',& + & 'Gridpak file') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Put global attributes to NetCDF file. +! + rcode = nf90_put_att(ncgridid,nf90_global,'gridid', gridid) + rcode = nf90_put_att(ncgridid,nf90_global,'history', & + & history) + rcode = nf90_put_att(ncgridid,nf90_global,'CPP-options', & + & CPPoptions) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Domain Length. +! + rcode = nf90_def_var(ncgridid,'xl',vartyp,varid=varid) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'domain length in the XI-direction') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif + rcode = nf90_put_att(ncgridid,varid,'units', 'meter') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif + rcode = nf90_def_var(ncgridid,'el',vartyp,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'domain length in the ETA-direction') + rcode = nf90_put_att(ncgridid,varid,'units', 'meter') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Projection parameters. +! + rcode = nf90_def_var(ncgridid,'JPRJ',nf90_char,(/twodim/),varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Map projection type') + rcode = nf90_put_att(ncgridid,varid,'option_ME', 'Mercator') + rcode = nf90_put_att(ncgridid,varid,'option_ST', 'Stereographic') + rcode = nf90_put_att(ncgridid,varid,'option_LC', & + & 'Lambert conformal conic') + rcode=nf90_def_var(ncgridid,'PLAT',nf90_double,(/twodim/),varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Reference latitude(s) for map projection') + rcode = nf90_put_att(ncgridid,varid,'units', 'degree_north') + rcode=nf90_def_var(ncgridid,'PLONG',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Reference longitude for map projection') + rcode = nf90_put_att(ncgridid,varid,'units', 'degree_east') + rcode=nf90_def_var(ncgridid,'ROTA',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Rotation angle for map projection') + rcode = nf90_put_att(ncgridid,varid,'units', 'degree') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif + + rcode=nf90_def_var(ncgridid,'JLTS',nf90_char,(/twodim/),varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'How limits of map are chosen') + rcode = nf90_put_att(ncgridid,varid,'option_CO', & + & 'P1, .. P4 define two opposite corners of domain') + rcode = nf90_put_att(ncgridid,varid,'option_MA', & + & 'Maximum (whole world)') + rcode = nf90_put_att(ncgridid,varid,'option_AN', & + & 'Angles - P1..P4 define angles to edge of domain') + rcode = nf90_put_att(ncgridid,varid,'option_LI', & + & 'Limits - P1..P4 define limits in u,v space') + rcode=nf90_def_var(ncgridid,'P1',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Map limit parameter number 1') + rcode=nf90_def_var(ncgridid,'P2',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Map limit parameter number 2') + rcode=nf90_def_var(ncgridid,'P3',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Map limit parameter number 3') + rcode=nf90_def_var(ncgridid,'P4',nf90_double,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Map limit parameter number 4') +! rcode=nf90_def_var(ncgridid,'JGRD',nf90_double,varid=varid) +! rcode = nf90_put_att(ncgridid,varid,'long_name', +! & 'Density of lat,lon lines to draw on plots') +! rcode = nf90_put_att(ncgridid,varid,'units', 'degree') + rcode=nf90_def_var(ncgridid,'XOFF',nf90_float,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Offset in x direction') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_def_var(ncgridid,'YOFF',nf90_float,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Offset in y direction') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! depthmin and depthmax. +! + rcode = nf90_def_var(ncgridid,'depthmin',vartyp,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Shallow bathymetry clipping depth') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_def_var(ncgridid,'depthmax',vartyp,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Deep bathymetry clipping depth') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Spherical geometry logical flag and beta-plane parameters. +! + rcode=nf90_def_var(ncgridid,'spherical',nf90_char,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Grid type logical switch') + rcode = nf90_put_att(ncgridid,varid,'option_T', 'spherical') + rcode = nf90_put_att(ncgridid,varid,'option_F', 'Cartesian') + rcode=nf90_def_var(ncgridid,'f0',vartyp,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Coriolis parameter central value on a beta-plane') + rcode = nf90_put_att(ncgridid,varid,'_FillValue',c0) + rcode=nf90_def_var(ncgridid,'dfdy',vartyp,varid=varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Coriolis parameter gradient on a beta-plane') + rcode = nf90_put_att(ncgridid,varid,'_FillValue',c0) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +!----------------------------------------------------------------------- +! Define grid variables. +!----------------------------------------------------------------------- +! +! Bathymetry. +! + rcode=nf90_def_var(ncgridid,'hraw',vartyp,h2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Working bathymetry at RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'bath, scalar') + rcode=nf90_def_var(ncgridid,'h',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Final bathymetry at RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'bath, scalar') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Coriolis Parameter. +! + rcode=nf90_def_var(ncgridid,'f',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'Coriolis parameter at RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units', 'second-1') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'Coriolis, scalar') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Curvilinear coordinates metrics. +! + rcode=nf90_def_var(ncgridid,'pm',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'curvilinear coordinate metric in XI') + rcode = nf90_put_att(ncgridid,varid,'units', 'meter-1') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'pm, scalar') + rcode=nf90_def_var(ncgridid,'pn',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'curvilinear coordinate metric in ETA') + rcode = nf90_put_att(ncgridid,varid,'units', 'meter-1') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'pn, scalar') + rcode=nf90_def_var(ncgridid,'dndx',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'xi derivative of inverse metric factor pn') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'dndx, scalar') + rcode=nf90_def_var(ncgridid,'dmde',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'eta derivative of inverse metric factor pm') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode = nf90_put_att(ncgridid,varid,'field', & + & 'dmde, scalar') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! x,y location on the grids. +! + rcode=nf90_def_var(ncgridid,'x_rho',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'x location of RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'y_rho',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'y location of RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'x_psi',vartyp,p2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'x location of PSI-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'y_psi',vartyp,p2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'y location of PSI-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'x_u',vartyp,u2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'x location of U-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'y_u',vartyp,u2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'y location of U-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'x_v',vartyp,v2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'x location of V-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + rcode=nf90_def_var(ncgridid,'y_v',vartyp,v2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'y location of V-points') + rcode = nf90_put_att(ncgridid,varid,'units','meter') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Latitude, longitude on the grids. +! + rcode=nf90_def_var(ncgridid,'lat_rho',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'latitude of RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_north') + rcode=nf90_def_var(ncgridid,'lon_rho',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'longitude of RHO-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_east') + rcode=nf90_def_var(ncgridid,'lat_psi',vartyp,p2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'latitude of PSI-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_north') + rcode=nf90_def_var(ncgridid,'lon_psi',vartyp,p2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'longitude of PSI-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_east') + rcode=nf90_def_var(ncgridid,'lat_u',vartyp,u2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'latitude of U-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_north') + rcode=nf90_def_var(ncgridid,'lon_u',vartyp,u2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'longitude of U-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_east') + rcode=nf90_def_var(ncgridid,'lat_v',vartyp,v2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'latitude of V-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_north') + rcode=nf90_def_var(ncgridid,'lon_v',vartyp,v2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'longitude of V-points') + rcode = nf90_put_att(ncgridid,varid,'units', & + & 'degree_east') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! 0/1 masks. +! + rcode=nf90_def_var(ncgridid,'mask_rho',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'mask on RHO-points') + rcode = nf90_put_att(ncgridid,varid,'option_0', 'land') + rcode = nf90_put_att(ncgridid,varid,'option_1', 'water') + rcode=nf90_def_var(ncgridid,'mask_u',vartyp,u2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'mask on U-points') + rcode = nf90_put_att(ncgridid,varid,'option_0', 'land') + rcode = nf90_put_att(ncgridid,varid,'option_1', 'water') + rcode=nf90_def_var(ncgridid,'mask_v',vartyp,v2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'mask on V-points') + rcode = nf90_put_att(ncgridid,varid,'option_0', 'land') + rcode = nf90_put_att(ncgridid,varid,'option_1', 'water') + rcode=nf90_def_var(ncgridid,'mask_psi',vartyp,p2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'mask on PSI-points') + rcode = nf90_put_att(ncgridid,varid,'option_0', 'land') + rcode = nf90_put_att(ncgridid,varid,'option_1', 'water') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +! Angle. +! + rcode=nf90_def_var(ncgridid,'angle',vartyp,t2dgrd,varid) + rcode = nf90_put_att(ncgridid,varid,'long_name', & + & 'angle between xi axis and east') + rcode = nf90_put_att(ncgridid,varid,'units','radian') + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +!----------------------------------------------------------------------- +! Leave definition mode. +!----------------------------------------------------------------------- +! + rcode = nf90_enddef(ncgridid) + if (rcode.ne.0) then + print *, trim(nf90_strerror(rcode)) + endif +! +!----------------------------------------------------------------------- +! Write out grid variables. +!----------------------------------------------------------------------- +! +! Curvilinear transformation metrics. +! + spherical = .false. + WRITE (char1,'(l1)') spherical + rcode=nf90_inq_varid(ncgridid,'spherical',varid) + rcode = nf90_put_var(ncgridid,varid,char1) + if (rcode.ne.0) then + write(stdout,20) 'spherical', TRIM(gridfile) + print *, trim(nf90_strerror(rcode)) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'pm',varid) + rcode = nf90_put_var(ncgridid,varid,pm) + if (rcode.ne.0) then + write(stdout,20) 'pm', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'pn',varid) + rcode = nf90_put_var(ncgridid,varid,pn) + if (rcode.ne.0) then + write(stdout,20) 'pn', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'dndx',varid) + rcode = nf90_put_var(ncgridid,varid,dndx) + if (rcode.ne.0) then + write(stdout,20) 'dndx', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'dmde',varid) + rcode = nf90_put_var(ncgridid,varid,dmde) + if (rcode.ne.0) then + write(stdout,20) 'dmde', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif +! +! Domain Length. +! + rcode=nf90_inq_varid(ncgridid,'xl',varid) + rcode = nf90_put_var(ncgridid,varid,xl) + if (rcode.ne.0) then + write(stdout,20) 'xl', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'el',varid) + rcode = nf90_put_var(ncgridid,varid,el) + if (rcode.ne.0) then + write(stdout,20) 'el', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif +! +! x,y grids. +! + rcode=nf90_inq_varid(ncgridid,'x_rho',varid) + rcode = nf90_put_var(ncgridid,varid,xr) + if (rcode.ne.0) then + write(stdout,20) 'x_rho', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_rho',varid) + rcode = nf90_put_var(ncgridid,varid,yr) + if (rcode.ne.0) then + write(stdout,20) 'y_rho', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_psi',varid) + rcode = nf90_put_var(ncgridid,varid,xp) + if (rcode.ne.0) then + write(stdout,20) 'x_psi', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_psi',varid) + rcode = nf90_put_var(ncgridid,varid,yp) + if (rcode.ne.0) then + write(stdout,20) 'y_psi', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_u',varid) + rcode = nf90_put_var(ncgridid,varid,xu) + if (rcode.ne.0) then + write(stdout,20) 'x_u', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_u',varid) + rcode = nf90_put_var(ncgridid,varid,yu) + if (rcode.ne.0) then + write(stdout,20) 'y_u', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_v',varid) + rcode = nf90_put_var(ncgridid,varid,xv) + if (rcode.ne.0) then + write(stdout,20) 'x_v', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_v',varid) + rcode = nf90_put_var(ncgridid,varid,yv) + if (rcode.ne.0) then + write(stdout,20) 'y_v', TRIM(gridfile) + call crash ('DEF_GRID',1) + endif +! +! Close the file. +! + rcode = nf90_close(ncgridid) + if (rcode.ne.0) then + write(stdout,30) TRIM(gridfile) + call crash ('DEF_GRID',1) + endif +! +!======================================================================= +! + 10 format(/' DEF_GRID - unable to create grid NetCDF file: ',a) + 20 format(/' DEF_GRID - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file: ',a) + 30 format(/' DEF_GRID - unable to close grid NetCDF file: ',a) + return + end diff --git a/Utility/drawcoast.F b/Utility/drawcoast.F new file mode 100644 index 0000000..2324357 --- /dev/null +++ b/Utility/drawcoast.F @@ -0,0 +1,49 @@ +! ********************************************************************* +! Copyright (c) 1991, 1993 Rutgers University +! +! ********************************************************************* + + subroutine drawcoast +#include "griddefs.h" + real lat, lon + +! MAX is maximum number of segments in data file + integer MAX + parameter ( MAX=100000 ) + character*80 datafile + integer icst, nn + + icst = 40 + call getenv('XCOASTDATA', datafile) + open(icst,file=datafile,err=130) + +! I want a "while (scanf() != EOF)", but I have to fake it. + do 100 nn=1,MAX + read (icst,*,err=120,end=110) lat, lon + call mapit(lat, lon, 0) + do while (abs(lat) .lt. 89.99) + call mapit(lat, lon, 2) + read (icst,*,err=120,end=110) lat, lon + enddo + 100 continue + + print *,'Did not reach end of file in drawcoast' + print *,'Increase MAX to draw the rest of your file' + 110 continue + call mapiq + close(icst) + return + + 120 print *,'read error in drawcoast' +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + 130 print *, 'error opening file in drawcoast ', datafile +#if NO_EXIT + stop +#else + call exit(1) +#endif /* NO_EXIT */ + end diff --git a/Utility/extract.F b/Utility/extract.F new file mode 100644 index 0000000..2eb0cff --- /dev/null +++ b/Utility/extract.F @@ -0,0 +1,96 @@ +#include "griddefs.h" + + subroutine extract(lon,lat,topo,im,jm) +! +!======================================================================= +! Define global data. +!======================================================================= +! + use netcdf +! +!======================================================================= +! Define local data. +!======================================================================= +! + integer ncinpid, rcode, i, j + character*60 fname + integer im, jm, stdout, varid + integer count(2), start(2) + integer*2 topo(im,jm) + real c0, c5, c60 + BIGREAL lat(jm), lon(im) + parameter ( c0=0.0,c5=5.0,c60=60.0,stdout=6) +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +#if ETOPO5 + call getenv('ETOPO5',fname) +#elif ETOPO2 + call getenv('ETOPO2',fname) +#elif GEBCO + call getenv('GEBCO',fname) +#else + call getenv('BATHY_FILE',fname) +#endif /* ETOPO5 */ + rcode = nf90_open(fname,nf90_nowrite,ncinpid) +! +!----------------------------------------------------------------------- +! Extract longitudes of the requested area. +!----------------------------------------------------------------------- +! + start(1)=1 + count(1)=im + rcode = nf90_inq_varid(ncinpid,'topo_lon',varid) + if (rcode.eq.0) then + rcode = nf90_get_var(ncinpid,varid,lon) + if (rcode.ne.0) then + write(stdout,900) 'topo_lon' + goto 10 + endif + else + write(stdout,901) 'topo_lon' + endif +! +!----------------------------------------------------------------------- +! Extract latitudes of the requested area. +!----------------------------------------------------------------------- +! + rcode = nf90_inq_varid(ncinpid,'topo_lat',varid) + if (rcode.eq.0) then + rcode = nf90_get_var(ncinpid,varid,lat) + if (rcode.ne.0) then + write(stdout,900) 'topo_lat' + goto 10 + endif + else + write(stdout,901) 'topo_lat' + endif + print *, 'im ', im, jm, lon(1) +! +!----------------------------------------------------------------------- +! Extract bathmetry +!----------------------------------------------------------------------- +! + rcode=nf90_inq_varid(ncinpid,'topo',varid) + if (rcode.eq.0) then + rcode = nf90_get_var(ncinpid,varid,topo) + if(rcode.ne.0) then + write(stdout,900) 'topo' + goto 10 + endif + else + write(stdout,901) 'topo' + endif +! + goto 20 + 10 write(stdout,903) + stop + 20 continue + 900 format(/' EXTRACT - error while reading variable: ',a) + 901 format(/' EXTRACT - cannot find variable: ',a) + 902 format(/' EXTRACT - error while writing variable: ',a) + 903 format(/' EXTRACT - terminated abnormally.') + return + end diff --git a/Utility/genbun.F b/Utility/genbun.F new file mode 100644 index 0000000..f953355 --- /dev/null +++ b/Utility/genbun.F @@ -0,0 +1,1370 @@ + subroutine genbun (nperod,n,mperod,m,a,b,c,idimy,y,ierror,w) +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! +! dimension of a(m),b(m),c(m),y(idimy,n), +! w(see parameter list) +! arguments +! +! latest revision november 1988 +! +! purpose the name of this package is a mnemonic for the +! generalized buneman algorithm. +! +! it solves the real linear system of equations +! +! a(i)*x(i-1,j) + b(i)*x(i,j) + c(i)*x(i+1,j) +! + x(i,j-1) - 2.*x(i,j) + x(i,j+1) = y(i,j) +! +! for i = 1,2,...,m and j = 1,2,...,n. +! +! indices i+1 and i-1 are evaluated modulo m, +! i.e., x(0,j) = x(m,j) and x(m+1,j) = x(1,j), +! and x(i,0) may equal 0, x(i,2), or x(i,n), +! and x(i,n+1) may equal 0, x(i,n-1), or x(i,1) +! depending on an input parameter. +! +! usage call genbun (nperod,n,mperod,m,a,b,c,idimy,y, +! ierror,w) +! +! arguments +! +! on input nperod +! +! indicates the values that x(i,0) and +! x(i,n+1) are assumed to have. +! +! = 0 if x(i,0) = x(i,n) and x(i,n+1) = +! x(i,1). +! = 1 if x(i,0) = x(i,n+1) = 0 . +! = 2 if x(i,0) = 0 and x(i,n+1) = x(i,n-1). +! = 3 if x(i,0) = x(i,2) and x(i,n+1) = +! x(i,n-1). +! = 4 if x(i,0) = x(i,2) and x(i,n+1) = 0. +! +! n +! the number of unknowns in the j-direction. +! n must be greater than 2. +! +! mperod +! = 0 if a(1) and c(m) are not zero +! = 1 if a(1) = c(m) = 0 +! +! m +! the number of unknowns in the i-direction. +! n must be greater than 2. +! +! a,b,c +! one-dimensional arrays of length m that +! specify the coefficients in the linear +! equations given above. if mperod = 0 +! the array elements must not depend upon +! the index i, but must be constant. +! specifically, the subroutine checks the +! following condition . +! +! a(i) = c(1) +! c(i) = c(1) +! b(i) = b(1) +! +! for i=1,2,...,m. +! +! idimy +! the row (or first) dimension of the +! two-dimensional array y as it appears +! in the program calling genbun. +! this parameter is used to specify the +! variable dimension of y. +! idimy must be at least m. +! +! y +! a two-dimensional complex array that +! specifies the values of the right side +! of the linear system of equations given +! above. +! y must be dimensioned at least m*n. +! +! w +! a one-dimensional array that must +! be provided by the user for work +! space. w may require up to 4*n + +! (10 + int(log2(n)))*m locations. +! the actual number of locations used is +! computed by genbun and is returned in +! location w(1). +! +! +! on output y +! +! contains the solution x. +! +! ierror +! an error flag which indicates invalid +! input parameters except for number +! zero, a solution is not attempted. +! +! = 0 no error. +! = 1 m .le. 2 . +! = 2 n .le. 2 +! = 3 idimy .lt. m +! = 4 nperod .lt. 0 or nperod .gt. 4 +! = 5 mperod .lt. 0 or mperod .gt. 1 +! = 6 a(i) .ne. c(1) or c(i) .ne. c(1) or +! b(i) .ne. b(1) for +! some i=1,2,...,m. +! = 7 a(1) .ne. 0 or c(m) .ne. 0 and +! mperod = 1 +! +! w +! w(1) contains the required length of w. +! +! special conditons none +! +! i/o none +! +! precision single +! +! required library comf and gnbnaux from fishpak +! files +! +! language fortran +! +! history written in 1979 by roland sweet of ncar's +! scientific computing division. made available +! on ncar's public libraries in january, 1980. +! +! algorithm the linear system is solved by a cyclic +! reduction algorithm described in the +! reference. +! +! portability fortran 77 -- +! the machine dependent constant pi is +! defined in function pimach. +! +! references sweet, r., "a cyclic reduction algorithm for +! solving block tridiagonal systems of arbitrary +! dimensions," siam j. on numer. anal., 14 (1977) +! pp. 706-720. +! +! accuracy this test was performed on a cdc 7600: +! +! a uniform random number generator was used +! to create a solution array x for the system +! given in the 'purpose' description above +! with +! a(i) = c(i) = -0.5*b(i) = 1, i=1,2,...,m +! +! and, when mperod = 1 +! +! a(1) = c(m) = 0 +! a(m) = c(1) = 2. +! +! the solution x was substituted into the +! given system and, using double precision +! a right side y was computed. +! using this array y, subroutine genbun +! was called to produce approximate +! solution z. then relative error +! e = max(abs(z(i,j)-x(i,j)))/ +! max(abs(x(i,j))) +! was computed, where the two maxima are taken +! over i=1,2,...,m and j=1,...,n. +! +! the value of e is given in the table +! below for some typical values of m and n. +! +! m (=n) mperod nperod t(msecs) e +! ------ ------ ------ -------- ------ +! +! 31 0 0 36 6.e-14 +! 31 1 1 21 4.e-13 +! 31 1 3 41 3.e-13 +! 32 0 0 29 9.e-14 +! 32 1 1 32 3.e-13 +! 32 1 3 48 1.e-13 +! 33 0 0 36 9.e-14 +! 33 1 1 30 4.e-13 +! 33 1 3 34 1.e-13 +! 63 0 0 150 1.e-13 +! 63 1 1 91 1.e-12 +! 63 1 3 173 2.e-13 +! 64 0 0 122 1.e-13 +! 64 1 1 128 1.e-12 +! 64 1 3 199 6.e-13 +! 65 0 0 143 2.e-13 +! 65 1 1 120 1.e-12 +! 65 1 3 138 4.e-13 +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +#include "griddefs.h" + integer nperod, n, mperod, m, idimy, ierror + BIGREAL y(idimy,1) + BIGREAL w(*) ,b(*) ,a(*) ,c(*) + +! local variables + integer i, j, k, np, mp, mh, mp1, iwba, iwbb, iwbc, & + & iwb2, iwb3, iww1, iww2, iww3, iwd, iwp, iwtcos, & + & ipstor, irev, modd, mhm1, mhmi, mhpi, nby2, & + & mskip + BIGREAL a1 + +! + ierror = 0 + if (m .le. 2) ierror = 1 + if (n .le. 2) ierror = 2 + if (idimy .lt. m) ierror = 3 + if (nperod.lt.0 .or. nperod.gt.4) ierror = 4 + if (mperod.lt.0 .or. mperod.gt.1) ierror = 5 + if (mperod .eq. 1) go to 102 + do 101 i=2,m + if (a(i) .ne. c(1)) go to 103 + if (c(i) .ne. c(1)) go to 103 + if (b(i) .ne. b(1)) go to 103 + 101 continue + go to 104 + 102 if (a(1).ne.0. .or. c(m).ne.0.) ierror = 7 + go to 104 + 103 ierror = 6 + 104 if (ierror .ne. 0) return + mp1 = m+1 + iwba = mp1 + iwbb = iwba+m + iwbc = iwbb+m + iwb2 = iwbc+m + iwb3 = iwb2+m + iww1 = iwb3+m + iww2 = iww1+m + iww3 = iww2+m + iwd = iww3+m + iwtcos = iwd+m + iwp = iwtcos+4*n + do 106 i=1,m + k = iwba+i-1 + w(k) = -a(i) + k = iwbc+i-1 + w(k) = -c(i) + k = iwbb+i-1 + w(k) = 2.-b(i) + do 105 j=1,n + y(i,j) = -y(i,j) + 105 continue + 106 continue + mp = mperod+1 + np = nperod+1 + go to (114,107),mp + 107 go to (108,109,110,111,123),np + 108 call poisp2 (m,n,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), & + & w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), & + & w(iwp)) + go to 112 + 109 call poisd2 (m,n,1,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iww1), & + & w(iwd),w(iwtcos),w(iwp)) + go to 112 + 110 call poisn2 (m,n,1,2,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), & + & w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), & + & w(iwp)) + go to 112 + 111 call poisn2 (m,n,1,1,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), & + & w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), & + & w(iwp)) + 112 ipstor = w(iww1) + irev = 2 + if (nperod .eq. 4) go to 124 + 113 go to (127,133),mp + 114 continue +! +! reorder unknowns when mp =0 +! + mh = (m+1)/2 + mhm1 = mh-1 + modd = 1 + if (mh*2 .eq. m) modd = 2 + do 119 j=1,n + do 115 i=1,mhm1 + mhpi = mh+i + mhmi = mh-i + w(i) = y(mhmi,j)-y(mhpi,j) + w(mhpi) = y(mhmi,j)+y(mhpi,j) + 115 continue + w(mh) = 2.*y(mh,j) + go to (117,116),modd + 116 w(m) = 2.*y(m,j) + 117 continue + do 118 i=1,m + y(i,j) = w(i) + 118 continue + 119 continue + k = iwbc+mhm1-1 + i = iwba+mhm1 + w(k) = 0. + w(i) = 0. + w(k+1) = 2.*w(k+1) + go to (120,121),modd + 120 continue + k = iwbb+mhm1-1 + w(k) = w(k)-w(i-1) + w(iwbc-1) = w(iwbc-1)+w(iwbb-1) + go to 122 + 121 w(iwbb-1) = w(k+1) + 122 continue + go to 107 +! +! reverse columns when nperod = 4. +! + 123 irev = 1 + nby2 = n/2 + 124 do 126 j=1,nby2 + mskip = n+1-j + do 125 i=1,m + a1 = y(i,j) + y(i,j) = y(i,mskip) + y(i,mskip) = a1 + 125 continue + 126 continue + go to (110,113),irev + 127 continue + do 132 j=1,n + do 128 i=1,mhm1 + mhmi = mh-i + mhpi = mh+i + w(mhmi) = .5*(y(mhpi,j)+y(i,j)) + w(mhpi) = .5*(y(mhpi,j)-y(i,j)) + 128 continue + w(mh) = .5*y(mh,j) + go to (130,129),modd + 129 w(m) = .5*y(m,j) + 130 continue + do 131 i=1,m + y(i,j) = w(i) + 131 continue + 132 continue + 133 continue +! +! return storage requirements for w array. +! + w(1) = ipstor+iwp-1 + return + end + + subroutine poisd2 (mr,nr,istag,ba,bb,bc,q,idimq,b,w,d,tcos,p) +! +! subroutine to solve poisson's equation for dirichlet boundary +! conditions. +! +! istag = 1 if the last diagonal block is the matrix a. +! istag = 2 if the last diagonal block is the matrix a+i. +! + integer mr, nr, istag, idimq + BIGREAL q(idimq,1) ,ba(*) ,bb(*) ,bc(*) , & + & tcos(*) ,b(*) ,d(*) ,w(*) , & + & p(*) +! local variables + integer i, j, l, m, n, jsh, ip, ipstor, kr, irreg, & + & jstsav, lr, nun, jst, jsp, nodd, jp3, jm2, jp2, & + & jm1, jp1, noddpr, jm3, ip1, krpi, ideg, jdeg + BIGREAL fi, t + external merge + BIGREAL half, zero, one + parameter ( half = 0.5, zero = 0., one = 1.0 ) + + m = mr + n = nr + jsh = 0 + fi = 1./float(istag) + ip = -m + ipstor = 0 + go to (101,102),istag + 101 kr = 0 + irreg = 1 + if (n .gt. 1) go to 106 + tcos(1) = 0. + go to 103 + 102 kr = 1 + jstsav = 1 + irreg = 2 + if (n .gt. 1) go to 106 + tcos(1) = -1. + 103 do 104 i=1,m + b(i) = q(i,1) + 104 continue + call trix (1,0,m,ba,bb,bc,b,tcos,d,w) + do 105 i=1,m + q(i,1) = b(i) + 105 continue + go to 183 + 106 lr = 0 + do 107 i=1,m + p(i) = 0. + 107 continue + nun = n + jst = 1 + jsp = n +! +! irreg = 1 when no irregularities have occurred, otherwise it is 2. +! + 108 l = 2*jst + nodd = 2-2*((nun+1)/2)+nun +! +! nodd = 1 when nun is odd, otherwise it is 2. +! + go to (110,109),nodd + 109 jsp = jsp-l + go to 111 + 110 jsp = jsp-jst + if (irreg .ne. 1) jsp = jsp-l + 111 continue +! +! regular reduction +! + call cosgen (jst,1,half,one,tcos) + if (l .gt. jsp) go to 118 + do 117 j=l,jsp,l + jm1 = j-jsh + jp1 = j+jsh + jm2 = j-jst + jp2 = j+jst + jm3 = jm2-jsh + jp3 = jp2+jsh + if (jst .ne. 1) go to 113 + do 112 i=1,m + b(i) = 2.*q(i,j) + q(i,j) = q(i,jm2)+q(i,jp2) + 112 continue + go to 115 + 113 do 114 i=1,m + t = q(i,j)-q(i,jm1)-q(i,jp1)+q(i,jm2)+q(i,jp2) + b(i) = t+q(i,j)-q(i,jm3)-q(i,jp3) + q(i,j) = t + 114 continue + 115 continue + call trix (jst,0,m,ba,bb,bc,b,tcos,d,w) + do 116 i=1,m + q(i,j) = q(i,j)+b(i) + 116 continue + 117 continue +! +! reduction for last unknown +! + 118 go to (119,136),nodd + 119 go to (152,120),irreg +! +! odd number of unknowns +! + 120 jsp = jsp+l + j = jsp + jm1 = j-jsh + jp1 = j+jsh + jm2 = j-jst + jp2 = j+jst + jm3 = jm2-jsh + go to (123,121),istag + 121 continue + if (jst .ne. 1) go to 123 + do 122 i=1,m + b(i) = q(i,j) + q(i,j) = 0. + 122 continue + go to 130 + 123 go to (124,126),noddpr + 124 do 125 i=1,m + ip1 = ip+i + b(i) = .5*(q(i,jm2)-q(i,jm1)-q(i,jm3))+p(ip1)+q(i,j) + 125 continue + go to 128 + 126 do 127 i=1,m + b(i) = .5*(q(i,jm2)-q(i,jm1)-q(i,jm3))+q(i,jp2)-q(i,jp1)+q(i,j) + 127 continue + 128 do 129 i=1,m + q(i,j) = .5*(q(i,j)-q(i,jm1)-q(i,jp1)) + 129 continue + 130 call trix (jst,0,m,ba,bb,bc,b,tcos,d,w) + ip = ip+m + ipstor = max0(ipstor,ip+m) + do 131 i=1,m + ip1 = ip+i + p(ip1) = q(i,j)+b(i) + b(i) = q(i,jp2)+p(ip1) + 131 continue + if (lr .ne. 0) go to 133 + do 132 i=1,jst + krpi = kr+i + tcos(krpi) = tcos(i) + 132 continue + go to 134 + 133 continue + call cosgen (lr,jstsav,zero,fi,tcos(jst+1)) + call merge (tcos,0,jst,jst,lr,kr) + 134 continue + call cosgen (kr,jstsav,zero,fi,tcos) + call trix (kr,kr,m,ba,bb,bc,b,tcos,d,w) + do 135 i=1,m + ip1 = ip+i + q(i,j) = q(i,jm2)+b(i)+p(ip1) + 135 continue + lr = kr + kr = kr+l + go to 152 +! +! even number of unknowns +! + 136 jsp = jsp+l + j = jsp + jm1 = j-jsh + jp1 = j+jsh + jm2 = j-jst + jp2 = j+jst + jm3 = jm2-jsh + go to (137,138),irreg + 137 continue + jstsav = jst + ideg = jst + kr = l + go to 139 + 138 call cosgen (kr,jstsav,zero,fi,tcos) + call cosgen (lr,jstsav,zero,fi,tcos(kr+1)) + ideg = kr + kr = kr+jst + 139 if (jst .ne. 1) go to 141 + irreg = 2 + do 140 i=1,m + b(i) = q(i,j) + q(i,j) = q(i,jm2) + 140 continue + go to 150 + 141 do 142 i=1,m + b(i) = q(i,j)+.5*(q(i,jm2)-q(i,jm1)-q(i,jm3)) + 142 continue + go to (143,145),irreg + 143 do 144 i=1,m + q(i,j) = q(i,jm2)+.5*(q(i,j)-q(i,jm1)-q(i,jp1)) + 144 continue + irreg = 2 + go to 150 + 145 continue + go to (146,148),noddpr + 146 do 147 i=1,m + ip1 = ip+i + q(i,j) = q(i,jm2)+p(ip1) + 147 continue + ip = ip-m + go to 150 + 148 do 149 i=1,m + q(i,j) = q(i,jm2)+q(i,j)-q(i,jm1) + 149 continue + 150 call trix (ideg,lr,m,ba,bb,bc,b,tcos,d,w) + do 151 i=1,m + q(i,j) = q(i,j)+b(i) + 151 continue + 152 nun = nun/2 + noddpr = nodd + jsh = jst + jst = 2*jst + if (nun .ge. 2) go to 108 +! +! start solution. +! + j = jsp + do 153 i=1,m + b(i) = q(i,j) + 153 continue + go to (154,155),irreg + 154 continue + call cosgen (jst,1,half,zero,tcos) + ideg = jst + go to 156 + 155 kr = lr+jst + call cosgen (kr,jstsav,zero,fi,tcos) + call cosgen (lr,jstsav,zero,fi,tcos(kr+1)) + ideg = kr + 156 continue + call trix (ideg,lr,m,ba,bb,bc,b,tcos,d,w) + jm1 = j-jsh + jp1 = j+jsh + go to (157,159),irreg + 157 do 158 i=1,m + q(i,j) = .5*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i) + 158 continue + go to 164 + 159 go to (160,162),noddpr + 160 do 161 i=1,m + ip1 = ip+i + q(i,j) = p(ip1)+b(i) + 161 continue + ip = ip-m + go to 164 + 162 do 163 i=1,m + q(i,j) = q(i,j)-q(i,jm1)+b(i) + 163 continue + 164 continue +! +! start back substitution. +! + jst = jst/2 + jsh = jst/2 + nun = 2*nun + if (nun .gt. n) go to 183 + do 182 j=jst,n,l + jm1 = j-jsh + jp1 = j+jsh + jm2 = j-jst + jp2 = j+jst + if (j .gt. jst) go to 166 + do 165 i=1,m + b(i) = q(i,j)+q(i,jp2) + 165 continue + go to 170 + 166 if (jp2 .le. n) go to 168 + do 167 i=1,m + b(i) = q(i,j)+q(i,jm2) + 167 continue + if (jst .lt. jstsav) irreg = 1 + go to (170,171),irreg + 168 do 169 i=1,m + b(i) = q(i,j)+q(i,jm2)+q(i,jp2) + 169 continue + 170 continue + call cosgen (jst,1,half,zero,tcos) + ideg = jst + jdeg = 0 + go to 172 + 171 if (j+l .gt. n) lr = lr-jst + kr = jst+lr + call cosgen (kr,jstsav,zero,fi,tcos) + call cosgen (lr,jstsav,zero,fi,tcos(kr+1)) + ideg = kr + jdeg = lr + 172 continue + call trix (ideg,jdeg,m,ba,bb,bc,b,tcos,d,w) + if (jst .gt. 1) go to 174 + do 173 i=1,m + q(i,j) = b(i) + 173 continue + go to 182 + 174 if (jp2 .gt. n) go to 177 + 175 do 176 i=1,m + q(i,j) = .5*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i) + 176 continue + go to 182 + 177 go to (175,178),irreg + 178 if (j+jsh .gt. n) go to 180 + do 179 i=1,m + ip1 = ip+i + q(i,j) = b(i)+p(ip1) + 179 continue + ip = ip-m + go to 182 + 180 do 181 i=1,m + q(i,j) = b(i)+q(i,j)-q(i,jm1) + 181 continue + 182 continue + l = l/2 + go to 164 + 183 continue +! +! return storage requirements for p vectors. +! + w(1) = ipstor + return + end + + subroutine poisn2 (m,n,istag,mixbnd,a,bb,c,q,idimq,b,b2,b3,w,w2, & + & w3,d,tcos,p) +! +! subroutine to solve poisson's equation with neumann boundary +! conditions. +! +! istag = 1 if the last diagonal block is a. +! istag = 2 if the last diagonal block is a-i. +! mixbnd = 1 if have neumann boundary conditions at both boundaries. +! mixbnd = 2 if have neumann boundary conditions at bottom and +! dirichlet condition at top. (for this case, must have istag = 1.) +! + integer m, n, istag, mixbnd, idimq + BIGREAL a(*) ,bb(*) ,c(*) ,q(idimq,*) , & + & b(*) ,b2(*) ,b3(*) ,w(*) , & + & w2(*) ,w3(*) ,d(*) ,tcos(*) , & + & p(*) +! local variables + integer i, j, k(4), k1, k2, k3, k4, mr, ipstor, i2r, jr, & + & nr, nlast, kr, lr, jstop, jp3, jp2, i2rby2, jm1, & + & jp1, jm2, jm3, nrodpr, ii, ip, i1, i2, jr2, & + & nlastp, jstep, nrod, jstart + BIGREAL fistag, fnum, fden, fi, t + equivalence (k(1),k1) ,(k(2),k2) ,(k(3),k3) ,(k(4),k4) + external merge + BIGREAL half, zero, one + parameter ( half = 0.5, zero = 0., one = 1.0 ) + + fistag = 3-istag + fnum = 1./float(istag) + fden = 0.5*float(istag-1) + mr = m + ip = -mr + ipstor = 0 + i2r = 1 + jr = 2 + nr = n + nlast = n + kr = 1 + lr = 0 + go to (101,103),istag + 101 continue + do 102 i=1,mr + q(i,n) = .5*q(i,n) + 102 continue + go to (103,104),mixbnd + 103 if (n .le. 3) go to 155 + 104 continue + jr = 2*i2r + nrod = 1 + if ((nr/2)*2 .eq. nr) nrod = 0 + go to (105,106),mixbnd + 105 jstart = 1 + go to 107 + 106 jstart = jr + nrod = 1-nrod + 107 continue + jstop = nlast-jr + if (nrod .eq. 0) jstop = jstop-i2r + call cosgen (i2r,1,half,zero,tcos) + i2rby2 = i2r/2 + if (jstop .ge. jstart) go to 108 + j = jr + go to 116 + 108 continue +! +! regular reduction. +! + do 115 j=jstart,jstop,jr + jp1 = j+i2rby2 + jp2 = j+i2r + jp3 = jp2+i2rby2 + jm1 = j-i2rby2 + jm2 = j-i2r + jm3 = jm2-i2rby2 + if (j .ne. 1) go to 109 + jm1 = jp1 + jm2 = jp2 + jm3 = jp3 + 109 continue + if (i2r .ne. 1) go to 111 + if (j .eq. 1) jm2 = jp2 + do 110 i=1,mr + b(i) = 2.*q(i,j) + q(i,j) = q(i,jm2)+q(i,jp2) + 110 continue + go to 113 + 111 continue + do 112 i=1,mr + fi = q(i,j) + q(i,j) = q(i,j)-q(i,jm1)-q(i,jp1)+q(i,jm2)+q(i,jp2) + b(i) = fi+q(i,j)-q(i,jm3)-q(i,jp3) + 112 continue + 113 continue + call trix (i2r,0,mr,a,bb,c,b,tcos,d,w) + do 114 i=1,mr + q(i,j) = q(i,j)+b(i) + 114 continue +! +! end of reduction for regular unknowns. +! + 115 continue +! +! begin special reduction for last unknown. +! + j = jstop+jr + 116 nlast = j + jm1 = j-i2rby2 + jm2 = j-i2r + jm3 = jm2-i2rby2 + if (nrod .eq. 0) go to 128 +! +! odd number of unknowns +! + if (i2r .ne. 1) go to 118 + do 117 i=1,mr + b(i) = fistag*q(i,j) + q(i,j) = q(i,jm2) + 117 continue + go to 126 + 118 do 119 i=1,mr + b(i) = q(i,j)+.5*(q(i,jm2)-q(i,jm1)-q(i,jm3)) + 119 continue + if (nrodpr .ne. 0) go to 121 + do 120 i=1,mr + ii = ip+i + q(i,j) = q(i,jm2)+p(ii) + 120 continue + ip = ip-mr + go to 123 + 121 continue + do 122 i=1,mr + q(i,j) = q(i,j)-q(i,jm1)+q(i,jm2) + 122 continue + 123 if (lr .eq. 0) go to 124 + call cosgen (lr,1,half,fden,tcos(kr+1)) + go to 126 + 124 continue + do 125 i=1,mr + b(i) = fistag*b(i) + 125 continue + 126 continue + call cosgen (kr,1,half,fden,tcos) + call trix (kr,lr,mr,a,bb,c,b,tcos,d,w) + do 127 i=1,mr + q(i,j) = q(i,j)+b(i) + 127 continue + kr = kr+i2r + go to 151 + 128 continue +! +! even number of unknowns +! + jp1 = j+i2rby2 + jp2 = j+i2r + if (i2r .ne. 1) go to 135 + do 129 i=1,mr + b(i) = q(i,j) + 129 continue + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + ip = 0 + ipstor = mr + go to (133,130),istag + 130 do 131 i=1,mr + p(i) = b(i) + b(i) = b(i)+q(i,n) + 131 continue + tcos(1) = 1. + tcos(2) = 0. + call trix (1,1,mr,a,bb,c,b,tcos,d,w) + do 132 i=1,mr + q(i,j) = q(i,jm2)+p(i)+b(i) + 132 continue + go to 150 + 133 continue + do 134 i=1,mr + p(i) = b(i) + q(i,j) = q(i,jm2)+2.*q(i,jp2)+3.*b(i) + 134 continue + go to 150 + 135 continue + do 136 i=1,mr + b(i) = q(i,j)+.5*(q(i,jm2)-q(i,jm1)-q(i,jm3)) + 136 continue + if (nrodpr .ne. 0) go to 138 + do 137 i=1,mr + ii = ip+i + b(i) = b(i)+p(ii) + 137 continue + go to 140 + 138 continue + do 139 i=1,mr + b(i) = b(i)+q(i,jp2)-q(i,jp1) + 139 continue + 140 continue + call trix (i2r,0,mr,a,bb,c,b,tcos,d,w) + ip = ip+mr + ipstor = max0(ipstor,ip+mr) + do 141 i=1,mr + ii = ip+i + p(ii) = b(i)+.5*(q(i,j)-q(i,jm1)-q(i,jp1)) + b(i) = p(ii)+q(i,jp2) + 141 continue + if (lr .eq. 0) go to 142 + call cosgen (lr,1,half,fden,tcos(i2r+1)) + call merge (tcos,0,i2r,i2r,lr,kr) + go to 144 + 142 do 143 i=1,i2r + ii = kr+i + tcos(ii) = tcos(i) + 143 continue + 144 call cosgen (kr,1,half,fden,tcos) + if (lr .ne. 0) go to 145 + go to (146,145),istag + 145 continue + call trix (kr,kr,mr,a,bb,c,b,tcos,d,w) + go to 148 + 146 continue + do 147 i=1,mr + b(i) = fistag*b(i) + 147 continue + 148 continue + do 149 i=1,mr + ii = ip+i + q(i,j) = q(i,jm2)+p(ii)+b(i) + 149 continue + 150 continue + lr = kr + kr = kr+jr + 151 continue + go to (152,153),mixbnd + 152 nr = (nlast-1)/jr+1 + if (nr .le. 3) go to 155 + go to 154 + 153 nr = nlast/jr + if (nr .le. 1) go to 192 + 154 i2r = jr + nrodpr = nrod + go to 104 + 155 continue +! +! begin solution +! + j = 1+jr + jm1 = j-i2r + jp1 = j+i2r + jm2 = nlast-i2r + if (nr .eq. 2) go to 184 + if (lr .ne. 0) go to 170 + if (n .ne. 3) go to 161 +! +! case n = 3. +! + go to (156,168),istag + 156 continue + do 157 i=1,mr + b(i) = q(i,2) + 157 continue + tcos(1) = 0. + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + do 158 i=1,mr + q(i,2) = b(i) + b(i) = 4.*b(i)+q(i,1)+2.*q(i,3) + 158 continue + tcos(1) = -2. + tcos(2) = 2. + i1 = 2 + i2 = 0 + call trix (i1,i2,mr,a,bb,c,b,tcos,d,w) + do 159 i=1,mr + q(i,2) = q(i,2)+b(i) + b(i) = q(i,1)+2.*q(i,2) + 159 continue + tcos(1) = 0. + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + do 160 i=1,mr + q(i,1) = b(i) + 160 continue + jr = 1 + i2r = 0 + go to 194 +! +! case n = 2**p+1 +! + 161 continue + go to (162,170),istag + 162 continue + do 163 i=1,mr + b(i) = q(i,j)+.5*q(i,1)-q(i,jm1)+q(i,nlast)-q(i,jm2) + 163 continue + call cosgen (jr,1,half,zero,tcos) + call trix (jr,0,mr,a,bb,c,b,tcos,d,w) + do 164 i=1,mr + q(i,j) = .5*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i) + b(i) = q(i,1)+2.*q(i,nlast)+4.*q(i,j) + 164 continue + jr2 = 2*jr + call cosgen (jr,1,zero,zero,tcos) + do 165 i=1,jr + i1 = jr+i + i2 = jr+1-i + tcos(i1) = -tcos(i2) + 165 continue + call trix (jr2,0,mr,a,bb,c,b,tcos,d,w) + do 166 i=1,mr + q(i,j) = q(i,j)+b(i) + b(i) = q(i,1)+2.*q(i,j) + 166 continue + call cosgen (jr,1,half,zero,tcos) + call trix (jr,0,mr,a,bb,c,b,tcos,d,w) + do 167 i=1,mr + q(i,1) = .5*q(i,1)-q(i,jm1)+b(i) + 167 continue + go to 194 +! +! case of general n with nr = 3 . +! + 168 do 169 i=1,mr + b(i) = q(i,2) + q(i,2) = 0. + b2(i) = q(i,3) + b3(i) = q(i,1) + 169 continue + jr = 1 + i2r = 0 + j = 2 + go to 177 + 170 continue + do 171 i=1,mr + b(i) = .5*q(i,1)-q(i,jm1)+q(i,j) + 171 continue + if (nrod .ne. 0) go to 173 + do 172 i=1,mr + ii = ip+i + b(i) = b(i)+p(ii) + 172 continue + go to 175 + 173 do 174 i=1,mr + b(i) = b(i)+q(i,nlast)-q(i,jm2) + 174 continue + 175 continue + do 176 i=1,mr + t = .5*(q(i,j)-q(i,jm1)-q(i,jp1)) + q(i,j) = t + b2(i) = q(i,nlast)+t + b3(i) = q(i,1)+2.*t + 176 continue + 177 continue + k1 = kr+2*jr-1 + k2 = kr+jr + tcos(k1+1) = -2. + k4 = k1+3-istag + call cosgen (k2+istag-2,1,zero,fnum,tcos(k4)) + k4 = k1+k2+1 + call cosgen (jr-1,1,zero,one,tcos(k4)) + call merge (tcos,k1,k2,k1+k2,jr-1,0) + k3 = k1+k2+lr + call cosgen (jr,1,half,zero,tcos(k3+1)) + k4 = k3+jr+1 + call cosgen (kr,1,half,fden,tcos(k4)) + call merge (tcos,k3,jr,k3+jr,kr,k1) + if (lr .eq. 0) go to 178 + call cosgen (lr,1,half,fden,tcos(k4)) + call merge (tcos,k3,jr,k3+jr,lr,k3-lr) + call cosgen (kr,1,half,fden,tcos(k4)) + 178 k3 = kr + k4 = kr + call tri3 (mr,a,bb,c,k,b,b2,b3,tcos,d,w,w2,w3) + do 179 i=1,mr + b(i) = b(i)+b2(i)+b3(i) + 179 continue + tcos(1) = 2. + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + do 180 i=1,mr + q(i,j) = q(i,j)+b(i) + b(i) = q(i,1)+2.*q(i,j) + 180 continue + call cosgen (jr,1,half,zero,tcos) + call trix (jr,0,mr,a,bb,c,b,tcos,d,w) + if (jr .ne. 1) go to 182 + do 181 i=1,mr + q(i,1) = b(i) + 181 continue + go to 194 + 182 continue + do 183 i=1,mr + q(i,1) = .5*q(i,1)-q(i,jm1)+b(i) + 183 continue + go to 194 + 184 continue + if (n .ne. 2) go to 188 +! +! case n = 2 +! + do 185 i=1,mr + b(i) = q(i,1) + 185 continue + tcos(1) = 0. + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + do 186 i=1,mr + q(i,1) = b(i) + b(i) = 2.*(q(i,2)+b(i))*fistag + 186 continue + tcos(1) = -fistag + tcos(2) = 2. + call trix (2,0,mr,a,bb,c,b,tcos,d,w) + do 187 i=1,mr + q(i,1) = q(i,1)+b(i) + 187 continue + jr = 1 + i2r = 0 + go to 194 + 188 continue +! +! case of general n and nr = 2 . +! + do 189 i=1,mr + ii = ip+i + b3(i) = 0. + b(i) = q(i,1)+2.*p(ii) + q(i,1) = .5*q(i,1)-q(i,jm1) + b2(i) = 2.*(q(i,1)+q(i,nlast)) + 189 continue + k1 = kr+jr-1 + tcos(k1+1) = -2. + k4 = k1+3-istag + call cosgen (kr+istag-2,1,zero,fnum,tcos(k4)) + k4 = k1+kr+1 + call cosgen (jr-1,1,zero,one,tcos(k4)) + call merge (tcos,k1,kr,k1+kr,jr-1,0) + call cosgen (kr,1,half,fden,tcos(k1+1)) + k2 = kr + k4 = k1+k2+1 + call cosgen (lr,1,half,fden,tcos(k4)) + k3 = lr + k4 = 0 + call tri3 (mr,a,bb,c,k,b,b2,b3,tcos,d,w,w2,w3) + do 190 i=1,mr + b(i) = b(i)+b2(i) + 190 continue + tcos(1) = 2. + call trix (1,0,mr,a,bb,c,b,tcos,d,w) + do 191 i=1,mr + q(i,1) = q(i,1)+b(i) + 191 continue + go to 194 + 192 do 193 i=1,mr + b(i) = q(i,nlast) + 193 continue + go to 196 + 194 continue +! +! start back substitution. +! + j = nlast-jr + do 195 i=1,mr + b(i) = q(i,nlast)+q(i,j) + 195 continue + 196 jm2 = nlast-i2r + if (jr .ne. 1) go to 198 + do 197 i=1,mr + q(i,nlast) = 0. + 197 continue + go to 202 + 198 continue + if (nrod .ne. 0) go to 200 + do 199 i=1,mr + ii = ip+i + q(i,nlast) = p(ii) + 199 continue + ip = ip-mr + go to 202 + 200 do 201 i=1,mr + q(i,nlast) = q(i,nlast)-q(i,jm2) + 201 continue + 202 continue + call cosgen (kr,1,half,fden,tcos) + call cosgen (lr,1,half,fden,tcos(kr+1)) + if (lr .ne. 0) go to 204 + do 203 i=1,mr + b(i) = fistag*b(i) + 203 continue + 204 continue + call trix (kr,lr,mr,a,bb,c,b,tcos,d,w) + do 205 i=1,mr + q(i,nlast) = q(i,nlast)+b(i) + 205 continue + nlastp = nlast + 206 continue + jstep = jr + jr = i2r + i2r = i2r/2 + if (jr .eq. 0) go to 222 + go to (207,208),mixbnd + 207 jstart = 1+jr + go to 209 + 208 jstart = jr + 209 continue + kr = kr-jr + if (nlast+jr .gt. n) go to 210 + kr = kr-jr + nlast = nlast+jr + jstop = nlast-jstep + go to 211 + 210 continue + jstop = nlast-jr + 211 continue + lr = kr-jr + call cosgen (jr,1,half,zero,tcos) + do 221 j=jstart,jstop,jstep + jm2 = j-jr + jp2 = j+jr + if (j .ne. jr) go to 213 + do 212 i=1,mr + b(i) = q(i,j)+q(i,jp2) + 212 continue + go to 215 + 213 continue + do 214 i=1,mr + b(i) = q(i,j)+q(i,jm2)+q(i,jp2) + 214 continue + 215 continue + if (jr .ne. 1) go to 217 + do 216 i=1,mr + q(i,j) = 0. + 216 continue + go to 219 + 217 continue + jm1 = j-i2r + jp1 = j+i2r + do 218 i=1,mr + q(i,j) = .5*(q(i,j)-q(i,jm1)-q(i,jp1)) + 218 continue + 219 continue + call trix (jr,0,mr,a,bb,c,b,tcos,d,w) + do 220 i=1,mr + q(i,j) = q(i,j)+b(i) + 220 continue + 221 continue + nrod = 1 + if (nlast+i2r .le. n) nrod = 0 + if (nlastp .ne. nlast) go to 194 + go to 206 + 222 continue +! +! return storage requirements for p vectors. +! + w(1) = ipstor + return + end + + subroutine poisp2 (m,n,a,bb,c,q,idimq,b,b2,b3,w,w2,w3,d,tcos,p) +! +! subroutine to solve poisson equation with periodic boundary +! conditions. +! + integer m, n, idimq + BIGREAL a(*) ,bb(*) ,c(*) ,q(idimq,1) , & + & b(*) ,b2(*) ,b3(*) ,w(*) , & + & w2(*) ,w3(*) ,d(*) ,tcos(*) , & + & p(*) +! local variables + integer i, j, mr, nr, nrm1, nrmj, nrpj, ipstor, lh + BIGREAL s, t + + mr = m + nr = (n+1)/2 + nrm1 = nr-1 + if (2*nr .ne. n) go to 107 +! +! even number of unknowns +! + do 102 j=1,nrm1 + nrmj = nr-j + nrpj = nr+j + do 101 i=1,mr + s = q(i,nrmj)-q(i,nrpj) + t = q(i,nrmj)+q(i,nrpj) + q(i,nrmj) = s + q(i,nrpj) = t + 101 continue + 102 continue + do 103 i=1,mr + q(i,nr) = 2.*q(i,nr) + q(i,n) = 2.*q(i,n) + 103 continue + call poisd2 (mr,nrm1,1,a,bb,c,q,idimq,b,w,d,tcos,p) + ipstor = w(1) + call poisn2 (mr,nr+1,1,1,a,bb,c,q(1,nr),idimq,b,b2,b3,w,w2,w3,d, & + & tcos,p) + ipstor = max0(ipstor,int(w(1))) + do 105 j=1,nrm1 + nrmj = nr-j + nrpj = nr+j + do 104 i=1,mr + s = .5*(q(i,nrpj)+q(i,nrmj)) + t = .5*(q(i,nrpj)-q(i,nrmj)) + q(i,nrmj) = s + q(i,nrpj) = t + 104 continue + 105 continue + do 106 i=1,mr + q(i,nr) = .5*q(i,nr) + q(i,n) = .5*q(i,n) + 106 continue + go to 118 + 107 continue +! +! odd number of unknowns +! + do 109 j=1,nrm1 + nrpj = n+1-j + do 108 i=1,mr + s = q(i,j)-q(i,nrpj) + t = q(i,j)+q(i,nrpj) + q(i,j) = s + q(i,nrpj) = t + 108 continue + 109 continue + do 110 i=1,mr + q(i,nr) = 2.*q(i,nr) + 110 continue + lh = nrm1/2 + do 112 j=1,lh + nrmj = nr-j + do 111 i=1,mr + s = q(i,j) + q(i,j) = q(i,nrmj) + q(i,nrmj) = s + 111 continue + 112 continue + call poisd2 (mr,nrm1,2,a,bb,c,q,idimq,b,w,d,tcos,p) + ipstor = w(1) + call poisn2 (mr,nr,2,1,a,bb,c,q(1,nr),idimq,b,b2,b3,w,w2,w3,d, & + & tcos,p) + ipstor = max0(ipstor,int(w(1))) + do 114 j=1,nrm1 + nrpj = nr+j + do 113 i=1,mr + s = .5*(q(i,nrpj)+q(i,j)) + t = .5*(q(i,nrpj)-q(i,j)) + q(i,nrpj) = t + q(i,j) = s + 113 continue + 114 continue + do 115 i=1,mr + q(i,nr) = .5*q(i,nr) + 115 continue + do 117 j=1,lh + nrmj = nr-j + do 116 i=1,mr + s = q(i,j) + q(i,j) = q(i,nrmj) + q(i,nrmj) = s + 116 continue + 117 continue + 118 continue +! +! return storage requirements for p vectors. +! + w(1) = ipstor + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +! june 1993 BIGREAL stuff added +!----------------------------------------------------------------------- + end + diff --git a/Utility/geodesic_dist.F b/Utility/geodesic_dist.F new file mode 100644 index 0000000..3a94d04 --- /dev/null +++ b/Utility/geodesic_dist.F @@ -0,0 +1,195 @@ + subroutine geodesic_dist (lon1,lat1,lon2,lat2,flag,dist,alpha) +! +!======================================================================= +! == +! Inverse, non-iterative solutions for distance and geodesic azimuth == +! between two points on the ellipsoid (The Earth) from the equations,== +! second order in spheroidal flatttening, given by: == +! == +! Sodano , E.M., and T. Robinson, 1963: Direct and inverse solutions == +! of geodesics, Army Map Service Technical Report No. 7, AD 657591. == +! == +! On input: Longitude is positive to the east and negative to the == +! west. Latitude is positive to the north and negative == +! to the south. == +! == +! LON1 Longitude point 1 (decimal degrees, real*8) == +! LAT1 Latitude point 1 (decimal degrees, real*8) == +! LON2 Longitude point 2 (decimal degrees, real*8) == +! LAT2 Latitude point 2 (decimal degrees, real*8) == +! FLAG flag for distance units on output (integer) == +! == +! On output: == +! == +! GALPHA Geodesic azimuth from point 1 to point 2 clockwise from == +! North (decimal degrees, real*8) == +! GDIST Geodesic distance between point 1 and point 2 (real*8) == +! == +! Units of distance == +! == +! Flag Units == +! ------ ------- == +! 1 Meters == +! 2 Nautical Miles == +! 3 Feet == +! 4 Kilometers == +! 5 Statute Mile == +! == +!======================================================================= +! +#include "griddefs.h" +! +!----------------------------------------------------------------------- +! Define local data +!----------------------------------------------------------------------- +! + logical first + integer flag + BIGREAL alpha, dist, lat1, lat2, lon1, lon2, r_lat1, r_lat2, & + & delta, l, beta1, beta2, a, b, c, ct, st, t, m, sob, & + & lambda, cott, adist + BIGREAL c0, c1, c4, c90, c180, c360, deg2rad, pi, rad2deg, smin + parameter (c0=0.d0, c1=1.0d0, c4=4.0d0, c90=90.0d0, & + & c180=180.0d0, c360=360.0d0 ) +#if ELLIPSOID + BIGREAL f, smaj, q, w, x, y, z, p5, p0625, p125, p25, c5 + parameter (c5=5.0d0, p5=0.5d0, p25=0.25d0, p125=0.125d0, & + & p0625=0.0625d0 ) + save f, smaj +#endif /* ELLIPSOID */ + save deg2rad, pi, rad2deg, smin + data first /.true./ +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +! Define parameters on first pass (SMIN: Ellipsoid semi-minor axis in +! meters; SMAJ: Ellipsoid semi-major axis in meters; F: spheroidal +! flattening). +! + if (first) then + smin = 6356750.52d0 +#if ELLIPSOID + smaj = 6378135.0d0 + f = c1-(smin/smaj) +#endif /* ELLIPSOID */ + pi = c4*atan(c1) + deg2rad = pi/c180 + rad2deg = c180/pi + first = .false. + endif +! +! Determine proper longitudinal shift. +! + delta = lon2-lon1 + l = abs(delta) + if (l.ge.c180) l = c360-abs(lon1-lon2) +! +! Convert Decimal degrees to radians. +! + r_lat1 = lat1*deg2rad + r_lat2 = lat2*deg2rad + l = l*deg2rad +! +! Calculate S/Bo subformulas. +! +#if ELLIPSOID + beta1 = atan(tan(r_lat1)*(c1-f)) + beta2 = atan(tan(r_lat2)*(c1-f)) + a = sin(beta1)*sin(beta2) + b = cos(beta1)*cos(beta2) + ct = a+b*cos(l) + st = sqrt(((sin(l)*cos(beta2))**2)+(((sin(beta2)*cos(beta1)) & + & -(sin(beta1)*cos(beta2)*cos(l)))**2)) + t = asin(st) + c = (b*sin(l))/st + m = c1-(c*c) +#else + beta1 = r_lat1 + beta2 = r_lat2 + a = sin(beta1)*sin(beta2) + b = cos(beta1)*cos(beta2) + ct = a+b*cos(l) + st = sqrt(((sin(l)*cos(beta2))**2)+(((sin(beta2)*cos(beta1)) & + & -(sin(beta1)*cos(beta2)*cos(l)))**2)) + t = asin(st) + c = (b*sin(l))/st + m = c1-(c*c) +#endif /* ELLIPSOID */ +! +! Calculate S/Bo term. +! +#if ELLIPSOID + q = f+(f*f) + z = f*f*p5 + x = f*f*p0625 + y = f*f*p125 + w = f*f*p25 +! + sob = ((c1+q)*t)+(a*((q*st)-(z*(t*t)*(c1/sin(t))))) & + & +(m*(((-q*p5)*t)-((q*p5)*st*ct)+(z*(t*t)*(c1/tan(t))))) & + & +((a**2)*(-z*st*ct)) & + & +((m**2)*((x*t)+(x*st*ct)-(z*(t*t)*(c1/tan(t))) & + & -(y*st*(ct*ct*ct)))) & + & +((a*m)*((z*(t*t)*(c1/sin(t)))+(z*st*(ct*ct)))) +#else + sob = t +#endif /* ELLIPSOID */ +! +! Compute geodesic azimuth from point 1 to point 2 clockwise from +! North, alpha. +! +#if ELLIPSOID + lambda = q*t+a*(-z*st-f*f*t*t/sin(t)) & + & +m*(-c5*w*t+w*st*cos(t)+f*f*t*t/tan(t)) + lambda = c*lambda+l +#else + lambda = l +#endif /* ELLIPSOID */ + if (lambda.eq.c0) then + if (lat1.lt.lat2) alpha = c0 + if (lat1.gt.lat2) alpha = c180 + goto 1 + endif +! + cott = (sin(beta2)*cos(beta1)- & + & cos(lambda)*sin(beta1)*cos(beta2))/ & + & (sin(lambda)*cos(beta2)) + if (cott.eq.c0) then + alpha = c90 + else + alpha = atan(c1/cott)*rad2deg + endif + +! Compute heading from point#1 to point#2 clockwise from north + + if (delta .gt. 0.d0) then + if (cott .gt. 0.d0) then + alpha = alpha ! first quadrant + else if (cott .lt. 0.d0) then + alpha = 180.d0 + alpha ! second quadrant + end if + end if + if (delta .lt. 0.d0) then + if (cott .lt. 0.d0) then + alpha = 180.d0 - alpha ! third quadrant + else if (cott .gt. 0.d0) then + alpha = 360.d0 - alpha ! fourth quadrant + end if + end if + +! Calculate distance from point 1 to point 2 + + 1 adist = sob * smin + +! Check flag for proper output units + + if (flag .eq. 1) dist = adist ! meters + if (flag .eq. 2) dist = adist * 5.396d-4 ! nautical miles + if (flag .eq. 3) dist = adist * 3.281d0 ! feed + if (flag .eq. 4) dist = adist * 1.d-3 ! kilometers + if (flag .eq. 5) dist = adist * 6.214d-4 ! statute mile + + return + end diff --git a/Utility/get_date.F b/Utility/get_date.F new file mode 100644 index 0000000..9e5c0bb --- /dev/null +++ b/Utility/get_date.F @@ -0,0 +1,287 @@ +#include "griddefs.h" + subroutine get_date (date_str) +! +!======================================================================= +! Copyright (c) 1996 Rutgers University === +!======================================================================= +! === +! This routine gets todays date, day of the week and time called === +! (default month & weekday are December & Saturday respectively). === +! It uses SUN intrinsic date routine by default. === +! === +! On Output: === +! === +! date_str Concatenated string for the day of the week, date === +! (month,day,year), and time (12hr clock) of day === +! (hour:min:sec). === +! === +#ifdef cray +! Calls: day_code === +# else +! Calls: none === +#endif +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + integer dstat, half, hour, iday, imon, len1, len2, len3, min, & + & nday, sec, tstat, year + integer lday(31), lmonth(12) +#if defined cray + integer century + parameter (century=1900) + character*8 tstring +#elif defined sun + character*3 day3, mon + character*28 fdate, tmpday +#elif AIX + character*3 day3, mon + character*28 tmpday +#endif + character*3 ampm(0:1) + character*9 day(0:6),month(12) + character*11 ctime + character*18 today + character*20 fmt + character*44 date_str,wkday + data ampm /' AM',' PM'/ + data day /'Sunday','Monday','Tuesday','Wednesday','Thursday', & + & 'Friday','Saturday'/ + data lmonth, lday /7,8,5,5,3,4,4,6,9,7,8,8,9*1,22*2/ + data month /'January','February','March','April','May','June', & + & 'July','August','September','October','November', & + & 'December'/ +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Get weekday, date and time in short format, then extract this +! information. +!----------------------------------------------------------------------- +! +#if defined vax + dstat=0 + call idate (imon,nday,year) + year=year+century + call time (tstring) + read(tstring,'(i2,1x,i2,1x,i2)',iostat=tstat) hour, min, sec + if(tstat.ne.0) ctime=tstring +#elif defined cray + write(tstring,'(a8)') date() + read(tstring,'(i2,1x,i2,1x,i2)',iostat=dstat) imon, nday, year + year=year+century + if(dstat.ne.0) then + wkday=tstring + today=' ' + endif + write(tstring,'(a8)') clock() + read(tstring,'(i2,1x,i2,1x,i2)',iostat=tstat) hour, min, sec + if(tstat.ne.0) ctime=tstring +#elif defined sun + tmpday=fdate() + read(tmpday,'(a3,1x,a3,1x,i2)',iostat=dstat) day3, mon, nday + read(tmpday,'(11x,i2,1x,i2,1x,i2)',iostat=tstat) hour, min, sec + tstat=max(abs(dstat),abs(tstat)) + read(tmpday,'(20x,i4)',iostat=dstat) year + if((dstat.ne.0).or.(tstat.ne.0)) then + dstat=1 + tstat=1 + wkday=tmpday + today=' ' + ctime=' ' + endif +#elif AIX + call fdate_(tmpday) + read(tmpday,'(a3,1x,a3,1x,i2)',iostat=dstat) day3, mon, nday + read(tmpday,'(11x,i2,1x,i2,1x,i2)',iostat=tstat) hour, min, sec + tstat=max(abs(dstat),abs(tstat)) + read(tmpday,'(20x,i4)',iostat=dstat) year + if((dstat.ne.0).or.(tstat.ne.0)) then + dstat=1 + tstat=1 + wkday=tmpday + today=' ' + ctime=' ' + endif +#else + dstat=1 + tstat=1 + wkday=' ' + today=' ' + ctime=' ' +#endif +! +!----------------------------------------------------------------------- +! Convert from 24 hour clock to 12 hour AM/PM clock. +!----------------------------------------------------------------------- +! + if (tstat.eq.0) then + half=hour/12 + hour=hour-half*12 + if (hour.eq.0) hour=12 + if (half.eq.2) half=0 + endif +! + if (dstat.eq.0) then +! +#if defined vax || defined cray +!----------------------------------------------------------------------- +! Get index for the day of the week. +!----------------------------------------------------------------------- +! + call day_code (imon,nday,year,iday) +#elif defined sun || AIX +!----------------------------------------------------------------------- +! Loop to find full day name by comparing DAY3 with first 3 letters +! of day. +!----------------------------------------------------------------------- +! + iday=0 + do while ((day3.ne.day(iday)(1:3)).and.(iday.lt.6)) + iday=iday+1 + enddo +! +!----------------------------------------------------------------------- +! Loop to find full month name by comparing MON with first 3 letters +! of month. +!----------------------------------------------------------------------- +! + imon=1 + do while ((mon.ne.month(imon)(1:3)).and.(imon.lt.12)) + imon=imon+1 + enddo +#endif +! +!----------------------------------------------------------------------- +! Construct date, time and day of the week output string. +!----------------------------------------------------------------------- +! + write(fmt,10) lmonth(imon), lday(nday) + 10 format('(a',i1,',1x,i',i1,',1h,,1x,i4)') + write(today,fmt) month(imon),nday,year + wkday=day(iday) + endif + if(tstat.eq.0) then + write(ctime,20) hour, min, sec, ampm(half) + 20 format(i2,':',i2.2,':',i2.2,a3) + endif +! +! Concatenate date string. +! + date_str=TRIM(wkday) + if (LEN_TRIM(today).gt.0) then + date_str=date_str//' - '//TRIM(today) + endif + if (LEN_TRIM(ctime).gt.0) then + date_str=date_str//' - '//TRIM(ctime) + endif + return + end + + subroutine day_code (month,day,year,code) +! +!======================================================================= +! Copyright (c) 1996 Rutgers University === +!======================================================================= +! === +! This subroutine computes a code for the day of the week, given === +! the date. This code is good for date after: === +! === +! January 1, 1752 AD === +! === +! the year the Gregorian calander was adopted in Britian and the === +! American colonies. === +! === +! On Input: === +! === +! month The month, 1=January, 2=February, ... (integer). === +! day The day of the month (integer). === +! year The year, including the century (integer). === +! === +! On Output: === +! === +! code A code for the corresponding day of the week === +! (integer): === +! code = 0 => Sunday === +! code = 1 => Monday === +! code = 2 => Tuesday === +! code = 3 => Wednesday === +! code = 4 => Thursday === +! code = 5 => Friday === +! code = 6 => Saturday === +! === +! Calls: none === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical leap_flag + integer base_cen, base_qcen, base_qyear, base_year, bym1_dec31, & + & code, day,feb_end, i, leap, month, no_day, no_yr, nqy,nyc, & + & nyqc, year + integer month_day(12) + parameter (base_cen=1700, base_qcen=1600, base_qyear=1748, & + & base_year=1752, bym1_dec31=5, feb_end=59) + data month_day /31,28,31,30,31,30,31,31,30,31,30,31/ +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Compute the number of years since the base year, the number of +! years since the beginning of the base century and the number of +! years since the beginning of the base 400 year. +!----------------------------------------------------------------------- +! + no_yr=year-base_year + nqy=year-base_qyear + nyc=year-base_cen + nyqc=year-base_qcen +! +!----------------------------------------------------------------------- +! Compute the number of leapdays in that time. Determine if this +! is a leap year. +!----------------------------------------------------------------------- +! + leap=nqy/4-nyc/100+nyqc/400 + leap_flag=((mod(nqy,4).eq.0).and.(mod(nyc,100).ne.0)).or. & + & (mod(nyqc,400).eq.0) +! +!----------------------------------------------------------------------- +! Compute the number of days this year. The leap year corrections +! are: +! Jan. 1 - Feb. 28 Have not had the leap day counted above. +! Feb.29 Counting leap day twice. +!----------------------------------------------------------------------- +! + no_day=day + do i=1,month-1 + no_day=no_day+month_day(i) + enddo + if (leap_flag.and.(no_day.le.feb_end)) no_day=no_day-1 + if (leap_flag.and.(month.eq.2).and.(day.eq.29)) no_day=no_day-1 +! +!----------------------------------------------------------------------- +! Compute the total number of days since Jan. 1 of the base year, +! exclusive of the 364 day per year which represent an even 52 +! weeks. Actually, only need to do the addition mod 7. +!----------------------------------------------------------------------- +! + no_day=mod(no_day,7)+mod(leap,7)+mod(no_yr,7)+bym1_dec31 +! +!----------------------------------------------------------------------- +! Get the day of the week code. +!----------------------------------------------------------------------- +! + code=mod(no_day,7) + return + end diff --git a/Utility/get_h.F b/Utility/get_h.F new file mode 100644 index 0000000..520de09 --- /dev/null +++ b/Utility/get_h.F @@ -0,0 +1,103 @@ +#include "griddefs.h" + subroutine get_h +! +!======================================================================= +! === +! This subroutine reads bathymetry information from grid NetCDF === +! file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +# include "bathy.h" +# include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical gothraw + integer grdhrid, i, level + integer count(3), start(3) +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Inquire about the contents of grid NetCDF file: Inquire about +! the dimensions and variables. Check for consistency. +!----------------------------------------------------------------------- +! + call opencdf (TRIM(gridfile)) + if (bathsize .lt. 1) then + write(stdout,40) TRIM(gridfile) + call crash ('GET_H',1) + endif +! +! Find out which level to read. +! + print *, 'There are ', bathsize, ' bathymetries.' + print *, 'Which level would you like to read?' + read (5,*) level + if (level .lt. 1 .or. level .gt. bathsize) then + call crash('Illegal level', level) + endif +! +! Scan variable list from input NetCDF and check for raw bathymetry. +! + do i=1,nvars + if (TRIM(varnam(i)).eq.'hraw') then + grdhrid=i + gothraw=.true. + endif + enddo +! +! Terminate execution if essential grid variables are not found. +! + if (.not.gothraw) then + write(stdout,10) 'hraw', TRIM(gridfile) + call crash ('GET_H',1) + endif +! +! Open grid NetCDF file for reading. +! + rcode=nf90_open(TRIM(gridfile),nf90_nowrite,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,20) TRIM(gridfile) + call crash ('GET_H',1) + endif +! +! Read in last bathymetry in hraw. +! + start(1)=1 + count(1)=Lp + start(2)=1 + count(2)=Mp + start(3)=level + count(3)=1 + if (gothraw) then + rcode = nf90_get_var(ncgridid,grdhrid,h,start,count) + if (rcode.ne.0) then + write(stdout,30) 'hraw', TRIM(gridfile) + call crash ('GET_H',1) + endif + endif +! +! Close file +! + rcode = nf90_close(ncgridid) +! + 10 format(/' GET_H - unable to find grid variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 20 format(/' GET_H - unable to open grid NetCDF file: ',a) + 30 format(/' GET_H - error while reading variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 40 format(/' GET_H - no bathymetries have been written yet: ',a) + return + end diff --git a/Utility/get_lat.F b/Utility/get_lat.F new file mode 100644 index 0000000..9fecb54 --- /dev/null +++ b/Utility/get_lat.F @@ -0,0 +1,191 @@ +#include "griddefs.h" + subroutine get_lat +! +!======================================================================= +! === +! This subroutine reads lat/lon information from grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +# include "bathy.h" +# include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical gotlatp, gotlonp, gotlatr, gotlonr, gotlatu, gotlonu, & + & gotlatv, gotlonv + integer grdlapid, grdlopid, grdlauid, grdlouid, grdlavid, & + & grdlovid, grdlarid, grdlorid, i +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Inquire about the contents of SCRUM grid NetCDF file: Inquire about +! the dimensions and variables. Check for consistency. +!----------------------------------------------------------------------- +! + call opencdf (TRIM(gridfile)) +! +! Scan variable list from input NetCDF and check for latitude and +! longitude variables. +! + do i=1,nvars + if (TRIM(varnam(i)).eq.'lat_rho') then + grdlarid=i + gotlatr=.true. + elseif (TRIM(varnam(i)).eq.'lon_rho') then + grdlorid=i + gotlonr=.true. + elseif (TRIM(varnam(i)).eq.'lat_psi') then + grdlapid=i + gotlatp=.true. + elseif (TRIM(varnam(i)).eq.'lon_psi') then + grdlopid=i + gotlonp=.true. + elseif (TRIM(varnam(i)).eq.'lat_u') then + grdlauid=i + gotlatu=.true. + elseif (TRIM(varnam(i)).eq.'lon_u') then + grdlouid=i + gotlonu=.true. + elseif (TRIM(varnam(i)).eq.'lat_v') then + grdlavid=i + gotlatv=.true. + elseif (TRIM(varnam(i)).eq.'lon_v') then + grdlovid=i + gotlonv=.true. + endif + enddo +! +! Terminate execution if essential grid variables are not found. +! + if (.not.gotlatr) then + write(stdout,10) 'lat_rho', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlonr) then + write(stdout,10) 'lon_rho', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlatp) then + write(stdout,10) 'lat_psi', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlonp) then + write(stdout,10) 'lon_psi', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlatu) then + write(stdout,10) 'lat_u', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlonu) then + write(stdout,10) 'lon_u', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlatv) then + write(stdout,10) 'lat_v', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + if (.not.gotlonv) then + write(stdout,10) 'lon_v', TRIM(gridfile) + call crash ('GET_LAT',1) + endif +! +! Open grid NetCDF file for reading. +! + rcode = nf90_open(TRIM(gridfile),nf90_nowrite,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,20) TRIM(gridfile) + call crash ('GET_LAT',1) + endif +! +! Read in lat,lon coordinates at RHO-points. +! + if (gotlatr) then + rcode = nf90_get_var(ncgridid,grdlarid,lat_rho) + if (rcode.ne.0) then + write(stdout,30) 'lat_rho', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif + if (gotlonr) then + rcode = nf90_get_var(ncgridid,grdlorid,lon_rho) + if (rcode.ne.0) then + write(stdout,30) 'lon_rho', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif +! +! Read in lat,lon coordinates at PSI-points. +! + if (gotlatp) then + rcode = nf90_get_var(ncgridid,grdlapid,lat_psi) + if (rcode.ne.0) then + write(stdout,30) 'lat_psi', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif + if (gotlonp) then + rcode = nf90_get_var(ncgridid,grdlopid,lon_psi) + if (rcode.ne.0) then + write(stdout,30) 'lon_psi', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif +! +! Read in lat,lon coordinates at U-points. +! + if (gotlatu) then + rcode = nf90_get_var(ncgridid,grdlauid,lat_u) + if (rcode.ne.0) then + write(stdout,30) 'lat_u', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif + if (gotlonu) then + rcode = nf90_get_var(ncgridid,grdlouid,lon_u) + if (rcode.ne.0) then + write(stdout,30) 'lon_u', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif +! +! Read in lat,lon coordinates at V-points. +! + if (gotlatv) then + rcode = nf90_get_var(ncgridid,grdlavid,lat_v) + if (rcode.ne.0) then + write(stdout,30) 'lat_v', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif + if (gotlonv) then + rcode = nf90_get_var(ncgridid,grdlovid,lon_v) + if (rcode.ne.0) then + write(stdout,30) 'lon_v', TRIM(gridfile) + call crash ('GET_LAT',1) + endif + endif +! +! Close file +! + rcode = nf90_close(ncgridid) +! + 10 format(/' GET_LAT - unable to find grid variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 20 format(/' GET_LAT - unable to open grid NetCDF file: ',a) + 30 format(/' GET_LAT - error while reading variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + return + end diff --git a/Utility/get_mn.F b/Utility/get_mn.F new file mode 100644 index 0000000..e286d3e --- /dev/null +++ b/Utility/get_mn.F @@ -0,0 +1,98 @@ +#include "griddefs.h" + subroutine get_mn +! +!======================================================================= +! === +! This subroutine reads grid metric information from grid NetCDF === +! file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +# include "bathy.h" +# include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical gotpm, gotpn + integer grdpmid, grdpnid, i +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Inquire about the contents of grid NetCDF file: Inquire about +! the dimensions and variables. Check for consistency. +!----------------------------------------------------------------------- +! + call opencdf(TRIM(gridfile)) +! +! Scan variable list from input NetCDF and check for pm and pn +! variables. +! + do i=1,nvars + if (TRIM(varnam(i)).eq.'pm') then + grdpmid=i + gotpm=.true. + endif + if (TRIM(varnam(i)).eq.'pn') then + grdpnid=i + gotpn=.true. + endif + enddo +! +! Terminate execution if essential grid variables are not found. +! + if (.not.gotpm) then + write(stdout,10) 'pm', TRIM(gridfile) + call crash ('GET_MN',1) + endif + if (.not.gotpn) then + write(stdout,10) 'pn', TRIM(gridfile) + call crash ('GET_MN',1) + endif +! +! Open grid NetCDF file for reading. +! + rcode=nf90_open(TRIM(gridfile),nf90_nowrite,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,20) TRIM(gridfile) + call crash ('GET_MN',1) + endif +! +! Read in grid metrics. +! + if (gotpm) then + rcode = nf90_get_var(ncgridid,grdpmid,pm) + if (rcode.ne.0) then + write(stdout,30) 'pm', TRIM(gridfile) + call crash ('GET_MN',1) + endif + endif + if (gotpn) then + rcode = nf90_get_var(ncgridid,grdpnid,pn) + if (rcode.ne.0) then + write(stdout,30) 'pn', TRIM(gridfile) + call crash ('GET_MN',1) + endif + endif +! +! Close file +! + rcode = nf90_close(ncgridid) +! + 10 format(/' GET_MN - unable to find grid variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 20 format(/' GET_MN - unable to open grid NetCDF file: ',a) + 30 format(/' GET_MN - error while reading variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + return + end diff --git a/Utility/get_rmask.F b/Utility/get_rmask.F new file mode 100644 index 0000000..fb5cf68 --- /dev/null +++ b/Utility/get_rmask.F @@ -0,0 +1,81 @@ +#include "griddefs.h" + subroutine get_rmask +! +!======================================================================= +! === +! This subroutine reads mask information from grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +# include "bathy.h" +# include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical gotrmask + integer grdrmaskid, i +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Inquire about the contents of grid NetCDF file: Inquire about +! the dimensions and variables. Check for consistency. +!----------------------------------------------------------------------- +! + call opencdf (TRIM(gridfile)) +! +! Scan variable list from input NetCDF and check for rho mask. +! + do i=1,nvars + if (TRIM(varnam(i)).eq.'mask_rho') then + grdrmaskid=i + gotrmask=.true. + endif + enddo +! +! Terminate execution if essential grid variables are not found. +! + if (.not.gotrmask) then + write(stdout,10) 'mask_rho', TRIM(gridfile) + call crash ('GET_RMASK',1) + endif +! +! Open grid NetCDF file for reading. +! + rcode=nf90_open(TRIM(gridfile),nf90_nowrite,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,20) TRIM(gridfile) + call crash ('GET_RMASK',1) + endif +! +! Read in rho mask. +! + if (gotrmask) then + rcode = nf90_get_var(ncgridid,grdrmaskid,mask_rho) + if (rcode.ne.0) then + write(stdout,30) 'mask_rho', TRIM(gridfile) + call crash ('GET_RMASK',1) + endif + endif +! +! Close file +! + rcode = nf90_close(ncgridid) +! + 10 format(/' GET_RMASK - unable to find grid variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 20 format(/' GET_RMASK - unable to open grid NetCDF file: ',a) + 30 format(/' GET_RMASK - error while reading variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + return + end diff --git a/Utility/get_xy.F b/Utility/get_xy.F new file mode 100644 index 0000000..27fb4af --- /dev/null +++ b/Utility/get_xy.F @@ -0,0 +1,190 @@ +#include "griddefs.h" + subroutine get_xy +! +!======================================================================= +! === +! This subroutine reads x,y grid information from grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +# include "bathy.h" +# include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + logical gotxp, gotyp, gotxu, gotyu, gotxv, gotyv, & + & gotxr, gotyr + integer grdxpid, grdypid, grdxuid, grdyuid, grdxvid, grdyvid, & + & grdxrid, grdyrid, i +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +!----------------------------------------------------------------------- +! Inquire about the contents of SCRUM grid NetCDF file: Inquire about +! the dimensions and variables. Check for consistency. +!----------------------------------------------------------------------- +! + call opencdf (TRIM(gridfile)) +! +! Scan variable list from input NetCDF and check for x,y variables. +! + do i=1,nvars + if (TRIM(varnam(i)).eq.'x_rho') then + grdxrid=i + gotxr=.true. + elseif (TRIM(varnam(i)).eq.'y_rho') then + grdyrid=i + gotyr=.true. + elseif (TRIM(varnam(i)).eq.'x_psi') then + grdxpid=i + gotxp=.true. + elseif (TRIM(varnam(i)).eq.'y_psi') then + grdypid=i + gotyp=.true. + elseif (TRIM(varnam(i)).eq.'x_u') then + grdxuid=i + gotxu=.true. + elseif (TRIM(varnam(i)).eq.'y_u') then + grdyuid=i + gotyu=.true. + elseif (TRIM(varnam(i)).eq.'x_v') then + grdxvid=i + gotxv=.true. + elseif (TRIM(varnam(i)).eq.'y_v') then + grdyvid=i + gotyv=.true. + endif + enddo +! +! Terminate execution if essential grid variables are not found. +! + if (.not.gotxr) then + write(stdout,10) 'xr', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotyr) then + write(stdout,10) 'yr', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotxp) then + write(stdout,10) 'xp', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotyp) then + write(stdout,10) 'yp', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotxu) then + write(stdout,10) 'xu', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotyu) then + write(stdout,10) 'yu', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotxv) then + write(stdout,10) 'xv', TRIM(gridfile) + call crash ('GET_XY',1) + endif + if (.not.gotyv) then + write(stdout,10) 'yv', TRIM(gridfile) + call crash ('GET_XY',1) + endif +! +! Open grid NetCDF file for reading. +! + rcode = nf90_open(TRIM(gridfile),nf90_nowrite,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,20) TRIM(gridfile) + call crash ('GET_XY',1) + endif +! +! Read in (x,y) coordinates at RHO-points. +! + if (gotxr) then + rcode = nf90_get_var(ncgridid,grdxrid,xr) + if (rcode.ne.0) then + write(stdout,30) 'x_rho', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif + if (gotyr) then + rcode = nf90_get_var(ncgridid,grdyrid,yr) + if (rcode.ne.0) then + write(stdout,30) 'y_rho', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif +! +! Read in (x,y) coordinates at PSI-points. +! + if (gotxp) then + rcode = nf90_get_var(ncgridid,grdxpid,xp) + if (rcode.ne.0) then + write(stdout,30) 'x_psi', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif + if (gotyp) then + rcode = nf90_get_var(ncgridid,grdypid,yp) + if (rcode.ne.0) then + write(stdout,30) 'y_psi', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif +! +! Read in (x,y) coordinates at U-points. +! + if (gotxu) then + rcode = nf90_get_var(ncgridid,grdxuid,xu) + if (rcode.ne.0) then + write(stdout,30) 'x_u', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif + if (gotyu) then + rcode = nf90_get_var(ncgridid,grdyuid,yu) + if (rcode.ne.0) then + write(stdout,30) 'y_u', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif +! +! Read in (x,y) coordinates at V-points. +! + if (gotxv) then + rcode = nf90_get_var(ncgridid,grdxvid,xv) + if (rcode.ne.0) then + write(stdout,30) 'x_v', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif + if (gotyv) then + rcode = nf90_get_var(ncgridid,grdyvid,yv) + if (rcode.ne.0) then + write(stdout,30) 'y_v', TRIM(gridfile) + call crash ('GET_XY',1) + endif + endif +! +! Close file +! + rcode = nf90_close(ncgridid) +! + 10 format(/' GET_XY - unable to find grid variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + 20 format(/' GET_XY - unable to open grid NetCDF file: ',a) + 30 format(/' GET_XY - error while reading variable: ',a, & + & /12x,'in grid NetCDF file: ',a) + return + end diff --git a/Utility/gnbnaux.F b/Utility/gnbnaux.F new file mode 100644 index 0000000..33111dd --- /dev/null +++ b/Utility/gnbnaux.F @@ -0,0 +1,337 @@ +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! package gnbnaux +! +! latest revision november 1988 +! +! purpose to provide auxiliary routines for fishpak +! entries genbun and poistg. +! +! usage there are no user entries in this package. +! the routines in this package are not intended +! to be called by users, but rather by routines +! in packages genbun and poistg. +! +! special conditions none +! +! i/o none +! +! precision single +! +! required library comf from fishpak +! files +! +! language fortran +! +! history written in 1979 by roland sweet of ncar's +! scientific computing division. made available +! on ncar's public libraries in january, 1980. +! +! portability fortran 77 +! ******************************************************************** +#include "griddefs.h" + subroutine cosgen (n,ijump,fnum,fden,a) + integer n, ijump + BIGREAL fnum, fden, a(*) + +! local variables + BIGREAL pi, dum, pimach, pibyn, x, y + integer i, k, k1, k2, k3, k4, k5, np1 +! +! +! this subroutine computes required cosine values in ascending +! order. when ijump .gt. 1 the routine computes values +! +! 2*cos(j*pi/l) , j=1,2,...,l and j .ne. 0(mod n/ijump+1) +! +! where l = ijump*(n/ijump+1). +! +! +! when ijump = 1 it computes +! +! 2*cos((j-fnum)*pi/(n+fden)) , j=1, 2, ... ,n +! +! where +! fnum = 0.5, fden = 0.0, for regular reduction values +! fnum = 0.0, fden = 1.0, for b-r and c-r when istag = 1 +! fnum = 0.0, fden = 0.5, for b-r and c-r when istag = 2 +! fnum = 0.5, fden = 0.5, for b-r and c-r when istag = 2 +! in poisn2 only. +! +! + pi = pimach(dum) + if (n .eq. 0) go to 105 + if (ijump .eq. 1) go to 103 + k3 = n/ijump+1 + k4 = k3-1 + pibyn = pi/float(n+ijump) + do 102 k=1,ijump + k1 = (k-1)*k3 + k5 = (k-1)*k4 + do 101 i=1,k4 + x = k1+i + k2 = k5+i + a(k2) = -2.*cos(x*pibyn) + 101 continue + 102 continue + go to 105 + 103 continue + np1 = n+1 + y = pi/(float(n)+fden) + do 104 i=1,n + x = float(np1-i)-fnum + a(i) = 2.*cos(x*y) + 104 continue + 105 continue + return + end + + subroutine merge (tcos,i1,m1,i2,m2,i3) + integer i1, m1, i2, m2, i3 + BIGREAL tcos(*) +! +! this subroutine merges two ascending strings of numbers in the +! array tcos. the first string is of length m1 and starts at +! tcos(i1+1). the second string is of length m2 and starts at +! tcos(i2+1). the merged string goes into tcos(i3+1). +! +! local variables + integer j, k, l, m, j1, j2 + BIGREAL x, y +! + j1 = 1 + j2 = 1 + j = i3 + if (m1 .eq. 0) go to 107 + if (m2 .eq. 0) go to 104 + 101 j = j+1 + l = j1+i1 + x = tcos(l) + l = j2+i2 + y = tcos(l) + if (x-y) 102,102,103 + 102 tcos(j) = x + j1 = j1+1 + if (j1 .gt. m1) go to 106 + go to 101 + 103 tcos(j) = y + j2 = j2+1 + if (j2 .le. m2) go to 101 + if (j1 .gt. m1) go to 109 + 104 k = j-j1+1 + do 105 j=j1,m1 + m = k+j + l = j+i1 + tcos(m) = tcos(l) + 105 continue + go to 109 + 106 continue + if (j2 .gt. m2) go to 109 + 107 k = j-j2+1 + do 108 j=j2,m2 + m = k+j + l = j+i2 + tcos(m) = tcos(l) + 108 continue + 109 continue + return + end + + subroutine trix (idegbr,idegcr,m,a,b,c,y,tcos,d,w) +! +! subroutine to solve a system of linear equations where the +! coefficient matrix is a rational function in the matrix given by +! tridiagonal ( . . . , a(i), b(i), c(i), . . . ). +! + integer idegbr, idegcr, m + BIGREAL a(*) ,b(*) ,c(*) ,y(*) , & + & tcos(*) ,d(*) ,w(*) + +! local variables + integer i, k, l, ip, lint, mm1, ifb, ifc + BIGREAL x, xx, z + + mm1 = m-1 + ifb = idegbr+1 + ifc = idegcr+1 + l = ifb/ifc + lint = 1 + do 108 k=1,idegbr + x = tcos(k) + if (k .ne. l) go to 102 + i = idegbr+lint + xx = x-tcos(i) + do 101 i=1,m + w(i) = y(i) + y(i) = xx*y(i) + 101 continue + 102 continue + z = 1./(b(1)-x) + d(1) = c(1)*z + y(1) = y(1)*z + do 103 i=2,mm1 + z = 1./(b(i)-x-a(i)*d(i-1)) + d(i) = c(i)*z + y(i) = (y(i)-a(i)*y(i-1))*z + 103 continue + z = b(m)-x-a(m)*d(mm1) + if (z .ne. 0.) go to 104 + y(m) = 0. + go to 105 + 104 y(m) = (y(m)-a(m)*y(mm1))/z + 105 continue + do 106 ip=1,mm1 + i = m-ip + y(i) = y(i)-d(i)*y(i+1) + 106 continue + if (k .ne. l) go to 108 + do 107 i=1,m + y(i) = y(i)+w(i) + 107 continue + lint = lint+1 + l = (lint*ifb)/ifc + 108 continue + return + end + + subroutine tri3 (m,a,b,c,k,y1,y2,y3,tcos,d,w1,w2,w3) + integer m + BIGREAL a(*) ,b(*) ,c(*) ,k(4) , & + & tcos(*) ,y1(*) ,y2(*) ,y3(*) , & + & d(*) ,w1(*) ,w2(*) ,w3(*) +! +! subroutine to solve three linear systems whose common coefficient +! matrix is a rational function in the matrix given by +! +! tridiagonal (...,a(i),b(i),c(i),...) +! +! local variables + integer i, n, k1, k2, k3, k4, mm1, l1, l2, l3, k2k3k4, & + & if1, if2, if3, if4, lint1, lint2, lint3, kint1, & + & kint2, kint3, ip + BIGREAL x, xx, z + + mm1 = m-1 + k1 = k(1) + k2 = k(2) + k3 = k(3) + k4 = k(4) + if1 = k1+1 + if2 = k2+1 + if3 = k3+1 + if4 = k4+1 + k2k3k4 = k2+k3+k4 + if (k2k3k4 .eq. 0) go to 101 + l1 = if1/if2 + l2 = if1/if3 + l3 = if1/if4 + lint1 = 1 + lint2 = 1 + lint3 = 1 + kint1 = k1 + kint2 = kint1+k2 + kint3 = kint2+k3 + 101 continue + do 115 n=1,k1 + x = tcos(n) + if (k2k3k4 .eq. 0) go to 107 + if (n .ne. l1) go to 103 + do 102 i=1,m + w1(i) = y1(i) + 102 continue + 103 if (n .ne. l2) go to 105 + do 104 i=1,m + w2(i) = y2(i) + 104 continue + 105 if (n .ne. l3) go to 107 + do 106 i=1,m + w3(i) = y3(i) + 106 continue + 107 continue + z = 1./(b(1)-x) + d(1) = c(1)*z + y1(1) = y1(1)*z + y2(1) = y2(1)*z + y3(1) = y3(1)*z + do 108 i=2,m + z = 1./(b(i)-x-a(i)*d(i-1)) + d(i) = c(i)*z + y1(i) = (y1(i)-a(i)*y1(i-1))*z + y2(i) = (y2(i)-a(i)*y2(i-1))*z + y3(i) = (y3(i)-a(i)*y3(i-1))*z + 108 continue + do 109 ip=1,mm1 + i = m-ip + y1(i) = y1(i)-d(i)*y1(i+1) + y2(i) = y2(i)-d(i)*y2(i+1) + y3(i) = y3(i)-d(i)*y3(i+1) + 109 continue + if (k2k3k4 .eq. 0) go to 115 + if (n .ne. l1) go to 111 + i = lint1+kint1 + xx = x-tcos(i) + do 110 i=1,m + y1(i) = xx*y1(i)+w1(i) + 110 continue + lint1 = lint1+1 + l1 = (lint1*if1)/if2 + 111 if (n .ne. l2) go to 113 + i = lint2+kint2 + xx = x-tcos(i) + do 112 i=1,m + y2(i) = xx*y2(i)+w2(i) + 112 continue + lint2 = lint2+1 + l2 = (lint2*if1)/if3 + 113 if (n .ne. l3) go to 115 + i = lint3+kint3 + xx = x-tcos(i) + do 114 i=1,m + y3(i) = xx*y3(i)+w3(i) + 114 continue + lint3 = lint3+1 + l3 = (lint3*if1)/if4 + 115 continue + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! october 1980 changed several divides of floating integers +! to integer divides to accomodate cray-1 arithmetic. +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +! june 1993 BIGREAL stuff added +!----------------------------------------------------------------------- + end + diff --git a/Utility/opencdf.F b/Utility/opencdf.F new file mode 100644 index 0000000..2c0443d --- /dev/null +++ b/Utility/opencdf.F @@ -0,0 +1,158 @@ +#include "griddefs.h" + subroutine opencdf (ncname) +! +!======================================================================= +! === +! This routine opens an existing NetCDF file and inquires about it === +! contents, and checks for consistency with model dimensions. === +! === +! On Input: === +! === +! ncname Input NetCDF file name. === +! === +! Calls: (NetCDF library) === +! crash === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global variables. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local variables. +!----------------------------------------------------------------------- +! + integer attype, dimid, dimsiz, i, ncid, ndims, & + & ngatts, nvatts, recdim + character*20 dimnam + character*(*) ncname +! +!======================================================================= +! Begin executable code. +!======================================================================= +! +! Open input NetCDF file. +! + rcode=nf90_open(TRIM(ncname),nf90_nowrite,ncid) + if ((rcode.ne.0).or.(ncid.eq.-1)) then + write(stdout,10) TRIM(ncname) + call crash ('OPENCDF',1) + endif +! +! Inquire and get global "type" attribute. +! + rcode = nf90_inquire_attribute(ncid,nf90_global,'type',attype) + if (rcode.eq.0) then + rcode = nf90_get_att(ncid,nf90_global,'type',type) + if(rcode.ne.0) then + write(stdout,20) 'type (global)', TRIM(ncname) + call crash ('OPENCDF',1) + endif + else + write(stdout,30) 'type (global)',TRIM(ncname) + endif +! +! Inquire about the contents of input NetCDF file: Inquire about the +! dimensions and variables. +! + rcode = nf90_inquire(ncid,ndims,nvars,ngatts,recdim) + if (nvars.gt.maxvar) then + write(stdout,40) maxvar, nvars + call crash ('OPENCDF',1) + endif + if (rcode.eq.0) then +! +! Inquire about dimensions. Check dimensions for consistency. +! + do i=1,ndims + dimid=i + rcode = nf90_inquire_dimension(ncid,dimid,dimnam,dimsiz) + if (rcode.ne.0) then + write(stdout,50) dimid, TRIM(ncname) + call crash ('OPENCDF',1) + endif + if ((TRIM(dimnam) .eq. 'xi_rho') .or. & + & (TRIM(dimnam) .eq. 'xi_v')) then + if (dimsiz.ne.Lp) then + write(stdout,60) TRIM(dimnam), dimsiz, Lp + call crash ('OPENCDF',1) + endif + elseif ((TRIM(dimnam) .eq. 'xi_u') .or. & + & (TRIM(dimnam) .eq. 'xi_psi')) then + if (dimsiz.ne.L) then + write(stdout,60) TRIM(dimnam), dimsiz, L + call crash ('OPENCDF',1) + endif + elseif ((TRIM(dimnam) .eq. 'eta_rho') .or. & + & (TRIM(dimnam) .eq. 'eta_u')) then + if (dimsiz.ne.Mp) then + write(stdout,60) TRIM(dimnam), dimsiz, Mp + call crash ('OPENCDF',1) + endif + elseif ((TRIM(dimnam) .eq. 'eta_v') .or. & + & (TRIM(dimnam) .eq. 'eta_psi')) then + if (dimsiz.ne.M) then + write(stdout,60) TRIM(dimnam), dimsiz, M + call crash ('OPENCDF',1) + endif + endif + enddo +! +! Inquire about variables. +! + do i=1,nvars + varid=i + rcode = nf90_inquire_variable(ncid,varid,varnam(i),vartyp, & + & nvdims(i),vdims(:,i),nvatts) + if (rcode.ne.0) then + write(stdout,70) varid, TRIM(ncname) + call crash ('OPENCDF',1) + endif + enddo + else + write(stdout,80) TRIM(ncname) + call crash ('OPENCDF',1) + endif +! +!----------------------------------------------------------------------- +! Inquire size of unlimited time record dimension. +!----------------------------------------------------------------------- +! + bathsize=0 + if (recdim.ne.-1) then + rcode = nf90_inquire_dimension(ncid,recdim,len=bathsize) + if (rcode.ne.0) then + write(stdout,90) 'bath', TRIM(ncname) + call crash ('OPENCDF',1) + endif + endif +! +! Close input NetCDF file. +! + rcode = nf90_close(ncid) +! + 10 format(/' OPENCDF - unable to open input NetCDF file: ',a) + 20 format(/' OPENCDF - error while reading attribute: ',a,2x, & + & ' in input NetCDF file: ',a) + 30 format(/' OPENCDF - cannot find attribute: ',a,2x, & + & ' in input NetCDF file: ',a) + 40 format(/' OPENCDF - too small dimension parameter, maxvar = ',2i5, & + & /,11x,'change file ncscrum.h and recompile.') + 50 format(/' OPENCDF - error while reading dimension ID: ',i3,2x, & + & ' in input NetCDF file: ',a) + 60 format(/' OPENCDF - inconsistent size of dimension: ',a,2x, & + & 2i5) + 70 format(/' OPENCDF - error while inquiring information for ', & + & ' variable ID: ',i3,2x,' in input NetCDF file: ',a) + 80 format(/' OPENCDF - unable to inquire about contents of', & + & ' input NetCDF file: ',a) + 90 format(/' OPENCDF - error inquiring dimension: ',a,2x, & + & ' in input NetCDF file: ',a) + return + end diff --git a/Utility/ploth.F b/Utility/ploth.F new file mode 100644 index 0000000..8d0c34c --- /dev/null +++ b/Utility/ploth.F @@ -0,0 +1,318 @@ +#include "griddefs.h" +! ******************************************************************** + + subroutine cpmpxy(imap,x,y,fx,fy) + integer imap + real x, y, fx, fy +#include "bathy.h" +#include "griddefs.h" + + if ( imap .eq. 3) then + fx = x_v(int(x),int(y)) & + & + (x_v(int(x)+1,int(y))-x_v(int(x),int(y)))*(x-aint(x)) & + & + (x_v(int(x),int(y)+1)-x_v(int(x),int(y)))*(y-aint(y)) & + & + (x_v(int(x)+1,int(y)+1)-x_v(int(x),int(y)+1) & + & - x_v(int(x)+1,int(y))+x_v(int(x),int(y))) & + & *(x-aint(x))*(y-aint(y)) + fy = y_v(int(x),int(y)) & + & + (y_v(int(x)+1,int(y))-y_v(int(x),int(y)))*(x-aint(x)) & + & + (y_v(int(x),int(y)+1)-y_v(int(x),int(y)))*(y-aint(y)) & + & + (y_v(int(x)+1,int(y)+1)-y_v(int(x),int(y)+1) & + & - y_v(int(x)+1,int(y))+y_v(int(x),int(y))) & + & *(x-aint(x))*(y-aint(y)) + end if + return + end + +!*******************************************************************c + + subroutine getxxyy +#include "bathy.h" + integer i, j + + do 100 i = 1,L + do 100 j = 1,M + x_v(i,j) = xp(i,j) + y_v(i,j) = yp(i,j) + 100 continue + do 110 i=1,L + x_v(i,Mp) = x_v(i,M) + y_v(i,Mp) = y_v(i,M) + 110 continue + do 120 j=1,Mp + x_v(Lp,j) = x_v(L,j) + y_v(Lp,j) = y_v(L,j) + 120 continue + return + end + +!*******************************************************************c + + subroutine getxyh +#include "bathy.h" + integer i, j + + do 100 i = 1,Lp + do 100 j = 1,Mp + x_v(i,j) = xr(i-1,j-1) + y_v(i,j) = yr(i-1,j-1) + 100 continue + do 110 i=1,Lp + x_v(i,0) = x_v(i,1) + y_v(i,0) = y_v(i,1) + x_v(i,M+2) = x_v(i,Mp) + y_v(i,M+2) = y_v(i,Mp) + 110 continue + do 120 j=1,M+2 + x_v(0,j) = x_v(1,j) + y_v(0,j) = y_v(1,j) + x_v(L+2,j) = x_v(Lp,j) + y_v(L+2,j) = y_v(Lp,j) + 120 continue + return + end + +! ******************************************************************** + + subroutine grdplt(x1,x2,y1,y2,gridid) + +! plots the psi points grid +! if called without advancing frame this can be used to overlay the grid +! on a colour filled contour plot + +#include "bathy.h" + character*40 gridid + real x1, x2, y1, y2 + integer i, j + + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq (0.5,0.96,gridid,.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) +#if DRAW_COASTS + call mapdrw +#endif /* DRAW_COASTS */ +#if DBLEPREC + do j = 1,Mm + do i = 1,Lm + if (mask_rho(i,j) .eq. 1.) then + call frstpt(sngl(xp(i,j)),sngl(yp(i,j))) + call vector(sngl(xp(i+1,j)),sngl(yp(i+1,j))) + call vector(sngl(xp(i+1,j+1)),sngl(yp(i+1,j+1))) + call vector(sngl(xp(i,j+1)),sngl(yp(i,j+1))) + call vector(sngl(xp(i,j)),sngl(yp(i,j))) + endif + enddo + enddo +#else + do j = 1,Mm + do i = 1,Lm + if (mask_rho(i,j) .eq. 1.) then + call frstpt(xp(i,j),yp(i,j)) + call vector(xp(i+1,j),yp(i+1,j)) + call vector(xp(i+1,j+1),yp(i+1,j+1)) + call vector(xp(i,j+1),yp(i,j+1)) + call vector(xp(i,j),yp(i,j)) + endif + enddo + enddo +#endif /* DBLEPREC */ + + return + end + +! ******************************************************************** + + subroutine ploth(gridid,colour,grover) + +#include "bathy.h" +#include "griddefs.h" + real dhdxx(L,0:M), dhdyy(0:L,M), tmp(L,M), & + & htmp(0:L,0:M) + character*24 ltit, lnote, lnote2 + character*40 gridid + logical colour, grover, tallflg + real x1, x2, y1, y2, depmin, depmax, ratio, slpmax + integer i, j + BIGREAL a1, a2, av2, vmin, vmax + real vsmax + + av2(a1,a2) = 0.5*(a1+a2) + +! find shape of domain to plot + if (xl .ge. el) then + x1 = 0.05 + x2 = 0.95 + y1 = -.45*el/xl + .5 + y2 = y1 + el/xl*.9 + tallflg = .false. + else + if (colour) then + y1 = 0.02 + y2 = 0.92 + else + y1 = 0.04 + y2 = 0.94 + end if + x1 = -.45*xl/el + .45 + x2 = x1 + xl/el*.9 + tallflg = .true. + end if + +! draw the grid first + call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + call frame + + write (ltit,100) + 100 format ('Bottom Topography') + + call getxyh + depmin = vmin(h,Lp*Mp) + write (lnote,120) depmin + 120 format ('MIN DEPTH =',f9.3) + depmax = vmax(h,Lp*Mp) + write (lnote2,131) depmax + 131 format ('MAX DEPTH =',f9.1) + + do j=0,M + do i=0,L + htmp(i,j) = h(i,j) + enddo + enddo + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq(.50,.98,ltit(1:17),.012,0.,0.) + call plchhq(.85,.98,lnote(1:20),.012,0.,0.) + call plchhq(.85,.95,lnote2(1:20),.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(htmp,Lp,Lp,Mp,16,lcflag,tallflg,.true.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(htmp,Lp,Lp,Mp,0.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + call getxxyy + write (ltit,130) + 130 format ('Bottom Slope') + + do 140 j=0,M + do 140 i=1,L + dhdxx(i,j) = (h(i,j) - h(i-1,j))*av2(pm(i,j),pm(i-1,j)) + 140 continue + do 150 j=1,M + do 150 i=0,L + dhdyy(i,j) = (h(i,j) - h(i,j-1))*av2(pn(i,j),pn(i,j-1)) + 150 continue + do 160 j=1,M + do 160 i=1,L + tmp(i,j) = sqrt((0.5*(dhdxx(i,j)+dhdxx(i,j-1)))**2 + & + & (0.5*(dhdyy(i,j)+dhdyy(i-1,j)))**2) + 160 continue + + slpmax = vsmax(tmp,L*M) + write (lnote,170) slpmax + 170 format ('MAX SLOPE =',f9.3) + + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq (0.5,0.98,ltit(1:12),.012,0.,0.) + call plchhq(.85,.98,lnote(1:20),.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(tmp,L,L,M,8,lcflag,tallflg,.false.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(tmp,L,L,M,0.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + write (ltit,180) + 180 format ('r-Value') + + do 190 j=0,M + do 190 i=1,L + dhdxx(i,j) = abs((h(i,j) - h(i-1,j)) & + & / (h(i,j) + h(i-1,j))) & + & * mask_rho(i,j) * mask_rho(i-1,j) + 190 continue + do 200 j=1,M + do 200 i=0,L + dhdyy(i,j) = abs((h(i,j) - h(i,j-1)) & + & / (h(i,j) + h(i,j-1))) & + & * mask_rho(i,j) * mask_rho(i,j-1) + 200 continue + do 210 j=1,M + do 210 i=1,L + tmp(i,j) = max(max(dhdxx(i,j),dhdxx(i,j-1)), & + & max(dhdyy(i,j),dhdyy(i-1,j))) + 210 continue + + ratio = vsmax(tmp,L*M) + write (lnote,220) ratio + 220 format ('MAX RATIO =',f9.3) + + call set(0.,1.,0.,1.,0.,1.,0.,1.,1) + call plchhq (0.5,0.98,ltit(1:7),.012,0.,0.) + call plchhq(.85,.98,lnote(1:20),.012,0.,0.) + call set(x1,x2,y1,y2,xmin,xmax,ymin,ymax,1) + if (colour) then + call cpsfill(tmp,L,L,M,8,lcflag,tallflg,.false.) + if (grover) call grdplt(x1,x2,y1,y2,gridid) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + else + call cpshift(tmp,L,L,M,0.,.false.,1.) +#if DRAW_COASTS + call drawcoast +#endif /* DRAW_COASTS */ + endif + call frame + + return + end + +! *********************************************************** + + real function vsmax(vect,N) + integer N + real vect(N) + real tmp + integer i + + tmp = vect(1) + do i=2,N + tmp = max(tmp,vect(i)) + enddo + vsmax = tmp + return + end + + real function vsmin(vect,N) + integer N + real vect(N) + real tmp + integer i + + tmp = vect(1) + do i=2,N + tmp = min(tmp,vect(i)) + enddo + vsmin = tmp + return + end + diff --git a/Utility/sepaux.F b/Utility/sepaux.F new file mode 100644 index 0000000..33c9e91 --- /dev/null +++ b/Utility/sepaux.F @@ -0,0 +1,406 @@ +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! package sepaux contains no user entry points. +! +! latest revision november 1988 +! +! purpose this package contains auxiliary routines for +! ncar public software packages such as sepeli +! and sepx4. +! +! usage since this package contains no user entries, +! no usage instructions or argument descriptions +! are given here. +! +! special conditions none +! +! i/o none +! +! precision single +! +! required library none +! files +! +! language fortran +! +! history developed in the late 1970's by john c. adams +! of ncar's scienttific computing division. +! +! portability fortran 77 +! ********************************************************************** +#include "griddefs.h" + subroutine seport (usol,idmn,zn,zm,pertrb) + integer idmn + BIGREAL usol(idmn,1) ,zn(*) ,zm(*) , pertrb +! +! this subroutine orthoganalizes the array usol with respect to +! the constant array in a weighted least squares norm +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + +! local variables + integer i, j, ii, jj, istr, ifnl, jstr, jfnl + BIGREAL ete, ute + + istr = is + ifnl = ms + jstr = js + jfnl = ns +! +! compute weighted inner products +! + ute = 0.0 + ete = 0.0 + do 20 i=is,ms + ii = i-is+1 + do 10 j=js,ns + jj = j-js+1 + ete = ete+zm(ii)*zn(jj) + ute = ute+usol(i,j)*zm(ii)*zn(jj) + 10 continue + 20 continue +! +! set perturbation parameter +! + pertrb = ute/ete +! +! subtract off constant pertrb +! + do 40 i=istr,ifnl + do 30 j=jstr,jfnl + usol(i,j) = usol(i,j)-pertrb + 30 continue + 40 continue + return + end + + subroutine sepmin (usol,idmn,zn,zm,pertb) + integer idmn + BIGREAL usol(idmn,1) ,zn(*) ,zm(*), pertb +! +! this subroutine orhtogonalizes the array usol with respect to +! the constant array in a weighted least squares norm +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + +! local variables + integer i, ii, j, jj, istr, ifnl, jstr, jfnl + BIGREAL ete, ute, pertrb +! +! entry at sepmin occurrs when the final solution is +! to be minimized with respect to the weighted +! least squares norm +! + istr = 1 + ifnl = k + jstr = 1 + jfnl = l +! +! compute weighted inner products +! + ute = 0.0 + ete = 0.0 + do 20 i=is,ms + ii = i-is+1 + do 10 j=js,ns + jj = j-js+1 + ete = ete+zm(ii)*zn(jj) + ute = ute+usol(i,j)*zm(ii)*zn(jj) + 10 continue + 20 continue +! +! set perturbation parameter +! + pertrb = ute/ete +! +! subtract off constant pertrb +! + do 40 i=istr,ifnl + do 30 j=jstr,jfnl + usol(i,j) = usol(i,j)-pertrb + 30 continue + 40 continue + return + end + + subroutine septri (n,a,b,c,d,u,z) +! +! this subroutine solves for a non-zero eigenvector corresponding +! to the zero eigenvalue of the transpose of the rank +! deficient one matrix with subdiagonal a, diagonal b, and +! superdiagonal c , with a(1) in the (1,n) position, with +! c(n) in the (n,1) position, and all other elements zero. +! + integer n + BIGREAL a(n) ,b(n) ,c(n) ,d(n) , & + & u(n) ,z(n) + +! local variables + integer j, k, nm1, nm2 + BIGREAL bn, v, den, an + + bn = b(n) + d(1) = a(2)/b(1) + v = a(1) + u(1) = c(n)/b(1) + nm2 = n-2 + do 10 j=2,nm2 + den = b(j)-c(j-1)*d(j-1) + d(j) = a(j+1)/den + u(j) = -c(j-1)*u(j-1)/den + bn = bn-v*u(j-1) + v = -v*d(j-1) + 10 continue + den = b(n-1)-c(n-2)*d(n-2) + d(n-1) = (a(n)-c(n-2)*u(n-2))/den + an = c(n-1)-v*d(n-2) + bn = bn-v*u(n-2) + den = bn-an*d(n-1) +! +! set last component equal to one +! + z(n) = 1.0 + z(n-1) = -d(n-1) + nm1 = n-1 + do 20 j=2,nm1 + k = n-j + z(k) = -d(k)*z(k+1)-u(k)*z(n) + 20 continue + return + end + + subroutine sepdx (u,idmn,i,j,uxxx,uxxxx) + integer idmn, i, j + BIGREAL u(idmn,1), uxxx, uxxxx +! +! this program computes second order finite difference +! approximations to the third and fourth x +! partial derivatives of u at the (i,j) mesh point +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + + if (i.gt.2 .and. i.lt.(k-1)) go to 50 + if (i .eq. 1) go to 10 + if (i .eq. 2) go to 30 + if (i .eq. k-1) go to 60 + if (i .eq. k) go to 80 +! +! compute partial derivative approximations at x=a +! + 10 if (kswx .eq. 1) go to 20 + uxxx = (-5.0*u(1,j)+18.0*u(2,j)-24.0*u(3,j)+14.0*u(4,j)- & + & 3.0*u(5,j))/(tdlx3) + uxxxx = (3.0*u(1,j)-14.0*u(2,j)+26.0*u(3,j)-24.0*u(4,j)+ & + & 11.0*u(5,j)-2.0*u(6,j))/dlx4 + return +! +! periodic at x=a +! + 20 uxxx = (-u(k-2,j)+2.0*u(k-1,j)-2.0*u(2,j)+u(3,j))/(tdlx3) + uxxxx = (u(k-2,j)-4.0*u(k-1,j)+6.0*u(1,j)-4.0*u(2,j)+u(3,j))/dlx4 + return +! +! compute partial derivative approximations at x=a+dlx +! + 30 if (kswx .eq. 1) go to 40 + uxxx = (-3.0*u(1,j)+10.0*u(2,j)-12.0*u(3,j)+6.0*u(4,j)-u(5,j))/ & + & tdlx3 + uxxxx = (2.0*u(1,j)-9.0*u(2,j)+16.0*u(3,j)-14.0*u(4,j)+6.0*u(5,j)- & + & u(6,j))/dlx4 + return +! +! periodic at x=a+dlx +! + 40 uxxx = (-u(k-1,j)+2.0*u(1,j)-2.0*u(3,j)+u(4,j))/(tdlx3) + uxxxx = (u(k-1,j)-4.0*u(1,j)+6.0*u(2,j)-4.0*u(3,j)+u(4,j))/dlx4 + return +! +! compute partial derivative approximations on the interior +! + 50 continue + uxxx = (-u(i-2,j)+2.0*u(i-1,j)-2.0*u(i+1,j)+u(i+2,j))/tdlx3 + uxxxx = (u(i-2,j)-4.0*u(i-1,j)+6.0*u(i,j)-4.0*u(i+1,j)+u(i+2,j))/ & + & dlx4 + return +! +! compute partial derivative approximations at x=b-dlx +! + 60 if (kswx .eq. 1) go to 70 + uxxx = (u(k-4,j)-6.0*u(k-3,j)+12.0*u(k-2,j)-10.0*u(k-1,j)+ & + & 3.0*u(k,j))/tdlx3 + uxxxx = (-u(k-5,j)+6.0*u(k-4,j)-14.0*u(k-3,j)+16.0*u(k-2,j)- & + & 9.0*u(k-1,j)+2.0*u(k,j))/dlx4 + return +! +! periodic at x=b-dlx +! + 70 uxxx = (-u(k-3,j)+2.0*u(k-2,j)-2.0*u(1,j)+u(2,j))/tdlx3 + uxxxx = (u(k-3,j)-4.0*u(k-2,j)+6.0*u(k-1,j)-4.0*u(1,j)+u(2,j))/ & + & dlx4 + return +! +! compute partial derivative approximations at x=b +! + 80 uxxx = -(3.0*u(k-4,j)-14.0*u(k-3,j)+24.0*u(k-2,j)-18.0*u(k-1,j)+ & + & 5.0*u(k,j))/tdlx3 + uxxxx = (-2.0*u(k-5,j)+11.0*u(k-4,j)-24.0*u(k-3,j)+26.0*u(k-2,j)- & + & 14.0*u(k-1,j)+3.0*u(k,j))/dlx4 + return + end + + subroutine sepdy (u,idmn,i,j,uyyy,uyyyy) + integer idmn, i, j + BIGREAL u(idmn,*), uyyy, uyyyy +! +! this program computes second order finite difference +! approximations to the third and fourth y +! partial derivatives of u at the (i,j) mesh point +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + if (j.gt.2 .and. j.lt.(l-1)) go to 50 + if (j .eq. 1) go to 10 + if (j .eq. 2) go to 30 + if (j .eq. l-1) go to 60 + if (j .eq. l) go to 80 +! +! compute partial derivative approximations at y=c +! + 10 if (kswy .eq. 1) go to 20 + uyyy = (-5.0*u(i,1)+18.0*u(i,2)-24.0*u(i,3)+14.0*u(i,4)- & + & 3.0*u(i,5))/tdly3 + uyyyy = (3.0*u(i,1)-14.0*u(i,2)+26.0*u(i,3)-24.0*u(i,4)+ & + & 11.0*u(i,5)-2.0*u(i,6))/dly4 + return +! +! periodic at x=a +! + 20 uyyy = (-u(i,l-2)+2.0*u(i,l-1)-2.0*u(i,2)+u(i,3))/tdly3 + uyyyy = (u(i,l-2)-4.0*u(i,l-1)+6.0*u(i,1)-4.0*u(i,2)+u(i,3))/dly4 + return +! +! compute partial derivative approximations at y=c+dly +! + 30 if (kswy .eq. 1) go to 40 + uyyy = (-3.0*u(i,1)+10.0*u(i,2)-12.0*u(i,3)+6.0*u(i,4)-u(i,5))/ & + & tdly3 + uyyyy = (2.0*u(i,1)-9.0*u(i,2)+16.0*u(i,3)-14.0*u(i,4)+6.0*u(i,5)- & + & u(i,6))/dly4 + return +! +! periodic at y=c+dly +! + 40 uyyy = (-u(i,l-1)+2.0*u(i,1)-2.0*u(i,3)+u(i,4))/tdly3 + uyyyy = (u(i,l-1)-4.0*u(i,1)+6.0*u(i,2)-4.0*u(i,3)+u(i,4))/dly4 + return +! +! compute partial derivative approximations on the interior +! + 50 continue + uyyy = (-u(i,j-2)+2.0*u(i,j-1)-2.0*u(i,j+1)+u(i,j+2))/tdly3 + uyyyy = (u(i,j-2)-4.0*u(i,j-1)+6.0*u(i,j)-4.0*u(i,j+1)+u(i,j+2))/ & + & dly4 + return +! +! compute partial derivative approximations at y=d-dly +! + 60 if (kswy .eq. 1) go to 70 + uyyy = (u(i,l-4)-6.0*u(i,l-3)+12.0*u(i,l-2)-10.0*u(i,l-1)+ & + & 3.0*u(i,l))/tdly3 + uyyyy = (-u(i,l-5)+6.0*u(i,l-4)-14.0*u(i,l-3)+16.0*u(i,l-2)- & + & 9.0*u(i,l-1)+2.0*u(i,l))/dly4 + return +! +! periodic at y=d-dly +! + 70 continue + uyyy = (-u(i,l-3)+2.0*u(i,l-2)-2.0*u(i,1)+u(i,2))/tdly3 + uyyyy = (u(i,l-3)-4.0*u(i,l-2)+6.0*u(i,l-1)-4.0*u(i,1)+u(i,2))/ & + & dly4 + return +! +! compute partial derivative approximations at y=d +! + 80 uyyy = -(3.0*u(i,l-4)-14.0*u(i,l-3)+24.0*u(i,l-2)-18.0*u(i,l-1)+ & + & 5.0*u(i,l))/tdly3 + uyyyy = (-2.0*u(i,l-5)+11.0*u(i,l-4)-24.0*u(i,l-3)+26.0*u(i,l-2)- & + & 14.0*u(i,l-1)+3.0*u(i,l))/dly4 + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +! june 1993 BIGREAL stuff added +!----------------------------------------------------------------------- + end diff --git a/Utility/sepeli.F b/Utility/sepeli.F new file mode 100644 index 0000000..ec1a8cd --- /dev/null +++ b/Utility/sepeli.F @@ -0,0 +1,1084 @@ + + subroutine sepeli (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c, & + & d,n,nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,grhs, & + & usol,idmn,w,pertrb,ierror) +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! +! dimension of bda(n+1), bdb(n+1), bdc(m+1), bdd(m+1), +! arguments usol(idmn,n+1),grhs(idmn,n+1), +! w (see argument list) +! +! latest revision november 1988 +! +! purpose sepeli solves for either the second-order +! finite difference approximation or a +! fourth-order approximation to a separable +! elliptic equation +! +! 2 2 +! af(x)*d u/dx + bf(x)*du/dx + cf(x)*u + +! 2 2 +! df(y)*d u/dy + ef(y)*du/dy + ff(y)*u +! +! = g(x,y) +! +! on a rectangle (x greater than or equal to a +! and less than or equal to b; y greater than +! or equal to c and less than or equal to d). +! any combination of periodic or mixed boundary +! conditions is allowed. +! +! the possible boundary conditions are: +! in the x-direction: +! (0) periodic, u(x+b-a,y)=u(x,y) for all +! y,x (1) u(a,y), u(b,y) are specified for +! all y +! (2) u(a,y), du(b,y)/dx+beta*u(b,y) are +! specified for all y +! (3) du(a,y)/dx+alpha*u(a,y),du(b,y)/dx+ +! beta*u(b,y) are specified for all y +! (4) du(a,y)/dx+alpha*u(a,y),u(b,y) are +! specified for all y +! +! in the y-direction: +! (0) periodic, u(x,y+d-c)=u(x,y) for all x,y +! (1) u(x,c),u(x,d) are specified for all x +! (2) u(x,c),du(x,d)/dy+xnu*u(x,d) are +! specified for all x +! (3) du(x,c)/dy+gama*u(x,c),du(x,d)/dy+ +! xnu*u(x,d) are specified for all x +! (4) du(x,c)/dy+gama*u(x,c),u(x,d) are +! specified for all x +! +! usage call sepeli (intl,iorder,a,b,m,mbdcnd,bda, +! alpha,bdb,beta,c,d,n,nbdcnd,bdc, +! gama,bdd,xnu,cofx,cofy,grhs,usol, +! idmn,w,pertrb,ierror) +! +! arguments +! on input intl +! = 0 on initial entry to sepeli or if any +! of the arguments c,d, n, nbdcnd, cofy +! are changed from a previous call +! = 1 if c, d, n, nbdcnd, cofy are unchanged +! from the previous call. +! +! iorder +! = 2 if a second-order approximation +! is sought +! = 4 if a fourth-order approximation +! is sought +! +! a,b +! the range of the x-independent variable, +! i.e., x is greater than or equal to a +! and less than or equal to b. a must be +! less than b. +! +! m +! the number of panels into which the +! interval [a,b] is subdivided. hence, +! there will be m+1 grid points in the x- +! direction given by xi=a+(i-1)*dlx +! for i=1,2,...,m+1 where dlx=(b-a)/m is +! the panel width. m must be less than +! idmn and greater than 5. +! +! mbdcnd +! indicates the type of boundary condition +! at x=a and x=b +! +! = 0 if the solution is periodic in x, i.e., +! u(x+b-a,y)=u(x,y) for all y,x +! = 1 if the solution is specified at x=a +! and x=b, i.e., u(a,y) and u(b,y) are +! specified for all y +! = 2 if the solution is specified at x=a and +! the boundary condition is mixed at x=b, +! i.e., u(a,y) and du(b,y)/dx+beta*u(b,y) +! are specified for all y +! = 3 if the boundary conditions at x=a and +! x=b are mixed, i.e., +! du(a,y)/dx+alpha*u(a,y) and +! du(b,y)/dx+beta*u(b,y) are specified +! for all y +! = 4 if the boundary condition at x=a is +! mixed and the solution is specified +! at x=b, i.e., du(a,y)/dx+alpha*u(a,y) +! and u(b,y) are specified for all y +! +! bda +! a one-dimensional array of length n+1 +! that specifies the values of +! du(a,y)/dx+ alpha*u(a,y) at x=a, when +! mbdcnd=3 or 4. +! bda(j) = du(a,yj)/dx+alpha*u(a,yj), +! j=1,2,...,n+1. when mbdcnd has any other +! other value, bda is a dummy parameter. +! +! alpha +! the scalar multiplying the solution in +! case of a mixed boundary condition at x=a +! (see argument bda). if mbdcnd is not +! equal to 3 or 4 then alpha is a dummy +! parameter. +! +! bdb +! a one-dimensional array of length n+1 +! that specifies the values of +! du(b,y)/dx+ beta*u(b,y) at x=b. +! when mbdcnd=2 or 3 +! bdb(j) = du(b,yj)/dx+beta*u(b,yj), +! j=1,2,...,n+1. when mbdcnd has any other +! other value, bdb is a dummy parameter. +! +! beta +! the scalar multiplying the solution in +! case of a mixed boundary condition at +! x=b (see argument bdb). if mbdcnd is +! not equal to 2 or 3 then beta is a dummy +! parameter. +! +! c,d +! the range of the y-independent variable, +! i.e., y is greater than or equal to c +! and less than or equal to d. c must be +! less than d. +! +! n +! the number of panels into which the +! interval [c,d] is subdivided. +! hence, there will be n+1 grid points +! in the y-direction given by +! yj=c+(j-1)*dly for j=1,2,...,n+1 where +! dly=(d-c)/n is the panel width. +! in addition, n must be greater than 4. +! +! nbdcnd +! indicates the types of boundary conditions +! at y=c and y=d +! +! = 0 if the solution is periodic in y, +! i.e., u(x,y+d-c)=u(x,y) for all x,y +! = 1 if the solution is specified at y=c +! and y = d, i.e., u(x,c) and u(x,d) +! are specified for all x +! = 2 if the solution is specified at y=c +! and the boundary condition is mixed +! at y=d, i.e., u(x,c) and +! du(x,d)/dy+xnu*u(x,d) are specified +! for all x +! = 3 if the boundary conditions are mixed +! at y=c and y=d, i.e., +! du(x,d)/dy+gama*u(x,c) and +! du(x,d)/dy+xnu*u(x,d) are specified +! for all x +! = 4 if the boundary condition is mixed +! at y=c and the solution is specified +! at y=d, i.e. du(x,c)/dy+gama*u(x,c) +! and u(x,d) are specified for all x +! +! bdc +! a one-dimensional array of length m+1 +! that specifies the value of +! du(x,c)/dy+gama*u(x,c) at y=c. +! when nbdcnd=3 or 4 bdc(i) = du(xi,c)/dy + +! gama*u(xi,c), i=1,2,...,m+1. +! when nbdcnd has any other value, bdc +! is a dummy parameter. +! +! gama +! the scalar multiplying the solution in +! case of a mixed boundary condition at +! y=c (see argument bdc). if nbdcnd is +! not equal to 3 or 4 then gama is a dummy +! parameter. +! +! bdd +! a one-dimensional array of length m+1 +! that specifies the value of +! du(x,d)/dy + xnu*u(x,d) at y=c. +! when nbdcnd=2 or 3 bdd(i) = du(xi,d)/dy + +! xnu*u(xi,d), i=1,2,...,m+1. +! when nbdcnd has any other value, bdd +! is a dummy parameter. +! +! xnu +! the scalar multiplying the solution in +! case of a mixed boundary condition at +! y=d (see argument bdd). if nbdcnd is +! not equal to 2 or 3 then xnu is a +! dummy parameter. +! +! cofx +! a user-supplied subprogram with +! parameters x, afun, bfun, cfun which +! returns the values of the x-dependent +! coefficients af(x), bf(x), cf(x) in the +! elliptic equation at x. +! +! cofy +! a user-supplied subprogram with parameters +! y, dfun, efun, ffun which returns the +! values of the y-dependent coefficients +! df(y), ef(y), ff(y) in the elliptic +! equation at y. +! +! note: cofx and cofy must be declared +! external in the calling routine. +! the values returned in afun and dfun +! must satisfy afun*dfun greater than 0 +! for a less than x less than b, c less +! than y less than d (see ierror=10). +! the coefficients provided may lead to a +! matrix equation which is not diagonally +! dominant in which case solution may fail +! (see ierror=4). +! +! grhs +! a two-dimensional array that specifies the +! values of the right-hand side of the +! elliptic equation, i.e., +! grhs(i,j)=g(xi,yi), for i=2,...,m, +! j=2,...,n. at the boundaries, grhs is +! defined by +! +! mbdcnd grhs(1,j) grhs(m+1,j) +! ------ --------- ----------- +! 0 g(a,yj) g(b,yj) +! 1 * * +! 2 * g(b,yj) j=1,2,...,n+1 +! 3 g(a,yj) g(b,yj) +! 4 g(a,yj) * +! +! nbdcnd grhs(i,1) grhs(i,n+1) +! ------ --------- ----------- +! 0 g(xi,c) g(xi,d) +! 1 * * +! 2 * g(xi,d) i=1,2,...,m+1 +! 3 g(xi,c) g(xi,d) +! 4 g(xi,c) * +! +! where * means these quantities are not used. +! grhs should be dimensioned idmn by at least +! n+1 in the calling routine. +! +! usol +! a two-dimensional array that specifies the +! values of the solution along the boundaries. +! at the boundaries, usol is defined by +! +! mbdcnd usol(1,j) usol(m+1,j) +! ------ --------- ----------- +! 0 * * +! 1 u(a,yj) u(b,yj) +! 2 u(a,yj) * j=1,2,...,n+1 +! 3 * * +! 4 * u(b,yj) +! +! nbdcnd usol(i,1) usol(i,n+1) +! ------ --------- ----------- +! 0 * * +! 1 u(xi,c) u(xi,d) +! 2 u(xi,c) * i=1,2,...,m+1 +! 3 * * +! 4 * u(xi,d) +! +! where * means the quantities are not used +! in the solution. +! +! if iorder=2, the user may equivalence grhs +! and usol to save space. note that in this +! case the tables specifying the boundaries +! of the grhs and usol arrays determine the +! boundaries uniquely except at the corners. +! if the tables call for both g(x,y) and +! u(x,y) at a corner then the solution must +! be chosen. for example, if mbdcnd=2 and +! nbdcnd=4, then u(a,c), u(a,d), u(b,d) must +! be chosen at the corners in addition +! to g(b,c). +! +! if iorder=4, then the two arrays, usol and +! grhs, must be distinct. +! +! usol should be dimensioned idmn by at least +! n+1 in the calling routine. +! +! idmn +! the row (or first) dimension of the arrays +! grhs and usol as it appears in the program +! calling sepeli. this parameter is used +! to specify the variable dimension of grhs +! and usol. idmn must be at least 7 and +! greater than or equal to m+1. +! +! w +! a one-dimensional array that must be +! provided by the user for work space. +! let k=int(log2(n+1))+1 and set l=2**(k+1). +! then (k-2)*l+k+10*n+12*m+27 will suffice +! as a length of w. the actual length of w +! in the calling routine must be set in w(1) +! (see ierror=11). +! +! on output usol +! contains the approximate solution to the +! elliptic equation. +! usol(i,j) is the approximation to u(xi,yj) +! for i=1,2...,m+1 and j=1,2,...,n+1. +! the approximation has error +! o(dlx**2+dly**2) if called with iorder=2 +! and o(dlx**4+dly**4) if called with +! iorder=4. +! +! w +! contains intermediate values that must not +! be destroyed if sepeli is called again with +! intl=1. in addition w(1) contains the +! exact minimal length (in floating point) +! required for the work space (see ierror=11). +! +! pertrb +! if a combination of periodic or derivative +! boundary conditions +! (i.e., alpha=beta=0 if mbdcnd=3; +! gama=xnu=0 if nbdcnd=3) is specified +! and if the coefficients of u(x,y) in the +! separable elliptic equation are zero +! (i.e., cf(x)=0 for x greater than or equal +! to a and less than or equal to b; +! ff(y)=0 for y greater than or equal to c +! and less than or equal to d) then a +! solution may not exist. pertrb is a +! constant calculated and subtracted from +! the right-hand side of the matrix equations +! generated by sepeli which insures that a +! solution exists. sepeli then computes this +! solution which is a weighted minimal least +! squares solution to the original problem. +! +! ierror +! an error flag that indicates invalid input +! parameters or failure to find a solution +! = 0 no error +! = 1 if a greater than b or c greater than d +! = 2 if mbdcnd less than 0 or mbdcnd greater +! than 4 +! = 3 if nbdcnd less than 0 or nbdcnd greater +! than 4 +! = 4 if attempt to find a solution fails. +! (the linear system generated is not +! diagonally dominant.) +! = 5 if idmn is too small +! (see discussion of idmn) +! = 6 if m is too small or too large +! (see discussion of m) +! = 7 if n is too small (see discussion of n) +! = 8 if iorder is not 2 or 4 +! = 9 if intl is not 0 or 1 +! = 10 if afun*dfun less than or equal to 0 +! for some interior mesh point (xi,yj) +! = 11 if the work space length input in w(1) +! is less than the exact minimal work +! space length required output in w(1). +! +! note (concerning ierror=4): for the +! coefficients input through cofx, cofy, +! the discretization may lead to a block +! tridiagonal linear system which is not +! diagonally dominant (for example, this +! happens if cfun=0 and bfun/(2.*dlx) greater +! than afun/dlx**2). in this case solution +! may fail. this cannot happen in the limit +! as dlx, dly approach zero. hence, the +! condition may be remedied by taking larger +! values for m or n. +! +! special conditions see cofx, cofy argument descriptions above. +! +! i/o none +! +! precision single +! +! required library blktri, comf, and sepaux +! files from fishpak +! +! language fortran +! +! history developed at ncar during 1975-76 by +! john c. adams of the scientific computing +! division. released on ncar's public software +! libraries in january 1980. +! +! portability fortran 77 +! +! algorithm sepeli automatically discretizes the +! separable elliptic equation which is then +! solved by a generalized cyclic reduction +! algorithm in the subroutine, blktri. the +! fourth-order solution is obtained using +! 'deferred corrections' which is described +! and referenced in sections, references and +! method. +! +! timing the operational count is proportional to +! m*n*log2(n). +! +! accuracy the following accuracy results were obtained +! on a cdc 7600. note that the fourth-order +! accuracy is not realized until the mesh is +! sufficiently refined. +! +! second-order fourth-order +! m n error error +! +! 6 6 6.8e-1 1.2e0 +! 14 14 1.4e-1 1.8e-1 +! 30 30 3.2e-2 9.7e-3 +! 62 62 7.5e-3 3.0e-4 +! 126 126 1.8e-3 3.5e-6 +! +! +! references keller, h.b., numerical methods for two-point +! boundary-value problems, blaisdel (1968), +! waltham, mass. +! +! swarztrauber, p., and r. sweet (1975): +! efficient fortran subprograms for the +! solution of elliptic partial differential +! equations. ncar technical note +! ncar-tn/ia-109, pp. 135-137. +!*********************************************************************** +#include "griddefs.h" + integer intl ,iorder ,m ,n , & + & mbdcnd ,nbdcnd ,idmn ,ierror + BIGREAL a ,b ,c ,d , & + & alpha ,beta ,gama ,xnu , & + & pertrb + BIGREAL grhs(idmn,n+1) ,usol(idmn,n+1) + BIGREAL bda(*) ,bdb(*) ,bdc(*) ,bdd(*) , & + & w(*) + external cofx ,cofy + integer l ,logb2n ,ll ,linput , & + & loutpt ,i1 ,length ,i2 , & + & i3 ,i4 ,i5 ,i6 , & + & i7 ,i8 ,i9 ,i10 , & + & i11 ,i12 ,i13 ,k +! +! check input parameters +! + call chkprm (intl,iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,cofy, & + & idmn,ierror) + if (ierror .ne. 0) return +! +! compute minimum work space and check work space length input +! + l = n+1 + if (nbdcnd .eq. 0) l = n + logb2n = int(alog(float(l)+0.5)/alog(2.0))+1 + ll = 2**(logb2n+1) + k = m+1 + l = n+1 + length = (logb2n-2)*ll+logb2n+max0(2*l,6*k)+5 + if (nbdcnd .eq. 0) length = length+2*l + ierror = 11 + linput = int(w(1)+0.5) + loutpt = length+6*(k+l)+1 + w(1) = float(loutpt) + if (loutpt .gt. linput) return + ierror = 0 +! +! set work space indices +! + i1 = length+2 + i2 = i1+l + i3 = i2+l + i4 = i3+l + i5 = i4+l + i6 = i5+l + i7 = i6+l + i8 = i7+k + i9 = i8+k + i10 = i9+k + i11 = i10+k + i12 = i11+k + i13 = 2 + call spelip (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, & + & nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,w(i1),w(i2),w(i3), & + & w(i4),w(i5),w(i6),w(i7),w(i8),w(i9),w(i10),w(i11), & + & w(i12),grhs,usol,idmn,w(i13),pertrb,ierror) + return + end + subroutine spelip (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c, & + & d,n,nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,an,bn, & + & cn,dn,un,zn,am,bm,cm,dm,um,zm,grhs,usol,idmn, & + & w,pertrb,ierror) +! +! spelip sets up vectors and arrays for input to blktri +! and computes a second order solution in usol. a return jump to +! sepeli occurrs if iorder=2. if iorder=4 a fourth order +! solution is generated in usol. +! + integer intl ,iorder ,m ,mbdcnd , & + & n ,nbdcnd ,idmn ,ierror + BIGREAL a ,b ,c ,d , & + & alpha ,beta ,gama ,xnu , & + & pertrb + BIGREAL bda(*) ,bdb(*) ,bdc(*) ,bdd(*) , & + & w(*) + BIGREAL grhs(idmn,n+1) ,usol(idmn,n+1) + BIGREAL an(*) ,bn(*) ,cn(*) ,dn(*) , & + & un(*) ,zn(*) + BIGREAL am(*) ,bm(*) ,cm(*) ,dm(*) , & + & um(*) ,zm(*) + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly ,tdlx3 ,tdly3 , & + & dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + logical singlr + external cofx ,cofy + integer i ,j ,i1 ,mp , & + & np ,iord + BIGREAL xi ,ai ,bi ,ci , & + & axi ,bxi ,cxi ,yj , & + & dj ,ej ,fj ,dyj , & + & eyj ,fyj ,ax1 ,cxm , & + & dy1 ,fyn ,prtrb +! +! set parameters internally +! + kswx = mbdcnd+1 + kswy = nbdcnd+1 + k = m+1 + l = n+1 + ait = a + bit = b + cit = c + dit = d +! +! set right hand side values from grhs in usol on the interior +! and non-specified boundaries. +! + do 20 i=2,m + do 10 j=2,n + usol(i,j) = grhs(i,j) + 10 continue + 20 continue + if (kswx.eq.2 .or. kswx.eq.3) go to 40 + do 30 j=2,n + usol(1,j) = grhs(1,j) + 30 continue + 40 continue + if (kswx.eq.2 .or. kswx.eq.5) go to 60 + do 50 j=2,n + usol(k,j) = grhs(k,j) + 50 continue + 60 continue + if (kswy.eq.2 .or. kswy.eq.3) go to 80 + do 70 i=2,m + usol(i,1) = grhs(i,1) + 70 continue + 80 continue + if (kswy.eq.2 .or. kswy.eq.5) go to 100 + do 90 i=2,m + usol(i,l) = grhs(i,l) + 90 continue + 100 continue + if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.3) & + & usol(1,1) = grhs(1,1) + if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.3) & + & usol(k,1) = grhs(k,1) + if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.5) & + & usol(1,l) = grhs(1,l) + if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.5) & + & usol(k,l) = grhs(k,l) + i1 = 1 +! +! set switches for periodic or non-periodic boundaries +! + mp = 1 + np = 1 + if (kswx .eq. 1) mp = 0 + if (kswy .eq. 1) np = 0 +! +! set dlx,dly and size of block tri-diagonal system generated +! in nint,mint +! + dlx = (bit-ait)/float(m) + mit = k-1 + if (kswx .eq. 2) mit = k-2 + if (kswx .eq. 4) mit = k + dly = (dit-cit)/float(n) + nit = l-1 + if (kswy .eq. 2) nit = l-2 + if (kswy .eq. 4) nit = l + tdlx3 = 2.0*dlx**3 + dlx4 = dlx**4 + tdly3 = 2.0*dly**3 + dly4 = dly**4 +! +! set subscript limits for portion of array to input to blktri +! + is = 1 + js = 1 + if (kswx.eq.2 .or. kswx.eq.3) is = 2 + if (kswy.eq.2 .or. kswy.eq.3) js = 2 + ns = nit+js-1 + ms = mit+is-1 +! +! set x - direction +! + do 110 i=1,mit + xi = ait+float(is+i-2)*dlx + call cofx (xi,ai,bi,ci) + axi = (ai/dlx-0.5*bi)/dlx + bxi = -2.*ai/dlx**2+ci + cxi = (ai/dlx+0.5*bi)/dlx + am(i) = axi + bm(i) = bxi + cm(i) = cxi + 110 continue +! +! set y direction +! + do 120 j=1,nit + yj = cit+float(js+j-2)*dly + call cofy (yj,dj,ej,fj) + dyj = (dj/dly-0.5*ej)/dly + eyj = (-2.*dj/dly**2+fj) + fyj = (dj/dly+0.5*ej)/dly + an(j) = dyj + bn(j) = eyj + cn(j) = fyj + 120 continue +! +! adjust edges in x direction unless periodic +! + ax1 = am(1) + cxm = cm(mit) + go to (170,130,150,160,140),kswx +! +! dirichlet-dirichlet in x direction +! + 130 am(1) = 0.0 + cm(mit) = 0.0 + go to 170 +! +! mixed-dirichlet in x direction +! + 140 am(1) = 0.0 + bm(1) = bm(1)+2.*alpha*dlx*ax1 + cm(1) = cm(1)+ax1 + cm(mit) = 0.0 + go to 170 +! +! dirichlet-mixed in x direction +! + 150 am(1) = 0.0 + am(mit) = am(mit)+cxm + bm(mit) = bm(mit)-2.*beta*dlx*cxm + + cm(mit) = 0.0 + go to 170 +! +! mixed - mixed in x direction +! + 160 continue + am(1) = 0.0 + bm(1) = bm(1)+2.*dlx*alpha*ax1 + cm(1) = cm(1)+ax1 + am(mit) = am(mit)+cxm + bm(mit) = bm(mit)-2.*dlx*beta*cxm + cm(mit) = 0.0 + 170 continue +! +! adjust in y direction unless periodic +! + dy1 = an(1) + fyn = cn(nit) + go to (220,180,200,210,190),kswy +! +! dirichlet-dirichlet in y direction +! + 180 continue + an(1) = 0.0 + cn(nit) = 0.0 + go to 220 +! +! mixed-dirichlet in y direction +! + 190 continue + an(1) = 0.0 + bn(1) = bn(1)+2.*dly*gama*dy1 + cn(1) = cn(1)+dy1 + cn(nit) = 0.0 + go to 220 +! +! dirichlet-mixed in y direction +! + 200 an(1) = 0.0 + an(nit) = an(nit)+fyn + bn(nit) = bn(nit)-2.*dly*xnu*fyn + cn(nit) = 0.0 + go to 220 +! +! mixed - mixed direction in y direction +! + 210 continue + an(1) = 0.0 + bn(1) = bn(1)+2.*dly*gama*dy1 + cn(1) = cn(1)+dy1 + an(nit) = an(nit)+fyn + bn(nit) = bn(nit)-2.0*dly*xnu*fyn + cn(nit) = 0.0 + 220 if (kswx .eq. 1) go to 270 +! +! adjust usol along x edge +! + do 260 j=js,ns + if (kswx.ne.2 .and. kswx.ne.3) go to 230 + usol(is,j) = usol(is,j)-ax1*usol(1,j) + go to 240 + 230 usol(is,j) = usol(is,j)+2.0*dlx*ax1*bda(j) + 240 if (kswx.ne.2 .and. kswx.ne.5) go to 250 + usol(ms,j) = usol(ms,j)-cxm*usol(k,j) + go to 260 + 250 usol(ms,j) = usol(ms,j)-2.0*dlx*cxm*bdb(j) + 260 continue + 270 if (kswy .eq. 1) go to 320 +! +! adjust usol along y edge +! + do 310 i=is,ms + if (kswy.ne.2 .and. kswy.ne.3) go to 280 + usol(i,js) = usol(i,js)-dy1*usol(i,1) + go to 290 + 280 usol(i,js) = usol(i,js)+2.0*dly*dy1*bdc(i) + 290 if (kswy.ne.2 .and. kswy.ne.5) go to 300 + usol(i,ns) = usol(i,ns)-fyn*usol(i,l) + go to 310 + 300 usol(i,ns) = usol(i,ns)-2.0*dly*fyn*bdd(i) + 310 continue + 320 continue +! +! save adjusted edges in grhs if iorder=4 +! + if (iorder .ne. 4) go to 350 + do 330 j=js,ns + grhs(is,j) = usol(is,j) + grhs(ms,j) = usol(ms,j) + 330 continue + do 340 i=is,ms + grhs(i,js) = usol(i,js) + grhs(i,ns) = usol(i,ns) + 340 continue + 350 continue + iord = iorder + pertrb = 0.0 +! +! check if operator is singular +! + call chksng (mbdcnd,nbdcnd,alpha,beta,gama,xnu,cofx,cofy,singlr) +! +! compute non-zero eigenvector in null space of transpose +! if singular +! + if (singlr) call septri (mit,am,bm,cm,dm,um,zm) + if (singlr) call septri (nit,an,bn,cn,dn,un,zn) +! +! make initialization call to blktri +! + if (intl .eq. 0) & + & call blktri (intl,np,nit,an,bn,cn,mp,mit,am,bm,cm,idmn, & + & usol(is,js),ierror,w) + if (ierror .ne. 0) return +! +! adjust right hand side if necessary +! + 360 continue + if (singlr) call seport (usol,idmn,zn,zm,pertrb) +! +! compute solution +! + call blktri (i1,np,nit,an,bn,cn,mp,mit,am,bm,cm,idmn,usol(is,js), & + & ierror,w) + if (ierror .ne. 0) return +! +! set periodic boundaries if necessary +! + if (kswx .ne. 1) go to 380 + do 370 j=1,l + usol(k,j) = usol(1,j) + 370 continue + 380 if (kswy .ne. 1) go to 400 + do 390 i=1,k + usol(i,l) = usol(i,1) + 390 continue + 400 continue +! +! minimize solution with respect to weighted least squares +! norm if operator is singular +! + if (singlr) call sepmin (usol,idmn,zn,zm,prtrb) +! +! return if deferred corrections and a fourth order solution are +! not flagged +! + if (iord .eq. 2) return + iord = 2 +! +! compute new right hand side for fourth order solution +! + call defer (cofx,cofy,idmn,n,usol,grhs) + go to 360 + end + subroutine chkprm (intl,iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx, & + & cofy,idmn,ierror) +! +! this program checks the input parameters for errors +! + integer intl ,iorder ,m ,mbdcnd , & + & n ,nbdcnd ,idmn ,ierror + BIGREAL a ,b ,c ,d + external cofx ,cofy + integer i ,j + BIGREAL ai ,bi ,ci ,xi , & + & dj ,ej ,fj ,yj , & + & dlx ,dly +! +! check definition of solution region +! + ierror = 1 + if (a.ge.b .or. c.ge.d) return +! +! check boundary switches +! + ierror = 2 + if (mbdcnd.lt.0 .or. mbdcnd.gt.4) return + ierror = 3 + if (nbdcnd.lt.0 .or. nbdcnd.gt.4) return +! +! check first dimension in calling routine +! + ierror = 5 + if (idmn .lt. 7) return +! +! check m +! + ierror = 6 + if (m.gt.(idmn-1) .or. m.lt.6) return +! +! check n +! + ierror = 7 + if (n .lt. 5) return +! +! check iorder +! + ierror = 8 + if (iorder.ne.2 .and. iorder.ne.4) return +! +! check intl +! + ierror = 9 + if (intl.ne.0 .and. intl.ne.1) return +! +! check that equation is elliptic +! + dlx = (b-a)/float(m) + dly = (d-c)/float(n) + do 30 i=2,m + xi = a+float(i-1)*dlx + call cofx (xi,ai,bi,ci) + do 20 j=2,n + yj = c+float(j-1)*dly + call cofy (yj,dj,ej,fj) + if (ai*dj .gt. 0.0) go to 10 + ierror = 10 + return + 10 continue + 20 continue + 30 continue +! +! no error found +! + ierror = 0 + return + end + subroutine chksng (mbdcnd,nbdcnd,alpha,beta,gama,xnu,cofx,cofy, & + & singlr) +! +! this subroutine checks if the pde sepeli +! must solve is a singular operator +! + integer mbdcnd ,nbdcnd + BIGREAL alpha ,beta ,gama ,xnu + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly ,tdlx3 ,tdly3 , & + & dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + logical singlr + integer i ,j + BIGREAL ai ,bi ,ci ,xi , & + & dj ,ej ,fj ,yj + external cofx ,cofy + singlr = .false. +! +! check if the boundary conditions are +! entirely periodic and/or mixed +! + if ((mbdcnd.ne.0 .and. mbdcnd.ne.3) .or. & + & (nbdcnd.ne.0 .and. nbdcnd.ne.3)) return +! +! check that mixed conditions are pure neuman +! + if (mbdcnd .ne. 3) go to 10 + if (alpha.ne.0.0 .or. beta.ne.0.0) return + 10 if (nbdcnd .ne. 3) go to 20 + if (gama.ne.0.0 .or. xnu.ne.0.0) return + 20 continue +! +! check that non-derivative coefficient functions +! are zero +! + do 30 i=is,ms + xi = ait+float(i-1)*dlx + call cofx (xi,ai,bi,ci) + if (ci .ne. 0.0) return + 30 continue + do 40 j=js,ns + yj = cit+float(j-1)*dly + call cofy (yj,dj,ej,fj) + if (fj .ne. 0.0) return + 40 continue +! +! the operator must be singular if this point is reached +! + singlr = .true. + return + end + subroutine defer (cofx,cofy,idmn,n,usol,grhs) +! +! this subroutine first approximates the truncation error given by +! trun1(x,y)=dlx**2*tx+dly**2*ty where +! tx=afun(x)*uxxxx/12.0+bfun(x)*uxxx/6.0 on the interior and +! at the boundaries if periodic(here uxxx,uxxxx are the third +! and fourth partial derivatives of u with respect to x). +! tx is of the form afun(x)/3.0*(uxxxx/4.0+uxxx/dlx) +! at x=a or x=b if the boundary condition there is mixed. +! tx=0.0 along specified boundaries. ty has symmetric form +! in y with x,afun(x),bfun(x) replaced by y,dfun(y),efun(y). +! the second order solution in usol is used to approximate +! (via second order finite differencing) the truncation error +! and the result is added to the right hand side in grhs +! and then transferred to usol to be used as a new right +! hand side when calling blktri for a fourth order solution. +! + integer idmn ,n + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly ,tdlx3 ,tdly3 , & + & dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + BIGREAL grhs(idmn,n+1) ,usol(idmn,n+1) + external cofx ,cofy + integer i ,j + BIGREAL ai ,bi ,ci ,xi , & + & dj ,ej ,fj ,yj , & + & uxxx ,uxxxx ,uyyy ,uyyyy , & + & tx ,ty +! +! compute truncation error approximation over the entire mesh +! + do 40 j=js,ns + yj = cit+float(j-1)*dly + call cofy (yj,dj,ej,fj) + do 30 i=is,ms + xi = ait+float(i-1)*dlx + call cofx (xi,ai,bi,ci) +! +! compute partial derivative approximations at (xi,yj) +! + call sepdx (usol,idmn,i,j,uxxx,uxxxx) + call sepdy (usol,idmn,i,j,uyyy,uyyyy) + tx = ai*uxxxx/12.0+bi*uxxx/6.0 + ty = dj*uyyyy/12.0+ej*uyyy/6.0 +! +! reset form of truncation if at boundary which is non-periodic +! + if (kswx.eq.1 .or. (i.gt.1 .and. i.lt.k)) go to 10 + tx = ai/3.0*(uxxxx/4.0+uxxx/dlx) + 10 if (kswy.eq.1 .or. (j.gt.1 .and. j.lt.l)) go to 20 + ty = dj/3.0*(uyyyy/4.0+uyyy/dly) + 20 grhs(i,j) = grhs(i,j)+dlx**2*tx+dly**2*ty + 30 continue + 40 continue +! +! reset the right hand side in usol +! + do 60 i=is,ms + do 50 j=js,ns + usol(i,j) = grhs(i,j) + 50 continue + 60 continue + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +!----------------------------------------------------------------------- + end diff --git a/Utility/sepx4.F b/Utility/sepx4.F new file mode 100644 index 0000000..2d1b7b3 --- /dev/null +++ b/Utility/sepx4.F @@ -0,0 +1,1012 @@ + subroutine sepx4 (iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, & + & nbdcnd,bdc,bdd,cofx,grhs,usol,idmn,w,pertrb, & + & ierror) +! +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! * * +! * f i s h p a k * +! * * +! * * +! * a package of fortran subprograms for the solution of * +! * * +! * separable elliptic partial differential equations * +! * * +! * (version 3.2 , november 1988) * +! * * +! * by * +! * * +! * john adams, paul swarztrauber and roland sweet * +! * * +! * of * +! * * +! * the national center for atmospheric research * +! * * +! * boulder, colorado (80307) u.s.a. * +! * * +! * which is sponsored by * +! * * +! * the national science foundation * +! * * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! +! dimension of bda(n+1), bdb(n+1), bdc(m+1), bdd(m+1), +! arguments usol(idmn,n+1), grhs(idmn,n+1), +! w (see argument list) +! +! latest revision november 1988 +! +! purpose sepx4 solves for either the second-order +! finite difference approximation or a +! fourth-order approximation to a separable +! elliptic equation +! +! af(x)*uxx+bf(x)*ux+cf(x)*u+uyy = g(x,y) +! +! on a rectangle (x greater than or equal to +! a and less than or equal to b, y greater than +! or equal to c and less than or equal to d). +! any combination of periodic or mixed boundary +! conditions is allowed. if boundary +! conditions in the x direction are periodic +! (see mbdcnd=0 below) then the coefficients +! must satisfy +! +! af(x)=c1,bf(x)=0,cf(x)=c2 for all x. +! +! here c1,c2 are constants, c1.gt.0. +! +! the possible boundary conditions are: +! in the x-direction: +! (0) periodic, u(x+b-a,y)=u(x,y) for +! all y,x +! (1) u(a,y), u(b,y) are specified for all y +! (2) u(a,y), du(b,y)/dx+beta*u(b,y) are +! specified for all y +! (3) du(a,y)/dx+alpha*u(a,y),du(b,y)/dx+ +! beta*u(b,y) are specified for all y +! (4) du(a,y)/dx+alpha*u(a,y),u(b,y) are +! specified for all y +! +! in the y-direction: +! (0) periodic, u(x,y+d-c)=u(x,y) for all x,y +! (1) u(x,c),u(x,d) are specified for all x +! (2) u(x,c),du(x,d)/dy are specified for +! all x +! (3) du(x,c)/dy,du(x,d)/dy are specified for +! all x +! (4) du(x,c)/dy,u(x,d) are specified for +! all x +! +! usage call sepx4(iorder,a,b,m,mbdcnd,bda,alpha,bdb, +! beta,c,d,n,nbdcnd,bdc,bdd,cofx, +! grhs,usol,idmn,w,pertrb,ierror) +! +! arguments +! on input iorder +! = 2 if a second-order approximation is +! sought +! = 4 if a fourth-order approximation is +! sought +! +! a,b +! the range of the x-independent variable, +! i.e., x is greater than or equal to a +! and less than or equal to b. a must be +! less than b. +! +! m +! the number of panels into which the +! interval (a,b) is subdivided. hence, +! there will be m+1 grid points in the x- +! direction given by xi=a+(i-1)*dlx +! for i=1,2,...,m+1 where dlx=(b-a)/m is +! the panel width. m must be less than +! idmn and greater than 5. +! +! mbdcnd +! indicates the type of boundary condition +! at x=a and x=b +! = 0 if the solution is periodic in x, i.e., +! u(x+b-a,y)=u(x,y) for all y,x +! = 1 if the solution is specified at x=a +! and x=b, i.e., u(a,y) and u(b,y) are +! specified for all y +! = 2 if the solution is specified at x=a +! and the boundary condition is mixed at +! x=b, i.e., u(a,y) and +! du(b,y)/dx+beta*u(b,y) are specified +! for all y +! = 3 if the boundary conditions at x=a and +! x=b are mixed, i.e., +! du(a,y)/dx+alpha*u(a,y) and +! du(b,y)/dx+beta*u(b,y) are specified +! for all y +! = 4 if the boundary condition at x=a is +! mixed and the solution is specified +! at x=b, i.e., du(a,y)/dx+alpha*u(a,y) +! and u(b,y) are specified for all y +! +! bda +! a one-dimensional array of length n+1 that +! specifies the values of +! du(a,y)/dx+ alpha*u(a,y) at x=a, when +! mbdcnd=3 or 4. +! bda(j) = du(a,yj)/dx+alpha*u(a,yj), +! j=1,2,...,n+1 +! when mbdcnd has any other value, bda is +! a dummy parameter. +! +! alpha +! the scalar multiplying the solution in case +! of a mixed boundary condition at x=a +! (see argument bda). if mbdcnd is not equal +! to either 3 or 4, then alpha is a dummy +! parameter. +! +! bdb +! a one-dimensional array of length n+1 that +! specifies the values of +! du(b,y)/dx+ beta*u(b,y) at x=b. +! when mbdcnd=2 or 3 +! bdb(j) = du(b,yj)/dx+beta*u(b,yj), +! j=1,2,...,n+1 +! when mbdcnd has any other value, bdb is +! a dummy parameter. +! +! beta +! the scalar multiplying the solution in +! case of a mixed boundary condition at x=b +! (see argument bdb). if mbdcnd is not equal +! to 2 or 3, then beta is a dummy parameter. +! +! c,d +! the range of the y-independent variable, +! i.e., y is greater than or equal to c and +! less than or equal to d. c must be less +! than d. +! +! n +! the number of panels into which the +! interval (c,d) is subdivided. hence, +! there will be n+1 grid points in the y- +! direction given by yj=c+(j-1)*dly for +! j=1,2,...,n+1 where dly=(d-c)/n is the +! panel width. in addition, n must be +! greater than 4. +! +! nbdcnd +! indicates the types of boundary conditions +! at y=c and y=d +! = 0 if the solution is periodic in y, +! i.e., u(x,y+d-c)=u(x,y) for all x,y +! = 1 if the solution is specified at y=c +! and y = d, i.e., u(x,c) and u(x,d) +! are specified for all x +! = 2 if the solution is specified at y=c +! and the boundary condition is mixed +! at y=d, i.e., du(x,c)/dy and u(x,d) +! are specified for all x +! = 3 if the boundary conditions are mixed +! at y=cand y=d i.e., +! du(x,d)/dy and du(x,d)/dy are +! specified for all x +! = 4 if the boundary condition is mixed +! at y=c and the solution is specified +! at y=d, i.e. du(x,c)/dy+gama*u(x,c) +! and u(x,d) are specified for all x +! +! bdc +! a one-dimensional array of length m+1 that +! specifies the value du(x,c)/dy at y=c. +! +! when nbdcnd=3 or 4 +! bdc(i) = du(xi,c)/dy i=1,2,...,m+1. +! +! when nbdcnd has any other value, bdc is +! a dummy parameter. +! +! bdd +! a one-dimensional array of length m+1 that +! specified the value of du(x,d)/dy at y=d. +! +! when nbdcnd=2 or 3 +! bdd(i)=du(xi,d)/dy i=1,2,...,m+1. +! +! when nbdcnd has any other value, bdd is +! a dummy parameter. +! +! cofx +! a user-supplied subprogram with parameters +! x, afun, bfun, cfun which returns the +! values of the x-dependent coefficients +! af(x), bf(x), cf(x) in the elliptic +! equation at x. if boundary conditions in +! the x direction are periodic then the +! coefficients must satisfy af(x)=c1,bf(x)=0, +! cf(x)=c2 for all x. here c1.gt.0 +! and c2 are constants. +! +! note that cofx must be declared external +! in the calling routine. +! +! grhs +! a two-dimensional array that specifies the +! values of the right-hand side of the +! elliptic equation, i.e.,grhs(i,j)=g(xi,yi), +! for i=2,...,m, j=2,...,n. at the +! boundaries, grhs is defined by +! +! mbdcnd grhs(1,j) grhs(m+1,j) +! ------ --------- ----------- +! 0 g(a,yj) g(b,yj) +! 1 * * +! 2 * g(b,yj) j=1,2,...,n+1 +! 3 g(a,yj) g(b,yj) +! 4 g(a,yj) * +! +! nbdcnd grhs(i,1) grhs(i,n+1) +! ------ --------- ----------- +! 0 g(xi,c) g(xi,d) +! 1 * * +! 2 * g(xi,d) i=1,2,...,m+1 +! 3 g(xi,c) g(xi,d) +! 4 g(xi,c) * +! +! where * means these quantites are not used. +! grhs should be dimensioned idmn by at least +! n+1 in the calling routine. +! +! usol +! a two-dimensional array that specifies the +! values of the solution along the boundaries. +! at the boundaries, usol is defined by +! +! mbdcnd usol(1,j) usol(m+1,j) +! ------ --------- ----------- +! 0 * * +! 1 u(a,yj) u(b,yj) +! 2 u(a,yj) * j=1,2,...,n+1 +! 3 * * +! 4 * u(b,yj) +! +! nbdcnd usol(i,1) usol(i,n+1) +! ------ --------- ----------- +! 0 * * +! 1 u(xi,c) u(xi,d) +! 2 u(xi,c) * i=1,2,...,m+1 +! 3 * * +! 4 * u(xi,d) +! +! where * means the quantites are not used +! in the solution. +! +! if iorder=2, the user may equivalence grhs +! and usol to save space. note that in this +! case the tables specifying the boundaries +! of the grhs and usol arrays determine the +! boundaries uniquely except at the corners. +! if the tables call for both g(x,y) and +! u(x,y) at a corner then the solution must +! be chosen. +! for example, if mbdcnd=2 and nbdcnd=4, +! then u(a,c), u(a,d),u(b,d) must be chosen +! at the corners in addition to g(b,c). +! +! if iorder=4, then the two arrays, usol and +! grhs, must be distinct. +! +! usol should be dimensioned idmn by at least +! n+1 in the calling routine. +! +! idmn +! the row (or first) dimension of the arrays +! grhs and usol as it appears in the program +! calling sepeli. this parameter is used +! to specify the variable dimension of grhs +! and usol. idmn must be at least 7 and +! greater than or equal to m+1. +! +! w +! a one-dimensional array that must be +! provided by the user for work space. +! 10*n+(16+int(log2(n+1)))*(m+1)+11 will +! suffice as a length for w. the actual +! length of w in the calling routine +! must be set in w(1) (see ierror=11). +! +! +! on output usol +! contains the approximate solution to the +! elliptic equation. usol(i,j) is the +! approximation to u(xi,yj) for i=1,2...,m+1 +! and j=1,2,...,n+1. the approximation has +! error o(dlx**2+dly**2) if called with +! iorder=2 and o(dlx**4+dly**4) if called +! with iorder=4. +! +! w +! contains intermediate values that must not +! be destroyed if sepeli is called again +! with intl=1. in addition w(1) contains +! the exact minimal length (in floating point) +! required for the work space (see ierror=11). +! +! pertrb +! if a combination of periodic or derivative +! boundary conditions (i.e., alpha=beta=0 if +! mbdcnd=3) is specified and if cf(x)=0 for +! all x then a solution to the discretized +! matrix equation may not exist +! (reflecting the non-uniqueness of solutions +! to the pde). +! pertrb is a constant calculated and +! subtracted from the right hand side of the +! matrix equation insuring the existence of a +! solution. sepx4 computes this solution +! which is a weighted minimal least squares +! solution to the original problem. if +! singularity is not detected pertrb=0.0 is +! returned by sepx4. +! +! ierror +! an error flag that indicates invalid input +! parameters or failure to find a solution +! +! = 0 no error +! = 1 if a greater than b or c greater +! than d +! = 2 if mbdcnd less than 0 or mbdcnd +! greater than 4 +! = 3 if nbdcnd less than 0 or nbdcnd +! greater than 4 +! = 4 if attempt to find a solution fails. +! (the linear system generated is not +! diagonally dominant.) +! = 5 if idmn is too small (see discussion +! of idmn) +! = 6 if m is too small or too large +! (see discussion of m) +! = 7 if n is too small (see discussion of n) +! = 8 if iorder is not 2 or 4 +! = 9 if intl is not 0 or 1 +! = 10 if afun is less than or equal to zero +! for some interior mesh point xi some +! interior mesh point (xi,yj) +! = 11 if the work space length input in w(1) +! is less than the exact minimal work +! space length required output in w(1). +! = 12 if mbdcnd=0 and af(x)=cf(x)=constant +! or bf(x)=0 for all x is not true. +! +! special conditions none +! +! i/o none +! +! required library comf, genbun, gnbnaux, and sepaux +! files from fishpak +! +! +! precision single +! +! required library none +! files +! +! language fortran +! +! history sepx4 was developed at ncar by john c. +! adams of the scientific computing division +! in october 1978. the basis of this code is +! ncar routine sepeli. both packages were +! released on ncar's public libraries in +! january 1980. +! +! portability fortran 77 +! +! algorithm sepx4 automatically discretizes the separable +! elliptic equation which is then solved by a +! generalized cyclic reduction algorithm in the +! subroutine pois. the fourth order solution +! is obtained using the technique of defferred +! corrections referenced below. +! +! timing when possible, sepx4 should be used instead +! of package sepeli. the increase in speed +! is at least a factor of three. +! +! references keller, h.b., numerical methods for two-point +! boundary-value problems, blaisdel (1968), +! waltham, mass. +! +! swarztrauber, p., and r. sweet (1975): +! efficient fortran subprograms for the +! solution of elliptic partial differential +! equations. ncar technical note +! ncar-tn/ia-109, pp. 135-137. +!*********************************************************************** +#include "griddefs.h" + integer iorder, m, mbdcnd, n, nbdcnd, idmn, ierror + BIGREAL grhs(idmn,1) ,usol(idmn,1) + BIGREAL bda(*) ,bdb(*) ,bdc(*) ,bdd(*) , & + & w(*) + BIGREAL a, b, alpha, beta, c, d, pertrb + external cofx + +! local variables + integer k, l, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, & + & i11, i12, i13, log2n, linput, loutpt, length + +! +! check input parameters +! + call c4kprm(iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,idmn,ierror) + if (ierror .ne. 0) return +! +! compute minimum work space and check work space length input +! + l = n+1 + if (nbdcnd .eq. 0) l = n + k = m+1 + l = n+1 +! estimate log base 2 of n + log2n=int(alog(float(n+1))/alog(2.0)+0.5) + length=4*(n+1)+(10+log2n)*(m+1) + ierror = 11 + linput = int(w(1)+0.5) + loutpt = length+6*(k+l)+1 + w(1) = float(loutpt) + if (loutpt .gt. linput) return + ierror = 0 +! +! set work space indices +! + i1 = length+2 + i2 = i1+l + i3 = i2+l + i4 = i3+l + i5 = i4+l + i6 = i5+l + i7 = i6+l + i8 = i7+k + i9 = i8+k + i10 = i9+k + i11 = i10+k + i12 = i11+k + i13 = 2 + call s4elip(iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, & + & nbdcnd,bdc,bdd,cofx,w(i1),w(i2),w(i3), & + & w(i4),w(i5),w(i6),w(i7),w(i8),w(i9),w(i10),w(i11), & + & w(i12),grhs,usol,idmn,w(i13),pertrb,ierror) + return + end + + subroutine s4elip(iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, & + & nbdcnd,bdc,bdd,cofx,an,bn,cn,dn,un,zn,am,bm, & + & cm,dm,um,zm,grhs,usol,idmn,w,pertrb,ierror) +! +! s4elip sets up vectors and arrays for input to blktri +! and computes a second order solution in usol. a return jump to +! sepeli occurrs if iorder=2. if iorder=4 a fourth order +! solution is generated in usol. +! + integer iorder, m, mbdcnd, n, nbdcnd, idmn, ierror + BIGREAL bda(*) ,bdb(*) ,bdc(*) ,bdd(*) , & + & w(*) + BIGREAL grhs(idmn,1) ,usol(idmn,1) + BIGREAL an(*) ,bn(*) ,cn(*) ,dn(*) , & + & un(*) ,zn(*) + BIGREAL am(*) ,bm(*) ,cm(*) ,dm(*) , & + & um(*) ,zm(*) + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + logical singlr + external cofx + +! local variables + integer i, j, i1, mp, np, iord, ieror + BIGREAL a, b, c, d, alpha, beta, pertrb, ai, bi, ci, & + & xi, axi, bxi, cxi, dyj, eyj, fyj, ax1, cxm, & + & dy1, fyn, gama, xnu, prtrb +! +! set parameters internally +! + kswx = mbdcnd+1 + kswy = nbdcnd+1 + k = m+1 + l = n+1 + ait = a + bit = b + cit = c + dit = d + dly=(dit-cit)/float(n) +! +! set right hand side values from grhs in usol on the interior +! and non-specified boundaries. +! + do 20 i=2,m + do 10 j=2,n + usol(i,j)=dly**2*grhs(i,j) + 10 continue + 20 continue + if (kswx.eq.2 .or. kswx.eq.3) go to 40 + do 30 j=2,n + usol(1,j)=dly**2*grhs(1,j) + 30 continue + 40 continue + if (kswx.eq.2 .or. kswx.eq.5) go to 60 + do 50 j=2,n + usol(k,j)=dly**2*grhs(k,j) + 50 continue + 60 continue + if (kswy.eq.2 .or. kswy.eq.3) go to 80 + do 70 i=2,m + usol(i,1)=dly**2*grhs(i,1) + 70 continue + 80 continue + if (kswy.eq.2 .or. kswy.eq.5) go to 100 + do 90 i=2,m + usol(i,l)=dly**2*grhs(i,l) + 90 continue + 100 continue + if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.3) & + &usol(1,1)=dly**2*grhs(1,1) + if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.3) & + &usol(k,1)=dly**2*grhs(k,1) + if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.5) & + &usol(1,l)=dly**2*grhs(1,l) + if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.5) & + &usol(k,l)=dly**2*grhs(k,l) + i1 = 1 +! +! set switches for periodic or non-periodic boundaries +! + mp=1 + if(kswx.eq.1) mp=0 + np=nbdcnd +! +! set dlx,dly and size of block tri-diagonal system generated +! in nint,mint +! + dlx = (bit-ait)/float(m) + mit = k-1 + if (kswx .eq. 2) mit = k-2 + if (kswx .eq. 4) mit = k + dly = (dit-cit)/float(n) + nit = l-1 + if (kswy .eq. 2) nit = l-2 + if (kswy .eq. 4) nit = l + tdlx3 = 2.0*dlx**3 + dlx4 = dlx**4 + tdly3 = 2.0*dly**3 + dly4 = dly**4 +! +! set subscript limits for portion of array to input to blktri +! + is = 1 + js = 1 + if (kswx.eq.2 .or. kswx.eq.3) is = 2 + if (kswy.eq.2 .or. kswy.eq.3) js = 2 + ns = nit+js-1 + ms = mit+is-1 +! +! set x - direction +! + do 110 i=1,mit + xi = ait+float(is+i-2)*dlx + call cofx (xi,ai,bi,ci) + axi = (ai/dlx-0.5*bi)/dlx + bxi = -2.*ai/dlx**2+ci + cxi = (ai/dlx+0.5*bi)/dlx + am(i)=dly**2*axi + bm(i)=dly**2*bxi + cm(i)=dly**2*cxi + 110 continue +! +! set y direction +! + dyj=1.0 + eyj=-2.0 + fyj=1.0 + do 120 j=1,nit + an(j) = dyj + bn(j) = eyj + cn(j) = fyj + 120 continue +! +! adjust edges in x direction unless periodic +! + ax1 = am(1) + cxm = cm(mit) + go to (170,130,150,160,140),kswx +! +! dirichlet-dirichlet in x direction +! + 130 am(1) = 0.0 + cm(mit) = 0.0 + go to 170 +! +! mixed-dirichlet in x direction +! + 140 am(1) = 0.0 + bm(1) = bm(1)+2.*alpha*dlx*ax1 + cm(1) = cm(1)+ax1 + cm(mit) = 0.0 + go to 170 +! +! dirichlet-mixed in x direction +! + 150 am(1) = 0.0 + am(mit) = am(mit)+cxm + bm(mit) = bm(mit)-2.*beta*dlx*cxm + cm(mit) = 0.0 + go to 170 +! +! mixed - mixed in x direction +! + 160 continue + am(1) = 0.0 + bm(1) = bm(1)+2.*dlx*alpha*ax1 + cm(1) = cm(1)+ax1 + am(mit) = am(mit)+cxm + bm(mit) = bm(mit)-2.*dlx*beta*cxm + cm(mit) = 0.0 + 170 continue +! +! adjust in y direction unless periodic +! + dy1 = an(1) + fyn = cn(nit) + gama=0.0 + xnu=0.0 + go to (220,180,200,210,190),kswy +! +! dirichlet-dirichlet in y direction +! + 180 continue + an(1) = 0.0 + cn(nit) = 0.0 + go to 220 +! +! mixed-dirichlet in y direction +! + 190 continue + an(1) = 0.0 + bn(1) = bn(1)+2.*dly*gama*dy1 + cn(1) = cn(1)+dy1 + cn(nit) = 0.0 + go to 220 +! +! dirichlet-mixed in y direction +! + 200 an(1) = 0.0 + an(nit) = an(nit)+fyn + bn(nit) = bn(nit)-2.*dly*xnu*fyn + cn(nit) = 0.0 + go to 220 +! +! mixed - mixed direction in y direction +! + 210 continue + an(1) = 0.0 + bn(1) = bn(1)+2.*dly*gama*dy1 + cn(1) = cn(1)+dy1 + an(nit) = an(nit)+fyn + bn(nit) = bn(nit)-2.0*dly*xnu*fyn + cn(nit) = 0.0 + 220 if (kswx .eq. 1) go to 270 +! +! adjust usol along x edge +! + do 260 j=js,ns + if (kswx.ne.2 .and. kswx.ne.3) go to 230 + usol(is,j) = usol(is,j)-ax1*usol(1,j) + go to 240 + 230 usol(is,j) = usol(is,j)+2.0*dlx*ax1*bda(j) + 240 if (kswx.ne.2 .and. kswx.ne.5) go to 250 + usol(ms,j) = usol(ms,j)-cxm*usol(k,j) + go to 260 + 250 usol(ms,j) = usol(ms,j)-2.0*dlx*cxm*bdb(j) + 260 continue + 270 if (kswy .eq. 1) go to 320 +! +! adjust usol along y edge +! + do 310 i=is,ms + if (kswy.ne.2 .and. kswy.ne.3) go to 280 + usol(i,js) = usol(i,js)-dy1*usol(i,1) + go to 290 + 280 usol(i,js) = usol(i,js)+2.0*dly*dy1*bdc(i) + 290 if (kswy.ne.2 .and. kswy.ne.5) go to 300 + usol(i,ns) = usol(i,ns)-fyn*usol(i,l) + go to 310 + 300 usol(i,ns) = usol(i,ns)-2.0*dly*fyn*bdd(i) + 310 continue + 320 continue +! +! save adjusted edges in grhs if iorder=4 +! + if (iorder .ne. 4) go to 350 + do 330 j=js,ns + grhs(is,j) = usol(is,j) + grhs(ms,j) = usol(ms,j) + 330 continue + do 340 i=is,ms + grhs(i,js) = usol(i,js) + grhs(i,ns) = usol(i,ns) + 340 continue + 350 continue + iord = iorder + pertrb = 0.0 +! +! check if operator is singular +! + call c4ksng(mbdcnd,nbdcnd,alpha,beta,cofx,singlr) +! +! compute non-zero eigenvector in null space of transpose +! if singular +! + if (singlr) call septri (mit,am,bm,cm,dm,um,zm) + if (singlr) call septri (nit,an,bn,cn,dn,un,zn) +! +! adjust right hand side if necessary +! + 360 continue + if (singlr) call seport (usol,idmn,zn,zm,pertrb) +! +! compute solution +! +! save adjusted right hand side in grhs + do 444 j=js,ns + do 444 i=is,ms + grhs(i,j)=usol(i,j) + 444 continue + call genbun(np,nit,mp,mit,am,bm,cm,idmn,usol(is,js),ieror,w) +! check if error detected in pois +! this can only correspond to ierror=12 + if(ieror.eq.0) go to 224 +! set error flag if improper coefficients input to pois + ierror=12 + return + 224 continue + if (ierror .ne. 0) return +! +! set periodic boundaries if necessary +! + if (kswx .ne. 1) go to 380 + do 370 j=1,l + usol(k,j) = usol(1,j) + 370 continue + 380 if (kswy .ne. 1) go to 400 + do 390 i=1,k + usol(i,l) = usol(i,1) + 390 continue + 400 continue +! +! minimize solution with respect to weighted least squares +! norm if operator is singular +! + if (singlr) call sepmin (usol,idmn,zn,zm,prtrb) +! +! return if deferred corrections and a fourth order solution are +! not flagged +! + if (iord .eq. 2) return + iord = 2 +! +! compute new right hand side for fourth order solution +! + call d4fer(cofx,idmn,usol,grhs) + go to 360 + end + + subroutine c4kprm(iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,idmn, & + & ierror) + integer iorder, m, mbdcnd, n, nbdcnd, idmn, ierror + BIGREAL a, b, c, d + external cofx + +! local variables + integer i + BIGREAL ai, bi, ci, xi, dlx +! +! this program checks the input parameters for errors +! +! +! +! check definition of solution region +! + ierror = 1 + if (a.ge.b .or. c.ge.d) return +! +! check boundary switches +! + ierror = 2 + if (mbdcnd.lt.0 .or. mbdcnd.gt.4) return + ierror = 3 + if (nbdcnd.lt.0 .or. nbdcnd.gt.4) return +! +! check first dimension in calling routine +! + ierror = 5 + if (idmn .lt. 7) return +! +! check m +! + ierror = 6 + if (m.gt.(idmn-1) .or. m.lt.6) return +! +! check n +! + ierror = 7 + if (n .lt. 5) return +! +! check iorder +! + ierror = 8 + if (iorder.ne.2 .and. iorder.ne.4) return +! +! check intl +! +! +! check that equation is elliptic +! + dlx = (b-a)/float(m) + do 30 i=2,m + xi = a+float(i-1)*dlx + call cofx (xi,ai,bi,ci) + if (ai.gt.0.0) go to 10 + ierror=10 + return + 10 continue + 30 continue +! +! no error found +! + ierror = 0 + return + end + + subroutine c4ksng(mbdcnd,nbdcnd,alpha,beta,cofx,singlr) + integer mbdcnd, nbdcnd + BIGREAL alpha, beta + external cofx + logical singlr +! +! this subroutine checks if the pde sepeli +! must solve is a singular operator +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 +! local variables + integer i + BIGREAL ai, bi, ci, xi + + singlr = .false. +! +! check if the boundary conditions are +! entirely periodic and/or mixed +! + if ((mbdcnd.ne.0 .and. mbdcnd.ne.3) .or. & + & (nbdcnd.ne.0 .and. nbdcnd.ne.3)) return +! +! check that mixed conditions are pure neuman +! + if (mbdcnd .ne. 3) go to 10 + if (alpha.ne.0.0 .or. beta.ne.0.0) return + 10 continue +! +! check that non-derivative coefficient functions +! are zero +! + do 30 i=is,ms + xi = ait+float(i-1)*dlx + call cofx (xi,ai,bi,ci) + if (ci .ne. 0.0) return + 30 continue +! +! the operator must be singular if this point is reached +! + singlr = .true. + return + end + + subroutine d4fer(cofx,idmn,usol,grhs) + integer idmn + BIGREAL grhs(idmn,1) ,usol(idmn,1) + external cofx +! +! this subroutine first approximates the truncation error given by +! trun1(x,y)=dlx**2*tx+dly**2*ty where +! tx=afun(x)*uxxxx/12.0+bfun(x)*uxxx/6.0 on the interior and +! at the boundaries if periodic(here uxxx,uxxxx are the third +! and fourth partial derivatives of u with respect to x). +! tx is of the form afun(x)/3.0*(uxxxx/4.0+uxxx/dlx) +! at x=a or x=b if the boundary condition there is mixed. +! tx=0.0 along specified boundaries. ty has symmetric form +! in y with x,afun(x),bfun(x) replaced by y,dfun(y),efun(y). +! the second order solution in usol is used to approximate +! (via second order finite differencing) the truncation error +! and the result is added to the right hand side in grhs +! and then transferred to usol to be used as a new right +! hand side when calling blktri for a fourth order solution. +! + integer kswx ,kswy ,k ,l , & + & mit ,nit ,is ,ms , & + & js ,ns + BIGREAL ait ,bit ,cit ,dit , & + & dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 + common /splp/ kswx ,kswy ,k ,l , & + & ait ,bit ,cit ,dit , & + & mit ,nit ,is ,ms , & + & js ,ns ,dlx ,dly , & + & tdlx3 ,tdly3 ,dlx4 ,dly4 +! local variables + integer i, j + BIGREAL ai, bi, ci, xi, uxxx, uxxxx, uyyy, uyyyy, & + & tx, ty +! +! +! compute truncation error approximation over the entire mesh +! + do 30 i=is,ms + xi = ait+float(i-1)*dlx + call cofx (xi,ai,bi,ci) + do 30 j=js,ns +! +! compute partial derivative approximations at (xi,yj) +! + call sepdx (usol,idmn,i,j,uxxx,uxxxx) + call sepdy (usol,idmn,i,j,uyyy,uyyyy) + tx = ai*uxxxx/12.0+bi*uxxx/6.0 + ty=uyyyy/12.0 +! +! reset form of truncation if at boundary which is non-periodic +! + if (kswx.eq.1 .or. (i.gt.1 .and. i.lt.k)) go to 10 + tx = ai/3.0*(uxxxx/4.0+uxxx/dlx) + 10 if (kswy.eq.1 .or. (j.gt.1 .and. j.lt.l)) go to 20 + ty = (uyyyy/4.0+uyyy/dly)/3.0 + 20 grhs(i,j)=grhs(i,j)+dly**2*(dlx**2*tx+dly**2*ty) + 30 continue +! +! reset the right hand side in usol +! + do 60 i=is,ms + do 50 j=js,ns + usol(i,j) = grhs(i,j) + 50 continue + 60 continue + return +! +! revision history--- +! +! september 1973 version 1 +! april 1976 version 2 +! january 1978 version 3 +! december 1979 version 3.1 +! february 1985 documentation upgrade +! november 1988 version 3.2, fortran 77 changes +! june 1993 BIGREAL stuff added +!----------------------------------------------------------------------- + end + diff --git a/Utility/start_plot.F b/Utility/start_plot.F new file mode 100644 index 0000000..9fe6e02 --- /dev/null +++ b/Utility/start_plot.F @@ -0,0 +1,34 @@ +! ********************************************************************* +! Copyright (c) 1991, 1993, 1995 Rutgers University +! +! ********************************************************************* + + subroutine start_plot + +#include "griddefs.h" +#if PLOTS + +! Open and activate the GKS "workstation" + call gopks(6,0) +#if X_WIN + call gopwk(1,2,8) +#else + call gopwk(1,2,1) +#endif /* X_WIN */ + call gacwk(1) + +! Set some plotting parameters + call pcseti('QUALITY',1) ! medium quality font +! call pcseti('CD - complex/duplex',1) ! complex or duplex font + + return + end + + subroutine end_plot + call gdawk(1) + call gclwk(1) + call gclks + +#endif /* PLOTS */ + return + end diff --git a/Utility/uv_mask.F b/Utility/uv_mask.F new file mode 100644 index 0000000..53c9099 --- /dev/null +++ b/Utility/uv_mask.F @@ -0,0 +1,39 @@ + subroutine uv_mask + +! *** In gridpak version 5.4 ***** October 18, 2001 **************** +! Kate Hedstrom (kate@arsc.edu) +! John Wilkin (wilkin@imcs.rutgers.edu) +! ******************************************************************* + +#include "griddefs.h" +#include "bathy.h" +#include "ncgrid.h" + integer i, j + BIGREAL a1, a2, av2 + + av2(a1,a2) = .5*(a1+a2) + +#include "gridid.h" + +! Compute u, v masks. + do i=1,L + do j=0,M + mask_u(i,j) = mask_rho(i,j) * mask_rho(i-1,j) + enddo + enddo + do i=0,L + do j=1,M + mask_v(i,j) = mask_rho(i,j) * mask_rho(i,j-1) + enddo + enddo + +! Compute psi mask. + do i=1,L + do j=1,M + mask_psi(i,j) = mask_rho(i,j) * mask_rho(i-1,j) & + & * mask_rho(i,j-1) * mask_rho(i-1,j-1) + enddo + enddo + + return + end diff --git a/Utility/vminmax.F b/Utility/vminmax.F new file mode 100644 index 0000000..5153e3a --- /dev/null +++ b/Utility/vminmax.F @@ -0,0 +1,31 @@ +#include "griddefs.h" +! *********************************************************** + + BIGREAL function vmax(vect,N) + integer N + BIGREAL vect(N) + BIGREAL tmp + integer i + + tmp = vect(1) + do 100 i=2,N + tmp = max(tmp,vect(i)) + 100 continue + vmax = tmp + return + end + + BIGREAL function vmin(vect,N) + integer N + BIGREAL vect(N) + BIGREAL tmp + integer i + + tmp = vect(1) + do 100 i=2,N + tmp = min(tmp,vect(i)) + 100 continue + vmin = tmp + return + end + diff --git a/Utility/wrt_all.F b/Utility/wrt_all.F new file mode 100644 index 0000000..a6daf22 --- /dev/null +++ b/Utility/wrt_all.F @@ -0,0 +1,293 @@ +#include "griddefs.h" + + subroutine wrt_all +! +!======================================================================= +! === +! This routine writes fields into the grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global data. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + integer level + integer start(3), count(3) +! +!======================================================================= +! Begin Executable code. +!======================================================================= +! +! Open restart file for read/write. +! + rcode = nf90_open(TRIM(gridfile),nf90_write,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out Coriolis parameter. +! + rcode = nf90_inq_varid(ncgridid,'f',varid) + rcode = nf90_put_var(ncgridid,varid,f) + if (rcode.ne.0) then + write(stdout,10) 'f', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out bathymetry. +! + rcode = nf90_inq_varid(ncgridid,'h',varid) + rcode = nf90_put_var(ncgridid,varid,h) + if (rcode.ne.0) then + write(stdout,10) 'h', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Find out what slice to write into. +! + print *, 'There are ', bathsize, ' bathymetries.' + print *, 'Which level would you like to write to?' + read (5,*) level + if (level .lt. 1) then + call crash('Illegal level', level) + endif + if (level .gt. bathsize) then + level = bathsize+1 + bathsize = level + endif +! +! Write out next bathymetry into hraw. +! + start(1)=1 + count(1)=Lp + start(2)=1 + count(2)=Mp + start(3)=level + count(3)=1 + rcode=nf90_inq_varid(ncgridid,'hraw',varid) + rcode = nf90_put_var(ncgridid,varid,h,start,count) + if (rcode.ne.0) then + write(stdout,10) 'hraw', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out grid metrics. +! + rcode=nf90_inq_varid(ncgridid,'spherical',varid) + if (spherical) then + rcode = nf90_put_var(ncgridid,varid,'T') + else + rcode = nf90_put_var(ncgridid,varid,'F') + endif + if (rcode.ne.0) then + write(stdout,20) 'spherical', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'pm',varid) + rcode = nf90_put_var(ncgridid,varid,pm) + if (rcode.ne.0) then + write(stdout,20) 'pm', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'pn',varid) + rcode = nf90_put_var(ncgridid,varid,pn) + if (rcode.ne.0) then + write(stdout,20) 'pn', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'dndx',varid) + rcode = nf90_put_var(ncgridid,varid,dndx) + if (rcode.ne.0) then + write(stdout,20) 'dndx', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'dmde',varid) + rcode = nf90_put_var(ncgridid,varid,dmde) + if (rcode.ne.0) then + write(stdout,20) 'dmde', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! x,y grids. +! + rcode=nf90_inq_varid(ncgridid,'x_rho',varid) + rcode = nf90_put_var(ncgridid,varid,xr) + if (rcode.ne.0) then + write(stdout,20) 'x_rho', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_rho',varid) + rcode = nf90_put_var(ncgridid,varid,yr) + if (rcode.ne.0) then + write(stdout,20) 'y_rho', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_psi',varid) + rcode = nf90_put_var(ncgridid,varid,xp) + if (rcode.ne.0) then + write(stdout,20) 'x_psi', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_psi',varid) + rcode = nf90_put_var(ncgridid,varid,yp) + if (rcode.ne.0) then + write(stdout,20) 'y_psi', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_u',varid) + rcode = nf90_put_var(ncgridid,varid,xu) + if (rcode.ne.0) then + write(stdout,20) 'x_u', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_u',varid) + rcode = nf90_put_var(ncgridid,varid,yu) + if (rcode.ne.0) then + write(stdout,20) 'y_u', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'x_v',varid) + rcode = nf90_put_var(ncgridid,varid,xv) + if (rcode.ne.0) then + write(stdout,20) 'x_v', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'y_v',varid) + rcode = nf90_put_var(ncgridid,varid,yv) + if (rcode.ne.0) then + write(stdout,20) 'y_v', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out lat/lon at RHO-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_rho',varid) + rcode = nf90_put_var(ncgridid,varid,lat_rho) + if (rcode.ne.0) then + write(stdout,10) 'lat_rho', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_rho',varid) + rcode = nf90_put_var(ncgridid,varid,lon_rho) + if (rcode.ne.0) then + write(stdout,10) 'lon_rho', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out lat/lon at PSI-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_psi',varid) + rcode = nf90_put_var(ncgridid,varid,lat_psi) + if (rcode.ne.0) then + write(stdout,10) 'lat_psi', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_psi',varid) + rcode = nf90_put_var(ncgridid,varid,lon_psi) + if (rcode.ne.0) then + write(stdout,10) 'lon_psi', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out lat/lon at U-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_u',varid) + rcode = nf90_put_var(ncgridid,varid,lat_u) + if (rcode.ne.0) then + write(stdout,10) 'lat_u', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_u',varid) + rcode = nf90_put_var(ncgridid,varid,lon_u) + if (rcode.ne.0) then + write(stdout,10) 'lon_u', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out lat/lon at V-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_v',varid) + rcode = nf90_put_var(ncgridid,varid,lat_v) + if (rcode.ne.0) then + write(stdout,10) 'lat_v', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_v',varid) + rcode = nf90_put_var(ncgridid,varid,lon_v) + if (rcode.ne.0) then + write(stdout,10) 'lon_v', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out mask at RHO-points. +! + rcode = nf90_inq_varid(ncgridid,'mask_rho',varid) + rcode = nf90_put_var(ncgridid,varid,mask_rho) + if (rcode.ne.0) then + write(stdout,10) 'mask_rho', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out mask at U-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_u',varid) + rcode = nf90_put_var(ncgridid,varid,mask_u) + if (rcode.ne.0) then + write(stdout,10) 'mask_u', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out mask at V-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_v',varid) + rcode = nf90_put_var(ncgridid,varid,mask_v) + if (rcode.ne.0) then + write(stdout,10) 'mask_v', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out mask at PSI-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_psi',varid) + rcode = nf90_put_var(ncgridid,varid,mask_psi) + if (rcode.ne.0) then + write(stdout,10) 'mask_psi', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Write out grid angle. +! + rcode = nf90_inq_varid(ncgridid,'angle',varid) + rcode = nf90_put_var(ncgridid,varid,angle) + if (rcode.ne.0) then + write(stdout,10) 'angle', TRIM(gridfile) + call crash ('WRT_ALL',1) + endif +! +! Synchronize restart NetCDF file to disk to allow other processes to +! access data immediately after it is written. +! + rcode = nf90_sync(ncgridid) + if (rcode.ne.0) then + write(stdout,20) + call crash ('WRT_ALL',1) + endif +! + 10 format(/,' WRT_ALL - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file for time record: ',i4) + 20 format(/,' WRT_ALL - unable to synchronize grid NetCDF to ', & + & 'disk.') + return + end diff --git a/Utility/wrt_fhmn.F b/Utility/wrt_fhmn.F new file mode 100644 index 0000000..918a1d5 --- /dev/null +++ b/Utility/wrt_fhmn.F @@ -0,0 +1,135 @@ +#include "griddefs.h" + + subroutine wrt_fhmn(f0,beta) +! +!======================================================================= +! === +! This routine writes fields into the grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global data. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + BIGREAL f0, beta +! +!======================================================================= +! Begin Executable code. +!======================================================================= +! +! Open restart file for read/write. +! + rcode = nf90_open(TRIM(gridfile),nf90_write,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif +! +! Write out Coriolis parameter. +! + if (.not. spherical) then + rcode = nf90_inq_varid(ncgridid,'spherical',varid) + rcode = nf90_put_var(ncgridid,varid,'F') + if (rcode.ne.0) then + write(stdout,10) 'spherical', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'f0',varid) + rcode = nf90_put_var(ncgridid,varid,f0) + if (rcode.ne.0) then + write(stdout,10) 'f0', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'dfdy',varid) + rcode = nf90_put_var(ncgridid,varid,beta) + if (rcode.ne.0) then + write(stdout,10) 'dfdy', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + endif + rcode = nf90_inq_varid(ncgridid,'f',varid) + rcode = nf90_put_var(ncgridid,varid,f) + if (rcode.ne.0) then + write(stdout,10) 'f', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif +! +! Write out bathymetry. +! + rcode = nf90_inq_varid(ncgridid,'h',varid) + rcode = nf90_put_var(ncgridid,varid,h) + if (rcode.ne.0) then + write(stdout,10) 'h', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif +! +! Write out grid metrics. +! + rcode = nf90_inq_varid(ncgridid,'spherical',varid) + if (spherical) then + rcode = nf90_put_var(ncgridid,varid,'T') + if (rcode.ne.0) then + write(stdout,20) 'spherical', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'pm',varid) + rcode = nf90_put_var(ncgridid,varid,pm) + if (rcode.ne.0) then + write(stdout,10) 'pm', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'pn',varid) + rcode = nf90_put_var(ncgridid,varid,pn) + if (rcode.ne.0) then + write(stdout,10) 'pn', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'dndx',varid) + rcode = nf90_put_var(ncgridid,varid,dndx) + if (rcode.ne.0) then + write(stdout,10) 'dndx', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + rcode = nf90_inq_varid(ncgridid,'dmde',varid) + rcode = nf90_put_var(ncgridid,varid,dmde) + if (rcode.ne.0) then + write(stdout,10) 'dmde', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif + endif +! +! Write out grid angle. +! + rcode = nf90_inq_varid(ncgridid,'angle',varid) + rcode = nf90_put_var(ncgridid,varid,angle) + if (rcode.ne.0) then + write(stdout,10) 'angle', TRIM(gridfile) + call crash ('WRT_FHMN',1) + endif +! +! Synchronize restart NetCDF file to disk to allow other processes to +! access data immediately after it is written. +! + rcode = nf90_sync(ncgridid) + if (rcode.ne.0) then + write(stdout,20) + call crash ('WRT_FHMN',1) + endif +! + 10 format(/,' WRT_FHMN - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file for time record: ',i4) + 20 format(/,' WRT_FHMN - unable to synchronize grid NetCDF to ', & + & 'disk.') + return + end diff --git a/Utility/wrt_h.F b/Utility/wrt_h.F new file mode 100644 index 0000000..c350131 --- /dev/null +++ b/Utility/wrt_h.F @@ -0,0 +1,82 @@ +#include "griddefs.h" + + subroutine wrt_h +! +!======================================================================= +! === +! This routine writes bathymetry into grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global data. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + integer count(3), start(3) + integer level +! +!======================================================================= +! Begin Executable code. +!======================================================================= +! +! Open restart file for read/write. +! + rcode=nf90_open(TRIM(gridfile),nf90_write,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('WRT_H',1) + endif +! +! Find out what slice to write into. +! + print *, 'There are ', bathsize, ' bathymetries.' + print *, 'Which level would you like to write to?' + read (5,*) level + if (level .lt. 1) then + call crash('Illegal level', level) + endif + if (level .gt. bathsize) then + level = bathsize+1 + bathsize = level + endif +! +! Write out next bathymetry into hraw. +! + start(1)=1 + count(1)=Lp + start(2)=1 + count(2)=Mp + start(3)=level + count(3)=1 + rcode=nf90_inq_varid(ncgridid,'hraw',varid) + rcode = nf90_put_var(ncgridid,varid,h,start,count) + if (rcode.ne.0) then + write(stdout,10) 'hraw', TRIM(gridfile) + call crash ('WRT_H',1) + endif +! +! Synchronize restart NetCDF file to disk to allow other processes to +! access data immediately after it is written. +! + rcode = nf90_sync(ncgridid) + if (rcode.ne.0) then + write(stdout,20) + call crash ('WRT_H',1) + endif +! + 10 format(/,' WRT_H - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file for time record: ',i4) + 20 format(/,' WRT_H - unable to synchronize grid NetCDF to ', & + & 'disk.') + return + end diff --git a/Utility/wrt_lat.F b/Utility/wrt_lat.F new file mode 100644 index 0000000..2b30537 --- /dev/null +++ b/Utility/wrt_lat.F @@ -0,0 +1,151 @@ +#include "griddefs.h" + + subroutine wrt_lat +! +!======================================================================= +! === +! This routine writes latitude/longitude fields into grid === +! NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global data. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +#include "proj.h" +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + real lat(2) +! +!======================================================================= +! Begin Executable code. +!======================================================================= +! +! Open restart file for read/write. +! + rcode=nf90_open(TRIM(gridfile),nf90_write,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('WRT_LAT',1) + endif +! +! Write out map projection parameters. +! + rcode=nf90_inq_varid(ncgridid,'JPRJ',varid) + rcode = nf90_put_var(ncgridid,varid,JPRJ) + lat(1) = PLAT + if (JPRJ .eq. 'LC') then + lat(2) = ROTA + else + lat(2) = 0. + endif + rcode=nf90_inq_varid(ncgridid,'PLAT',varid) + rcode = nf90_put_var(ncgridid,varid,lat) + rcode=nf90_inq_varid(ncgridid,'PLONG',varid) + rcode = nf90_put_var(ncgridid,varid,PLONG) + if (JPRJ .eq. 'LC') then + lat(1) = 0. + else + lat(1) = ROTA + endif + rcode=nf90_inq_varid(ncgridid,'ROTA',varid) + rcode = nf90_put_var(ncgridid,varid,lat) + + rcode=nf90_inq_varid(ncgridid,'JLTS',varid) + rcode = nf90_put_var(ncgridid,varid,JLTS) + rcode=nf90_inq_varid(ncgridid,'P1',varid) + rcode = nf90_put_var(ncgridid,varid,P1) + rcode=nf90_inq_varid(ncgridid,'P2',varid) + rcode = nf90_put_var(ncgridid,varid,P2) + rcode=nf90_inq_varid(ncgridid,'P3',varid) + rcode = nf90_put_var(ncgridid,varid,P3) + rcode=nf90_inq_varid(ncgridid,'P4',varid) + rcode = nf90_put_var(ncgridid,varid,P4) + rcode=nf90_inq_varid(ncgridid,'XOFF',varid) + rcode = nf90_put_var(ncgridid,varid,XOFF) + rcode=nf90_inq_varid(ncgridid,'YOFF',varid) + rcode = nf90_put_var(ncgridid,varid,YOFF) +! +! Write out lat/lon at RHO-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_rho',varid) + rcode = nf90_put_var(ncgridid,varid,lat_rho) + if (rcode.ne.0) then + write(stdout,10) 'lat_rho', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_rho',varid) + rcode = nf90_put_var(ncgridid,varid,lon_rho) + if (rcode.ne.0) then + write(stdout,10) 'lon_rho', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif +! +! Write out lat/lon at PSI-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_psi',varid) + rcode = nf90_put_var(ncgridid,varid,lat_psi) + if (rcode.ne.0) then + write(stdout,10) 'lat_psi', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_psi',varid) + rcode = nf90_put_var(ncgridid,varid,lon_psi) + if (rcode.ne.0) then + write(stdout,10) 'lon_psi', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif +! +! Write out lat/lon at U-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_u',varid) + rcode = nf90_put_var(ncgridid,varid,lat_u) + if (rcode.ne.0) then + write(stdout,10) 'lat_u', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_u',varid) + rcode = nf90_put_var(ncgridid,varid,lon_u) + if (rcode.ne.0) then + write(stdout,10) 'lon_u', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif +! +! Write out lat/lon at V-points. +! + rcode=nf90_inq_varid(ncgridid,'lat_v',varid) + rcode = nf90_put_var(ncgridid,varid,lat_v) + if (rcode.ne.0) then + write(stdout,10) 'lat_v', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif + rcode=nf90_inq_varid(ncgridid,'lon_v',varid) + rcode = nf90_put_var(ncgridid,varid,lon_v) + if (rcode.ne.0) then + write(stdout,10) 'lon_v', TRIM(gridfile) + call crash ('WRT_LAT',1) + endif +! +! Synchronize restart NetCDF file to disk to allow other processes to +! access data immediately after it is written. +! + rcode = nf90_sync(ncgridid) + if (rcode.ne.0) then + write(stdout,20) + call crash ('WRT_LAT',1) + endif +! + 10 format(/,' WRT_LAT - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file for time record: ',i4) + 20 format(/,' WRT_LAT - unable to synchronize grid NetCDF to ', & + & 'disk.') + return + end diff --git a/Utility/wrt_mask.F b/Utility/wrt_mask.F new file mode 100644 index 0000000..16bfbb7 --- /dev/null +++ b/Utility/wrt_mask.F @@ -0,0 +1,97 @@ +#include "griddefs.h" + + subroutine wrt_mask +! +!======================================================================= +! === +! This routine writes the masks into grid NetCDF file. === +! === +!======================================================================= +! +!----------------------------------------------------------------------- +! Define global data. +!----------------------------------------------------------------------- +! + use netcdf + +#include "bathy.h" +#include "ncgrid.h" +! +!----------------------------------------------------------------------- +! Define local data. +!----------------------------------------------------------------------- +! + BIGREAL bvar +! +!======================================================================= +! Begin Executable code. +!======================================================================= +! +! Open restart file for read/write. +! + rcode=nf90_open(TRIM(gridfile),nf90_write,ncgridid) + if ((rcode.ne.0).or.(ncgridid.eq.-1)) then + write(stdout,10) TRIM(gridfile) + call crash ('WRT_MASK',1) + endif +! +! Write out bathymetry clipping depths. +! + bvar = depthmin + rcode = nf90_inq_varid(ncgridid,'depthmin',varid) + rcode = nf90_put_var(ncgridid,varid,bvar) + bvar = depthmax + rcode = nf90_inq_varid(ncgridid,'depthmax',varid) + rcode = nf90_put_var(ncgridid,varid,bvar) +! +! Write out mask at RHO-points. +! + rcode = nf90_inq_varid(ncgridid,'mask_rho',varid) + rcode = nf90_put_var(ncgridid,varid,mask_rho) + if (rcode.ne.0) then + write(stdout,10) 'mask_rho', TRIM(gridfile) + call crash ('WRT_MASK',1) + endif +! +! Write out mask at U-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_u',varid) + rcode = nf90_put_var(ncgridid,varid,mask_u) + if (rcode.ne.0) then + write(stdout,10) 'mask_u', TRIM(gridfile) + call crash ('WRT_MASK',1) + endif +! +! Write out mask at V-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_v',varid) + rcode = nf90_put_var(ncgridid,varid,mask_v) + if (rcode.ne.0) then + write(stdout,10) 'mask_v', TRIM(gridfile) + call crash ('WRT_MASK',1) + endif +! +! Write out mask at PSI-points. +! + rcode=nf90_inq_varid(ncgridid,'mask_psi',varid) + rcode = nf90_put_var(ncgridid,varid,mask_psi) + if (rcode.ne.0) then + write(stdout,10) 'mask_psi', TRIM(gridfile) + call crash ('WRT_MASK',1) + endif +! +! Synchronize restart NetCDF file to disk to allow other processes to +! access data immediately after it is written. +! + rcode = nf90_sync(ncgridid) + if (rcode.ne.0) then + write(stdout,20) + call crash ('WRT_MASK',1) + endif +! + 10 format(/,' WRT_MASK - error while writing variable: ',a,/,11x, & + & 'into grid NetCDF file for time record: ',i4) + 20 format(/,' WRT_MASK - unable to synchronize grid NetCDF to ', & + & 'disk.') + return + end diff --git a/makefile b/makefile new file mode 100644 index 0000000..893a17f --- /dev/null +++ b/makefile @@ -0,0 +1,346 @@ +#:::::::::::::::::::::::::::::::::::::::::::::::::::::::: Kate Hedstrom ::: +# ::: +# ROMS/TOMS Gridpak Code Master Makefile ::: +# ::: +# This makefile is designed to work only with GNU Make version 3.77 or ::: +# higher. It can be used in any architecture provided that there is a ::: +# machine/compiler rules file in the "Compilers" subdirectory. You ::: +# may need to modify the rules file to specify the correct path for ::: +# the NetCDF and ARPACK libraries. The ARPACK library is only used in ::: +# the Generalized Stability Theory analysis. ::: +# ::: +# If appropriate, the USER needs to modify the macro definitions in ::: +# in user-defined section below. To activate an option set the macro ::: +# to "on". For example, if you want to compile with debugging options ::: +# set: ::: +# ::: +# DEBUG := on ::: +# ::: +# Otherwise, leave macro definition blank. ::: +# ::: +# The USER needs to provide a value for the macro FORT. Choose the ::: +# appropriate value from the list below. ::: +# ::: +#::::::::::::::::::::::::::::::::::::::::::::::::::::: Hernan G. Arango ::: + + +NEED_VERSION := 3.80 3.81 +$(if $(filter $(MAKE_VERSION),$(NEED_VERSION)),, \ + $(error This makefile requires one of GNU make version $(NEED_VERSION).)) + + +#-------------------------------------------------------------------------- +# Initialize some things. +#-------------------------------------------------------------------------- + + sources := + libraries := + +#========================================================================== +# Start of user-defined options. Modify macro variables: on is TRUE while +# blank is FALSE. +#========================================================================== +# +# Activate debugging compiler options: + + DEBUG := + +# If parallel applications, use at most one of these definitions +# (leave both definitions blank in serial applications): + + MPI := + OpenMP := + +# If applicable, compile with the ARPACK library (GST analysis): + + ARPACK := + +# If applicable, activate 64-bit compilation: + + LARGE := + +#-------------------------------------------------------------------------- +# We are going to include a file with all the settings that depend on +# the system and the compiler. We are going to build up the name of the +# include file using information on both. Set your compiler here from +# the following list: +# +# Operating System Compiler(s) +# +# AIX: xlf +# ALPHA: f90 +# CYGWIN: g95, df +# Darwin: f90 +# IRIX: f90 +# Linux: ifc, ifort, pgi, path, g95, mpif90 +# SunOS: f95 +# UNICOS-mp: ftn +# SunOS/Linux: ftn (Cray cross-compiler) +# +# Feel free to send us additional rule files to include! Also, be sure +# to check the appropriate file to make sure it has the right paths to +# NetCDF and so on. +#-------------------------------------------------------------------------- + + FORT ?= gfortran + +#-------------------------------------------------------------------------- +# Set directory for executable. +#-------------------------------------------------------------------------- + + BINDIR := . + +#========================================================================== +# End of user-defined options. See also the machine-dependent include +# file being used above. +#========================================================================== + +#-------------------------------------------------------------------------- +# Set directory for temporary objects. +# #-------------------------------------------------------------------------- + +SCRATCH_DIR ?= Build + clean_list := core *.ipo $(SCRATCH_DIR) + +ifeq "$(strip $(SCRATCH_DIR))" "." + clean_list := core *.o *.oo *.mod *.f90 lib*.a *.bak + clean_list += $(CURDIR)/*.ipo +endif +ifeq "$(strip $(SCRATCH_DIR))" "./" + clean_list := core *.o *.oo *.ipo *.mod *.f90 lib*.a *.bak + clean_list += $(CURDIR)/*.ipo +endif + +#-------------------------------------------------------------------------- +# Make functions for putting the temporary files in $(SCRATCH_DIR) +# # DO NOT modify this section; spaces and blank lines are needed. +#-------------------------------------------------------------------------- + +# $(call source-dir-to-binary-dir, directory-list) +source-dir-to-binary-dir = $(addprefix $(SCRATCH_DIR)/, $(notdir $1)) + +# $(call source-to-object, source-file-list) +source-to-object = $(call source-dir-to-binary-dir, \ + $(subst .F,.o,$1)) + +# $(call source-to-object, source-file-list) +c-source-to-object = $(call source-dir-to-binary-dir, \ + $(subst .c,.o,$(filter %.c,$1)) \ + $(subst .cc,.o,$(filter %.cc,$1))) + +$(call make-library, library-name, source-file-list) +define make-library + libraries += $(SCRATCH_DIR)/$1 + sources += $2 + + $(SCRATCH_DIR)/$1: $(call source-dir-to-binary-dir, \ + $(subst .F,.o,$2)) + $(AR) $(ARFLAGS) $$@ $$^ + $(RANLIB) $$@ +endef + +$(call make-c-library, library-name, source-file-list) +define make-c-library + libraries += $(SCRATCH_DIR)/$1 + c_sources += $2 + + $(SCRATCH_DIR)/$1: $(call source-dir-to-binary-dir, \ + $(subst .c,.o,$(filter %.c,$2)) \ + $(subst .cc,.o,$(filter %.cc,$2))) + $(AR) $(ARFLAGS) $$@ $$^ + $(RANLIB) $$@ +endef + +# $(call f90-source, source-file-list) +f90-source = $(call source-dir-to-binary-dir, \ + $(subst .F,.f90,$1)) + +# $(compile-rules) +define compile-rules + $(foreach f, $(local_src), \ + $(call one-compile-rule,$(call source-to-object,$f), \ + $(call f90-source,$f),$f)) +endef + +# $(c-compile-rules) +define c-compile-rules + $(foreach f, $(local_c_src), \ + $(call one-c-compile-rule,$(call c-source-to-object,$f), $f)) +endef + +# $(call one-compile-rule, binary-file, f90-file, source-file) +define one-compile-rule + $1: $2 $3 + cd $$(SCRATCH_DIR); $$(FC) -c $$(FFLAGS) $(notdir $2) + + $2: $3 + $$(CPP) $$(CPPFLAGS) $$(MY_CPP_FLAGS) $$< > $$@ + $$(CLEAN) $$@ + +endef + +# $(call one-c-compile-rule, binary-file, source-file) +define one-c-compile-rule + $1: $2 + cd $$(SCRATCH_DIR); $$(CXX) -c $$(CXXFLAGS) $$< + +endef + +#-------------------------------------------------------------------------- +# Set ROMS/TOMS executable file name. +#-------------------------------------------------------------------------- + +COAST := $(BINDIR)/coast +GRID := $(BINDIR)/grid +SQGRID := $(BINDIR)/sqgrid +TOLAT := $(BINDIR)/tolat +BATHTUB := $(BINDIR)/bathtub +BATHSUDS := $(BINDIR)/bathsuds +BATHSOAP := $(BINDIR)/bathsoap +SPHERE := $(BINDIR)/sphere +ifdef DEBUG + COAST := $(BINDIR)/coastG + GRID := $(BINDIR)/gridG + SQGRID := $(BINDIR)/sqgridG + TOLAT := $(BINDIR)/tolatG + BATHTUB := $(BINDIR)/bathtubG + BATHSUDS := $(BINDIR)/bathsudsG + BATHSOAP := $(BINDIR)/bathsoapG + SPHERE := $(BINDIR)/sphereG +endif + +#-------------------------------------------------------------------------- +# Set name of module files for netCDF F90 interface. On some platforms +# these will need to be overridden in the machine-dependent include file. +#-------------------------------------------------------------------------- + + NETCDF_MODFILE := netcdf.mod +TYPESIZES_MODFILE := typesizes.mod + +#-------------------------------------------------------------------------- +# "uname -s" should return the OS or kernel name and "uname -m" should +# return the CPU or hardware name. In practice the results can be pretty +# flaky. Run the results through sed to convert "/" and " " to "-", +# then apply platform-specific conversions. +#-------------------------------------------------------------------------- + +OS := $(shell uname -s | sed 's/[\/ ]/-/g') +OS := $(patsubst CYGWIN_%,CYGWIN,$(OS)) +OS := $(patsubst sn%,UNICOS-sn,$(OS)) + +CPU := $(shell uname -m | sed 's/[\/ ]/-/g') + +ifndef FORT + $(error Variable FORT not set) +endif + +ifneq "$(MAKECMDGOALS)" "clean" + include Compilers/$(OS)-$(strip $(FORT)).mk +endif + +#-------------------------------------------------------------------------- +# Pass the platform variables to the preprocessor as macros. Convert to +# valid, upper-case identifiers. +#-------------------------------------------------------------------------- + +CPPFLAGS += -D$(shell echo ${OS} | tr "-" "_" | tr [a-z] [A-Z]) +CPPFLAGS += -D$(shell echo ${CPU} | tr "-" "_" | tr [a-z] [A-Z]) +CPPFLAGS += -D$(shell echo ${FORT} | tr "-" "_" | tr [a-z] [A-Z]) + +#-------------------------------------------------------------------------- +# Build target directories. +#-------------------------------------------------------------------------- + +.PHONY: all + +all: $(SCRATCH_DIR) $(SCRATCH_DIR)/MakeDepend $(COAST) $(GRID) $(SQGRID) \ + $(TOLAT) $(BATHTUB) $(BATHSUDS) $(BATHSOAP) $(SPHERE) + +modules := Utility Drivers + +includes := Include + +vpath %.F $(modules) +vpath %.h $(includes) +vpath %.f90 $(SCRATCH_DIR) +vpath %.o $(SCRATCH_DIR) + +include $(addsuffix /Module.mk,$(modules)) + +MDEPFLAGS += $(patsubst %,-I %,$(includes)) --silent --moddir=$(SCRATCH_DIR) + +CPPFLAGS += $(patsubst %,-I%,$(includes)) + +$(SCRATCH_DIR): + $(shell $(TEST) -d $(SCRATCH_DIR) || $(MKDIR) $(SCRATCH_DIR) ) + +#-------------------------------------------------------------------------- +.PHONY: libraries + +libraries: $(libraries) + +#-------------------------------------------------------------------------- +# Target to create ROMS/TOMS dependecies. +#-------------------------------------------------------------------------- + +$(SCRATCH_DIR)/$(NETCDF_MODFILE): | $(SCRATCH_DIR) + cp -f $(NETCDF_INCDIR)/$(NETCDF_MODFILE) $(SCRATCH_DIR) + +$(SCRATCH_DIR)/$(TYPESIZES_MODFILE): | $(SCRATCH_DIR) + cp -f $(NETCDF_INCDIR)/$(TYPESIZES_MODFILE) $(SCRATCH_DIR) + +$(SCRATCH_DIR)/MakeDepend: makefile \ + $(SCRATCH_DIR)/$(NETCDF_MODFILE) \ + $(SCRATCH_DIR)/$(TYPESIZES_MODFILE) \ + | $(SCRATCH_DIR) + $(SFMAKEDEPEND) $(MDEPFLAGS) $(sources) > $(SCRATCH_DIR)/MakeDepend + +.PHONY: depend + +SFMAKEDEPEND := ./Bin/sfmakedepend + +depend: $(SCRATCH_DIR) + $(SFMAKEDEPEND) $(MDEPFLAGS) $(sources) > $(SCRATCH_DIR)/MakeDepend + +ifneq "$(MAKECMDGOALS)" "clean" + -include $(SCRATCH_DIR)/MakeDepend +endif + +#-------------------------------------------------------------------------- +# Target to create ROMS/TOMS tar file. +#-------------------------------------------------------------------------- + +.PHONY: tarfile + +tarfile: + tar -cvf gridpak.tar * + +.PHONY: zipfile + +zipfile: + zip -r gridpak.zip * + + +#-------------------------------------------------------------------------- +# Cleaning targets. +#-------------------------------------------------------------------------- + +.PHONY: clean + +clean: + $(RM) -r $(clean_list) + +#-------------------------------------------------------------------------- +# A handy debugging target. This will allow to print the value of any +# makefile defined macro (see http://tinyurl.com/8ax3j). For example, +# to find the value of CPPFLAGS execute: +# +# gmake print-CPPFLAGS +# or +# make print-CPPFLAGS +#-------------------------------------------------------------------------- + +.PHONY: print-% + +print-%: + @echo $* = $($*)