See section III-5.
-
-
-This file was last modified on Monday,
--- nec-2.orig/doc/NECdoc/cards/xq.html
+++ nec-2/doc/NECdoc/cards/xq.html
@@ -1,6 +1,3 @@
-
-
-
Execute (XQ)
Execute (XQ)
@@ -51,9 +48,6 @@
specified. For these cases, the RP card is used where the presence
of the additional ground parameters is indicated.
-
-
-This file was last modified on
--- nec-2.orig/doc/NECdoc/examples/ex1.txt
+++ nec-2/doc/NECdoc/examples/ex1.txt
@@ -0,0 +1,10 @@
+TESTEX1
+CEEXAMPLE 1. CENTER FED LINEAR ANTENNA
+GW 0,7,0.,0.,-.25,0.,0.,.25,.001
+GE
+EX 0 0 4 0 1.
+XQ
+LD 0 0 4 4 10. 3.000E-09 5.300E-11
+PQ
+NE 0 1 1 15 .001 0 0 0. 0. .01786
+EN
--- nec-2.orig/doc/NECdoc/examples/ex2.txt
+++ nec-2/doc/NECdoc/examples/ex2.txt
@@ -0,0 +1,15 @@
+TESTEX2
+CMEXAMPLE 2. CENTER FED LINEAR ANTENNA.
+CM CURRENT SLOPE DISCONTINUITY SOURCE.
+CM 1. THIN PERFECTLY CONDUCTING WIRE
+CE 2. THIN ALUMINUM WIRE
+GW 0 8 0. 0. -.25 0. 0. .25 .00001
+GE
+FR 0 3 0 0 200. 50.
+EX 5 0 5 1 1. 0. 50.
+XQ
+LD 5 0 0 0 3.720E+07
+FR 0 1 0 0 300.
+EX 5 0 5 0 1.
+XQ
+EN
--- nec-2.orig/doc/NECdoc/examples/ex3.txt
+++ nec-2/doc/NECdoc/examples/ex3.txt
@@ -0,0 +1,20 @@
+TESTEX3
+CMEXAMPLE 3. VERTICAL HALF WAVELENGTH ANTENNA OVER GROUND
+CM EXTENDED THIN WIRE KERNEL USED
+CM 1. PERFECT GROUND
+CM 2. IMPERFECT GROUND INCLUDING GROUND WAVE AND RECEIVING
+CE PATTERN CALCULATIONS
+GW 0 9 0. 0. 2. 0. 0. 7. .3
+GE 1
+EK
+FR 0 1 0 0 30.
+EX 0 0 5 0 1.
+GN 1
+RP 0 10 2 1301 0. 0. 10. 90.
+GN 0 0 0 0 6. 1.000E-03
+RP 0 10 2 1301 0. 0. 10. 90.
+RP 1 10 1 0 1. 0. 2. 0. 1.000E+05
+EX 1 10 1 0 0. 0. 0. 10.
+PT 2 0 5 5
+XQ
+EN
--- nec-2.orig/doc/NECdoc/examples/ex4.txt
+++ nec-2/doc/NECdoc/examples/ex4.txt
@@ -0,0 +1,14 @@
+TESTEX4
+CEEXAMPLE 4. T ANTENNA ON A BOX OVER PERFECT GROUND
+SP 0 0 .1 .05 .05 0. 0. .01
+SP 0 0 .05 .1 .05 0. 90. .01
+GX 0 110
+SP 0 0 0. 0. .1 90. 0. .04
+GW 1 4 0. 0. .1 0. 0. .3 .001
+GW 2 2 0. 0. .3 .15 0. .3 .001
+GW 3 2 0. 0. .3 -.15 0. .3 .001
+GE 1
+GN 1
+EX 0 1 1 0 1.
+RP 0 10 4 1001 0. 0. 10. 30.
+EN
--- nec-2.orig/doc/NECdoc/examples/ex5.txt
+++ nec-2/doc/NECdoc/examples/ex5.txt
@@ -0,0 +1,33 @@
+TESTEX5
+CM 12 ELEMENT LOG PERIODIC ANTENNA IN FREE SPACE
+CM 78 SEGMENTS. SIGMA=O/L RECEIVING AND TRANS. PATTERNS.
+CM DIPOLE LENGTH TO DIAMETER RATIO=150.
+CE TAU=0.93. SIGMA=0.70. BOOM IMPEDANCE=50. OHMS.
+GW 1 5 0.0000 -1.0000 0.0000000 0.00000 1.0000 0.000 .00667
+GW 2 5 -.7527 -1.0753 0. -.7527 1.0753 0. .00717
+GW 3 5 -1.562 -1.1562 0. -1.562 1.1562 0. .00771
+GW 4 5 -2.4323 -1.2432 0. -2.4323 1.2432 0. .00829
+GW 5 5 -3.368 -1.3368 0. -3.368 1.3368 0. .00891
+GW 6 7 -4.3742 -1.4374 0. -4.3742 1.4374 0. .00958
+GW 7 7 -5.4562 -1.5456 0. -5.4562 1.5456 0. .0103
+GW 8 7 -6.6195 -1.6619 0. -6.6195 1.6619 0. .01108
+GW 9 7 -7.8705 -1.787 0. -7.8705 1.787 0. .01191
+GW 10 7 -9.2156 -1.9215 0. -9.2156 1.9215 0. .01281
+GW 11 9 -10.6619 -2.0662 0. -10.6619 2.0662 0. .01377
+GW 12 9 -12.2171 -2.2217 0. -12.2171 2.2217 0. .01481
+GE
+FR 0 0 0 0 46.29 0.
+TL 1 3 2 3 -50.
+TL 2 3 3 3 -50.
+TL 3 3 4 3 -50.
+TL 4 3 5 3 -50.
+TL 5 3 6 4 -50.
+TL 6 4 7 4 -50.
+TL 7 4 8 4 -50.
+TL 8 4 9 4 -50.
+TL 9 4 10 4 -50.
+TL 10 4 11 5 -50.
+TL 11 5 12 5 -50. ,0.,0.,0.,.02
+EX 0 1 3 10 1
+RP 0 37 1 1110 90. 0. -5. 0.
+EN
--- nec-2.orig/doc/NECdoc/examples/ex6.txt
+++ nec-2/doc/NECdoc/examples/ex6.txt
@@ -0,0 +1,22 @@
+TESTEX6
+CECYLINDER WITH ATTACHED WIRES
+SP 0 0 10 0 7.3333 0. 0. 38.4
+SP 0 0 10 0 0. 0. 0. 38.4
+SP 0 0 10 0 -7.3333 0. 0. 38.4
+GM 0 1 0. 0. 30.
+SP 0 0 6.89 0. 11. 90. 0. 44.88
+SP 0 0 6.89 0. -11. -90. 0. 44.88
+GR 0 6
+SP 0 0 0. 0. 11. 90. 0. 44.89
+SP 0 0 0. 0. -11. -90. 0. 44.89
+GW 1 4 0. 0. 11. 0. 0. 23. .1
+GW 2 5 10. 0. 0. 27.6 0. 0. .2
+GS,0,0,.01
+GE
+FR,0,1,0,0,465.84
+CP 1 1 2 1
+EX 0 1 1 1.
+RP 0 73 1 1000 0. 0. 5. 0.
+EX 0 2 1 0 1.
+XQ
+EN
--- nec-2.orig/doc/NECdoc/examples/ex7.txt
+++ nec-2/doc/NECdoc/examples/ex7.txt
@@ -0,0 +1,18 @@
+TESTEX7
+CMSAMPLE PROBLEM FOR NEC
+CESTICK MODEL OF AIRCRAFT - FREE SPACE
+GW 1, 1, 0., 0., 0., 6., 0., 0., 1.,
+GW 2 6 6. 0. 0. 44. 0. 0. 1.
+GW 3 4 44. 0. 0. 68. 0. 0. 1.
+GW 4 6 44. 0. 0. 24. 29.9 0. 1.
+GW 5 6 44. 0. 0. 24. -29.9 0. 1.
+GW 6 2 6. 0. 0. 2. 11.3 0. 1.
+GW 7 2 6. 0. 0. 2. -11.3 0. 1.
+GW 8 2 6. 0. 0. 2. 0. 10. 1.
+GE
+FR 0 1 0 0 3.
+EX 1 1 1 0 0.
+RP 0 1 1 1000 0. 0. 0.
+EX 1 1 1 0 90. 30. -90.
+RP 0 1 1 1000 90. 30.
+EN
--- nec-2.orig/doc/NECdoc/examples/examp1-4.html
+++ nec-2/doc/NECdoc/examples/examp1-4.html
@@ -1,10 +1,10 @@
-
+
Examples 1 through 4
EXAMPLES 1 THROUGH 4
Examples 1 through 4 are simple cases intended to illustrate the basic
-formats. Example1 includes a calculation of
+formats. Example 1 includes a calculation of
near-electric-field along the wire. When the field is computed at the center of
a segment without an applied field or loading, the Z-component of electric field
is small since the solution procedure enforces the boungary condition at these
@@ -16,28 +16,31 @@
along the wire axis, the radial field would be set to zero. for a nonplaner
structur, however, computation along the axis is the only way to reproduce the
conditions of the current solution and obtain small fields at the match points.
-
In example 2 the wire has an even number of segments so
+
In example 2 the wire has an even number of segments so
that a charge-discontinuity voltage source can be used at the center. The
symble "*" in the table of antenna input parameters is a reminder that this type
of source has been used. Three frequencies are run for this case and the EX
card option is used to collect and normalize the input impedances. At the end
-of example 2 the wire is given the conductivity of aluminum.
+of example 2 the wire is given the conductivity of aluminum.
This has a significant effect since the wire is relatively thin.
-
example 3 is a vertical dipole over ground. Since the wire
+
+
+Example 3 is a vertical dipole over ground. Since the wire
is thick the extended thin-wire approzimation has been used. Computation of the
average power gain is requested on the RP cards. Over a perfectly conductive
ground the average power gain should be 2. The computed result differs by about
1.5%, probably due to the 10-degree steps used in integration the radiated
power. For a more comples structure, the average gain can provide a check on
the accuracy of the computed input impedance over a perfect ground where it
-should equal 2 or in free space where it should equal 1. example
+should equal 2 or in free space where it should equal 1. Example
3 also includes a finitely conducting ground whwere the average gain of 0.72
indicates that only 36% of the power leaving the antenna is going into the space
wave. The formats for normalized gain and tht combined space-save and
-ground-wave fields are illustrated. At the end of example 3,
+ground-wave fields are illustrated. At the end of example 3,
the wire is excited with an incident wave at 10-degree angles and the PT card
option is used to print receiving antenna patterns.
-
example4 includes both patches and wires. Although the
+
+
Example 4 includes both patches and wires. Although the
structure is over a perfect ground, the average power gain is 1.8. This
indicates that the input impedance is inaccurate, probably due to the crude
patch model used for the box. Since there is no omic loss, a more accurate
--- nec-2.orig/doc/NECdoc/examples/examp5.html
+++ nec-2/doc/NECdoc/examples/examp5.html
@@ -3,7 +3,7 @@
Example 5
-Example 5 is a practical log-periodic antenna with 12
+
Example 5 is a practical log-periodic antenna with 12
elements. Input data for the transmission line sections is printed in the table
"Network Data." The table "Structure Excitation Data at Network connection
Points" contains the voltage, current impedance, admittance, and power in each
--- nec-2.orig/doc/NECdoc/examples/examp7.html
+++ nec-2/doc/NECdoc/examples/examp7.html
@@ -3,10 +3,10 @@
Examples 7 and 8
-Examples 7 and 8 demonstrate the use of NEC for scattering.
+
Examples 7 and 8 demonstrate the use of NEC for scattering.
The columns labled "gain" are, inthis case, scattering cross section in square
wave-lengths (sigma/lamda2). Example 8 is a stick model of an
-aircraft as shown in figure 19.
+aircraft as shown in figure 19.
--- nec-2.orig/Makefile
+++ nec-2/Makefile
@@ -7,11 +7,13 @@
RM= rm -f
# Things to pass to all makes
MAKEDEFS =
-INSTALL = /usr/bin/install -o root -g root -c
-INSTALL_PROGRAM = $(INSTALL)
+#INSTALL = /usr/bin/install -o root -g root -c
+INSTALL = /usr/bin/install -o root -g root
+INSTALL_PROGRAM = $(INSTALL) -m 0755 -s
+INSTALL_MAN = $(INSTALL) -m 0644
DESTDIR =
-BINDIR = $(DESTDIR)/usr/local/bin
-
+BINDIR = $(DESTDIR)/usr/bin
+MANDIR = $(DESTDIR)/usr/man/man1
SUBDIRS= somnec nec
#default target
@@ -24,8 +26,15 @@
install:
$(INSTALL_PROGRAM) nec/nec2 $(BINDIR)
+ $(INSTALL_PROGRAM) nec/nec2small $(BINDIR)
+
$(INSTALL_PROGRAM) somnec/somnec $(BINDIR)
+installman:
+ $(INSTALL_MAN) nec/nec2.1 $(MANDIR)/nec2.1
+ $(INSTALL_MAN) somnec/somnec.1 $(MANDIR)/somnec.1
+
+
clean: clean-recursive clean-local
clean-local:
--- nec-2.orig/debian/README.debian
+++ nec-2/debian/README.debian
@@ -0,0 +1,21 @@
+nec for Debian
+----------------------
+
+Comments regarding the Package
+
+Note that g77 in its libraries provides an extra intrinsic called SECNDS
+with some care it should be possible to get this to produce proper
+timing information; although this is less important than it used to be
+since modern systems are so fast that such computations are almost
+instantaneous. For the moment this means that g77 won't compile the
+code as is; since it complains about the name conflict.
+
+ , Thur, 10 Jun 1999 00:34:49 +0100
+
+I have in response to bug reports and private comments increased the size of
+system which nec2 can handle as to do this requires a fiddly recompilation.
+This increases the bss to about 10Mb from 1Mb, but nec runs are likely to
+be done on more powerful equipment. I have left a small version nec2small
+which may prove useful for educational use etc.
+
+ , Tue, 2 Oct 2002 12:34:49 +0100
--- nec-2.orig/debian/changelog
+++ nec-2/debian/changelog
@@ -0,0 +1,137 @@
+nec (2-16) unstable; urgency=low
+ * fix spelling error in nec2small binary
+ * remove duplicate priority field in control file
+
+ -- Alan Bain Thu, 6 Aug 2009 20:43:23 +0100
+
+
+nec (2-15) unstable; urgency=low
+ * change the way max number of patches + segments is handled
+ to avoid buys of the type reported in #511907
+ * fix lintian reports (spelling: choosen)
+ * update documentation to describe free format input (closes: bug#231038)
+ * remove .comment and .note sections from binaries
+ -- Alan Bain Thu, 30 Jul 2009 23:10:01 +0100
+
+nec (2-14.1) unstable; urgency=high
+
+ * Non-maintainer upload.
+ * Fix segfault due to an out of bound loop.
+ Patch by Samuel Thibault , thanks!
+ Closes: #511907
+ * Clean nec/nec2.{c,o}, as the patch won't help otherwise.
+ * Urgency set to high due to RC bugfix.
+
+ -- Evgeni Golov Sun, 01 Feb 2009 18:31:12 +0100
+
+nec (2-14) unstable; urgency=low
+ * Generate md5sums file
+ * Add watch file indicating no upstream source
+ -- Alan Bain Tue, 8 Jul 2008 23:02:00 +0100
+
+nec (2-13) unstable; urgency=low
+ * Correct erroneous datestamp on previous changelog
+
+ -- Alan Bain Thu, 24 Apr 2008 23:20:00 +0100
+
+nec (2-12) unstable; urgency=low
+ * standards version updated
+ * don't strip when nostrip build option set (closes: bug#437607)
+ * check for errors in make clean target
+ * package is not orphaned (closes: bug#465910)
+
+ -- Alan Bain Fri, 26 Aug 2005 23:14:21 +0100
+
+nec (2-11) unstable; urgency=low
+ * standards version updated
+
+ -- Alan Bain Fri, 26 Aug 2005 23:14:21 +0100
+
+nec (2-10) unstable; urgency=low
+ * Terminal input bug fixed (closes: bug #184190)
+ Input and output filenames are taken correctly from command
+ line.
+ * Broken links in manual corrected and checked (closes: bug #293674)
+ * Manual correction to RP card description.
+ * Free format input mentioned in manual index.html (closes: bug #231038)
+ * Workaround for console io not required any longer (closes: bug #231035)
+ * nec2small now has a manpage (closes: bug #230712)
+ * nec2 manpage now references somnec in `see also' section
+ * rhombic example file corrected so keep phi within 360 degree range
+ enabling xnecview to work correctly with it as an example input.
+
+ -- Alan Bain Thu, 18 Aug 2005 19:07:52 +0100
+
+nec (2-9) unstable; urgency=low
+
+ * Fixed broken links in documentation (closes: bug#230296)
+
+ -- Alan Bain Sun, 1 Feb 2004 11:00:00 +0000
+
+nec (2-8) unstable; urgency=low
+
+ * Corrected package description (closes: bug#198510, closes: bug#181469)
+
+ -- Alan Bain Mon, 5 Jan 2004 17:17:00 +0000
+
+nec (2-7) unstable; urgency=low
+
+ * Increased max number of patches and segments to 5000 closing
+ bug #151377, since this only increased the bss from 1Mb to 10Mb
+ so should no longer unduly restrict the use of this program; a
+ small binary nec2small is provided for small problem sets suitable
+ for educational use etc. as part of the same package.
+
+ -- Tue, 2 Oct 2002 12:00:00 +0100
+
+nec (2-6) unstable; urgency=low
+
+ * Added build depends on fort77, closing bug #103319
+
+ -- Tue, 3 Jul 2001 16:00:00 +0100
+
+nec (2-5) unstable; urgency=low
+
+ * New standards version
+ * Removed incorrect dependancy on f2c closing bug #40731
+ * Added build-dependencies
+
+ -- Thu, 5 Apr 2001 16:00:00 +0100
+
+nec (2-4) unstable; urgency=low
+
+ * Changed /usr/doc to /usr/share/doc and /usr/man to /usr/share/man
+
+ -- Fri, 5 Nov 1999 12:00:00 +0000
+
+nec (2-3) unstable; urgency=low
+
+ * made small changes to ZINT routine to bring into line with the
+ official report.
+ * added some more explanation to the copyright file.
+
+ -- Fri, 11 Jun 1999 12:00:00 +0100
+
+nec (2-2) unstable; urgency=low
+
+ * Fixed a bug in input reading routine (READGM and READMN) so handles
+ 22E3 correctly.
+ i.e. scientific notation without a decimal point for a real valued
+ read in quantity.
+
+ * Fixed examples to remove erroneous line breaks which have been
+ introduced at some point in the past.
+ * Fixed some typographical errors in the online version of the manual.
+
+ -- Wed, 2 Jun 1999 20:00:00 +0100
+
+nec (2-1) unstable; urgency=low
+
+ * Initial release.
+ * Single Precision Code.
+
+ -- Mon, 24 May 1999 00:34:49 +0100
+
+Local variables:
+mode: debian-changelog
+End:
--- nec-2.orig/debian/compat
+++ nec-2/debian/compat
@@ -0,0 +1 @@
+5
--- nec-2.orig/debian/control
+++ nec-2/debian/control
@@ -0,0 +1,23 @@
+Source: nec
+Section: hamradio
+Priority: optional
+Maintainer: Alan Bain
+Standards-Version: 3.8.2
+Build-Depends: f2c,fort77,debhelper(>=5.0)
+
+Package: nec
+Architecture: any
+Depends: ${shlibs:Depends}
+Description: NEC2 Antenna Modelling System
+ The NEC2 (Numerical Electromagnetics Code) is software for modelling
+ antennas using the Method of Moments. It was developed at Lawrence
+ Livermore Laboratories, and remains widely used, despite the old
+ fashioned punched card style input required.
+ .
+ This version contains code which hasn't been extensively tested
+ for errors, which was input by hand from a report -- use with care.
+ The numerics are currently only SINGLE PRECISION.
+ .
+ User's documentation is provided in HTML format (based on OCR text
+ so beware of potential errors).
+
--- nec-2.orig/debian/copyright
+++ nec-2/debian/copyright
@@ -0,0 +1,40 @@
+This package was debianized by afrb2@debian.org on
+Mon, 24 May 1999 00:34:49 +0100.
+
+It was downloaded from: my own personal archive of NEC material.
+
+Copyright:
+
+The following statement is contained at the start of the code.
+
+C NUMERICAL ELECTROMAGNETICS CODE (NEC2) DEVELOPED AT LAWRENCE
+C LIVERMORE LAB., LIVERMORE, CA. (CONTACT G. BURKE AT 415-422-8414
+C FOR PROBLEMS WITH THE NEC CODE. FOR PROBLEMS WITH THE VAX IMPLEM-
+C ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415
+C 422-5936)
+C FILE CREATED 4/11/80.
+C
+C ***********NOTICE**********
+C THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK
+C SPONSORED BY THE UNITED STATES GOVERNMENT. NEITHER THE UNITED
+C STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF
+C THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR
+C THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
+C ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
+C COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT
+C OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
+C INFRINGE PRIVATELY-OWNED RIGHTS.
+
+
+As it is indicated it was prepared as work sponsored by the US goverment.
+It now has an unclassified status (unlike the later development NEC4).
+
+As a result the works seems to have a public domain status (see 17 USC105);
+despite it not explicitly being stated in the code or indeed any of the
+associated reports.
+
+There exits several other commercial products which are widely used
+which include support for either NEC2 or NEC4; in the former case
+no additional licence is necessary, in the second a licence must
+be obtained in return for a fee payed.
+
--- nec-2.orig/debian/dirs
+++ nec-2/debian/dirs
@@ -0,0 +1,2 @@
+usr/bin
+usr/share/man/man1
--- nec-2.orig/debian/rules
+++ nec-2/debian/rules
@@ -0,0 +1,114 @@
+#!/usr/bin/make -f
+# Made with the aid of debmake, by Christoph Lameter,
+# based on the sample debian/rules file for GNU hello by Ian Jackson.
+
+package=nec
+
+INSTALL = /usr/bin/install
+INSTALL_PROGRAM = $(INSTALL) -o root -g root -m 0755
+
+FFLAGS = -g
+ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS)))
+FFLAGS += -O0
+else
+FFLAGS += -O2
+endif
+
+ifeq (,$(findstring nostrip,$(DEB_BUILD_OPTIONS)))
+INSTALL_PROGRAM += -s
+endif
+
+build:
+ $(checkdir)
+
+ $(MAKE) FC=fort77 F77=fort77 FFLAGS="$(FFLAGS)"
+ touch build
+
+clean:
+ $(checkdir)
+ -rm -f build
+ $(MAKE) clean
+ -rm -f `find . -name "*~"`
+ -rm -rf debian/tmp `find debian/* -type d ! -name CVS ` debian/files* core
+ -rm -f debian/*substvars
+ dh_clean nec/nec2.o nec/nec2.c nec/secnds.c
+
+binary-indep: checkroot build
+ $(checkdir)
+# There are no architecture-independent files to be uploaded
+# generated by this package. If there were any they would be
+# made here.
+
+binary-arch: checkroot build
+ $(checkdir)
+ -rm -rf debian/tmp `find debian/* -type d`
+ install -d debian/tmp
+ install -d debian/tmp/DEBIAN
+ cd debian/tmp && install -d `cat ../dirs`
+ $(MAKE) install DESTDIR=`pwd`/debian/tmp INSTALL_PROGRAM="$(INSTALL_PROGRAM)"
+ifeq (,$(findstring nostrip,$(DEB_BUILD_OPTIONS)))
+ strip --remove-section=.comment --remove-section=.note debian/tmp/usr/bin/nec2
+ strip --remove-section=.comment --remove-section=.note debian/tmp/usr/bin/nec2small
+ strip --remove-section=.comment --remove-section=.note debian/tmp/usr/bin/somnec
+endif
+
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/cards
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/examples
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/gifs
+
+
+ install -d `pwd`/debian/tmp/usr/share/doc/$(package)/examples
+ install -o root -g root -m 0644 \
+ doc/Input-Specification \
+ `pwd`/debian/tmp/usr/share/doc/$(package)
+ gzip -9v `pwd`/debian/tmp/usr/share/doc/$(package)/Input-Specification
+ install -o root -g root -m 0644 \
+ doc/NECdoc/*.html `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc
+ install -o root -g root -m 0644 \
+ doc/NECdoc/gifs/*.gif \
+ `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/gifs
+ install -o root -g root -m 0644 \
+ doc/NECdoc/cards/*.html \
+ `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/cards
+ install -o root -g root -m 0644 \
+ examples/* `pwd`/debian/tmp/usr/share/doc/$(package)/examples
+ install -o root -g root -m 0644 \
+ doc/NECdoc/examples/* \
+ `pwd`/debian/tmp/usr/share/doc/$(package)/NECdoc/examples
+ install -o root -g root -m 0644 \
+ nec/nec2.1 \
+ `pwd`/debian/tmp/usr/share/man/man1/nec2.1
+ install -o root -g root -m 0644 \
+ nec/nec2small.1 \
+ `pwd`/debian/tmp/usr/share/man/man1/nec2small.1
+ install -o root -g root -m 0644 \
+ somnec/somnec.1 \
+ `pwd`/debian/tmp/usr/share/man/man1/somnec.1
+ gzip -9v `pwd`/debian/tmp/usr/share/man/man1/*.1
+ cp debian/copyright `pwd`/debian/tmp/usr/share/doc/$(package)/.
+ cp README `pwd`/debian/tmp/usr/share/doc/$(package)/changelog
+ cp debian/changelog \
+ debian/tmp/usr/share/doc/$(package)/changelog.Debian
+ cd debian/tmp/usr/share/doc/$(package) && \
+ gzip -9v changelog changelog.Debian
+
+ dpkg-shlibdeps nec/nec2 somnec/somnec
+ dpkg-gencontrol -isp -pnec
+ dh_md5sums --tmpdir=debian/tmp
+ chown -R root.root debian/tmp
+ chmod -R go=rX debian/tmp
+ dpkg --build debian/tmp ..
+
+define checkdir
+ test -f debian/rules
+endef
+
+binary: binary-indep binary-arch
+
+checkroot:
+ $(checkdir)
+ test root = "`whoami`"
+
+.PHONY: binary binary-arch binary-indep clean checkroot
--- nec-2.orig/debian/watch
+++ nec-2/debian/watch
@@ -0,0 +1 @@
+# NEC Version 2.0 is no longer being maintained upstream
--- nec-2.orig/examples/16ele-yagi.nec
+++ nec-2/examples/16ele-yagi.nec
@@ -1,40 +1,22 @@
CM NEC Input File of a 16 element Yagi
CE
-GW 15 7 0.00000 -0.34000 0.00000 0.00000 0.34000 0.00000
- 0.00250
-GW 16 7 0.27300 -0.31750 0.00000 0.27300 0.31750 0.00000
- 0.00250
-GW 1 7 0.69300 -0.30500 0.00000 0.69300 0.30500 0.00000
- 0.00250
-GW 2 7 1.11300 -0.30500 0.00000 1.11300 0.30500 0.00000
- 0.00250
-GW 3 7 1.53300 -0.30500 0.00000 1.53300 0.30500 0.00000
- 0.00250
-GW 4 7 1.95300 -0.30500 0.00000 1.95300 0.30500 0.00000
- 0.00250
-GW 5 7 2.37300 -0.30500 0.00000 2.37300 0.30500 0.00000
- 0.00250
-GW 6 7 2.79300 -0.30500 0.00000 2.79300 0.30500 0.00000
- 0.00250
-GW 7 7 3.21300 -0.30500 0.00000 3.21300 0.30500 0.00000
- 0.00250
-GW 8 7 3.63300 -0.30500 0.00000 3.63300 0.30500 0.00000
- 0.00250
-GW 9 7 4.05300 -0.30500 0.00000 4.05300 0.30500 0.00000
- 0.00250
-GW 10 7 4.47300 -0.30500 0.00000 4.47300 0.30500 0.00000
- 0.00250
-GW 11 7 4.89300 -0.30500 0.00000 4.89300 0.30500 0.00000
- 0.00250
-GW 12 7 5.31300 -0.30500 0.00000 5.31300 0.30500 0.00000
- 0.00250
-GW 13 7 5.73300 -0.30500 0.00000 5.73300 0.30500 0.00000
- 0.00250
+GW 15 7 0.00000 -0.34000 0.00000 0.00000 0.34000 0.00000 0.00250
+GW 16 7 0.27300 -0.31750 0.00000 0.27300 0.31750 0.00000 0.00250
+GW 1 7 0.69300 -0.30500 0.00000 0.69300 0.30500 0.00000 0.00250
+GW 2 7 1.11300 -0.30500 0.00000 1.11300 0.30500 0.00000 0.00250
+GW 3 7 1.53300 -0.30500 0.00000 1.53300 0.30500 0.00000 0.00250
+GW 4 7 1.95300 -0.30500 0.00000 1.95300 0.30500 0.00000 0.00250
+GW 5 7 2.37300 -0.30500 0.00000 2.37300 0.30500 0.00000 0.00250
+GW 6 7 2.79300 -0.30500 0.00000 2.79300 0.30500 0.00000 0.00250
+GW 7 7 3.21300 -0.30500 0.00000 3.21300 0.30500 0.00000 0.00250
+GW 8 7 3.63300 -0.30500 0.00000 3.63300 0.30500 0.00000 0.00250
+GW 9 7 4.05300 -0.30500 0.00000 4.05300 0.30500 0.00000 0.00250
+GW 10 7 4.47300 -0.30500 0.00000 4.47300 0.30500 0.00000 0.00250
+GW 11 7 4.89300 -0.30500 0.00000 4.89300 0.30500 0.00000 0.00250
+GW 12 7 5.31300 -0.30500 0.00000 5.31300 0.30500 0.00000 0.00250
+GW 13 7 5.73300 -0.30500 0.00000 5.73300 0.30500 0.00000 0.00250
GE 0
-FR 0 1 0 0 2.20E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 16 4 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-RP 0 31 73 1001 0.00E+00 0.00E+00 3.00E+00 5.00E+00 1.00E+04
- 0.00E+00
+FR 0 1 0 0 2.20E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 16 4 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 31 73 1001 0.00E+00 0.00E+00 3.00E+00 5.00E+00 1.00E+04 0.00E+00
EN
--- nec-2.orig/examples/kc2mk.nec
+++ nec-2/examples/kc2mk.nec
@@ -2,24 +2,15 @@
CM DE-55.58 ft REF-57.58 ft SPACING-6.54 ft
CM Increase REF loop (GW4,5,6) to raise resonance
CE
-GW 1 20 1.00600 2.81900 10.00000 1.00600 -2.81900 10.00000
- 0.00200
-GW 2 20 1.00600 -2.81900 10.00000 1.00600 0.00000 14.90200
- 0.00200
-GW 3 20 1.00600 0.00000 14.90200 1.00600 2.81900 10.00000
- 0.00200
-GW 4 20 -1.00600 2.81900 10.00000 -1.00600 -2.81900 10.00000
- 0.00200
-GW 5 20 -1.00600 -2.81900 10.00000 -1.00600 0.00000 15.30000
- 0.00200
-GW 6 20 -1.00600 0.00000 15.30000 -1.00600 2.81900 10.00000
- 0.00200
+GW 1 20 1.00600 2.81900 10.00000 1.00600 -2.81900 10.00000 0.00200
+GW 2 20 1.00600 -2.81900 10.00000 1.00600 0.00000 14.90200 0.00200
+GW 3 20 1.00600 0.00000 14.90200 1.00600 2.81900 10.00000 0.00200
+GW 4 20 -1.00600 2.81900 10.00000 -1.00600 -2.81900 10.00000 0.00200
+GW 5 20 -1.00600 -2.81900 10.00000 -1.00600 0.00000 15.30000 0.00200
+GW 6 20 -1.00600 0.00000 15.30000 -1.00600 2.81900 10.00000 0.00200
GE 0
GN 1
-FR 0 3 0 0 18.06800 0.050000 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-RP 0 1 37 1001 6.90E+01 0.00E+00 0.00E+00 5.00E+00 1.00E+04
- 0.00E+00
+FR 0 3 0 0 18.06800 0.050000 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 1 37 1001 6.90E+01 0.00E+00 0.00E+00 5.00E+00 1.00E+04 0.00E+00
EN
--- nec-2.orig/examples/log-periodic.nec
+++ nec-2/examples/log-periodic.nec
@@ -2,46 +2,26 @@
CM PT control card supresses printing of element currents
CM TL control card specs transmission line in terms of Z,length,and shunt Y
CE
-GW 3 7 -9.66700 -2.14200 0.00000 -9.66700 2.14200 0.00000
- 0.00429
-GW 4 7 -11.10700 -2.46300 0.00000 -11.10700 2.46300 0.00000
- 0.00493
-GW 5 7 -12.76800 -2.83200 0.00000 -12.76800 2.83200 0.00000
- 0.00566
-GW 6 9 -14.67500 -3.25500 0.00000 -14.67500 3.25500 0.00000
- 0.00651
-GW 7 9 -16.86500 -3.74100 0.00000 -16.86500 3.74100 0.00000
- 0.00750
-GW 8 9 -19.38300 -4.29900 0.00000 -19.38300 4.29900 0.00000
- 0.00860
-GW 9 11 -22.27700 -4.94400 0.00000 -22.27700 4.94400 0.00000
- 0.00988
-GW 10 11 -25.60300 -5.68200 0.00000 -25.60300 5.68200 0.00000
- 0.01136
-GW 11 11 -29.42500 -6.53100 0.00000 -29.42500 6.53100 0.00000
- 0.01305
+GW 3 7 -9.66700 -2.14200 0.00000 -9.66700 2.14200 0.00000 0.00429
+GW 4 7 -11.10700 -2.46300 0.00000 -11.10700 2.46300 0.00000 0.00493
+GW 5 7 -12.76800 -2.83200 0.00000 -12.76800 2.83200 0.00000 0.00566
+GW 6 9 -14.67500 -3.25500 0.00000 -14.67500 3.25500 0.00000 0.00651
+GW 7 9 -16.86500 -3.74100 0.00000 -16.86500 3.74100 0.00000 0.00750
+GW 8 9 -19.38300 -4.29900 0.00000 -19.38300 4.29900 0.00000 0.00860
+GW 9 11 -22.27700 -4.94400 0.00000 -22.27700 4.94400 0.00000 0.00988
+GW 10 11 -25.60300 -5.68200 0.00000 -25.60300 5.68200 0.00000 0.01136
+GW 11 11 -29.42500 -6.53100 0.00000 -29.42500 6.53100 0.00000 0.01305
GE 0
-FR 0 2 0 0 1.20E+01 4.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 3 4 4 4 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 4 4 5 4 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 5 4 6 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 6 5 7 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 7 5 8 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 8 5 9 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 9 6 10 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-TL 10 6 11 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- -2.20E-03
-EX 0 3 4 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
+FR 0 2 0 0 1.20E+01 4.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 3 4 4 4 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 4 4 5 4 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 5 4 6 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 6 5 7 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 7 5 8 5 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 8 5 9 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 9 6 10 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+TL 10 6 11 6 -4.50E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 -2.20E-03
+EX 0 3 4 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
PT -1
-RP 0 37 37 1001 0.00E+00 0.00E+00 5.00E+00 1.00E+01 0.00E+00
- 0.00E+00
+RP 0 37 37 1001 0.00E+00 0.00E+00 5.00E+00 1.00E+01 0.00E+00 0.00E+00
EN
--- nec-2.orig/examples/monopole.nec
+++ nec-2/examples/monopole.nec
@@ -1,14 +1,12 @@
CM NEC Input File for monopole
+CM 18MHz for 17m monopole (radius 0.001m) above perfect ground
+CM Excited at base by a 1V source.
+CM Normal mode solution at 181 values of THETA, 2 values of PHI (0 and 180).
CE
-GW 1 8 0.00000 0.00000 0.00000 0.00000 0.00000 17.00000
- 0.00100
+GW 1 8 0.00000 0.00000 0.00000 0.00000 0.00000 17.00000 0.00100
GE 1
-GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-FR 0 1 0 0 1.81E+01 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 1 1 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-RP 0 181 2 1001 0.00E+00 0.00E+00 1.00E+00 1.80E+02 0.00E+00
- 0.00E+00
+GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+FR 0 1 0 0 1.81E+01 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 1 1 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 181 2 1001 0.00E+00 0.00E+00 1.00E+00 1.80E+02 0.00E+00 0.00E+00
EN
--- nec-2.orig/examples/rhombic.nec
+++ nec-2/examples/rhombic.nec
@@ -1,26 +1,15 @@
CM NEC Input File for Rhombic
CE
-GW 1 10 0.00000 0.00000 10.00000 17.30000 10.00000 10.00000
- 0.01000
-GW 2 10 0.00000 0.00000 10.00000 17.30000 -10.00000 10.00000
- 0.01000
-GW 3 10 17.30000 10.00000 10.00000 34.60000 0.00000 10.00000
- 0.01000
-GW 4 10 17.30000 -10.00000 10.00000 34.60000 0.00000 10.00000
- 0.01000
+GW 1 10 0.00000 0.00000 10.00000 17.30000 10.00000 10.00000 0.01000
+GW 2 10 0.00000 0.00000 10.00000 17.30000 -10.00000 10.00000 0.01000
+GW 3 10 17.30000 10.00000 10.00000 34.60000 0.00000 10.00000 0.01000
+GW 4 10 17.30000 -10.00000 10.00000 34.60000 0.00000 10.00000 0.01000
GE 1
-GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-FR 0 1 0 0 3.00E+01 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 1 1 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 2 1 0 -1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-LD 0 3 10 10 2.90E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-LD 0 4 10 10 2.90E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-RP 0 31 73 1001 0.00E+00 0.00E+00 3.00E+00 5.00E+00 0.00E+00
- 0.00E+00
+GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+FR 0 1 0 0 3.00E+01 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 1 1 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 2 1 0 -1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+LD 0 3 10 10 2.90E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+LD 0 4 10 10 2.90E+02 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 31 72 1001 0.00E+00 0.00E+00 3.00E+00 5.00E+00 0.00E+00 0.00E+00
EN
--- nec-2.orig/examples/w7gq-15m.nec
+++ nec-2/examples/w7gq-15m.nec
@@ -3,30 +3,18 @@
CM Scaled to 17 meters by GS=1.176, RP horz pat 0 to 180 deg, 0 is forward
CM vertical pattern fixed at 69 deg from top or 21 up from horizontal
CE
-GW 1 20 1.51400 1.79100 10.00000 1.51400 -1.79100 10.00000
- 0.00200
-GW 2 20 1.51400 -1.79100 10.00000 1.51400 -1.79100 13.58200
- 0.00200
-GW 3 20 1.51400 -1.79100 13.58200 1.51400 1.79100 13.58200
- 0.00200
-GW 4 20 1.51400 1.79100 13.58200 1.51400 1.79100 10.00000
- 0.00200
-GW 5 20 -1.51400 1.86000 10.00000 -1.51400 -1.86000 10.00000
- 0.00200
-GW 6 20 -1.51400 -1.86000 10.00000 -1.51400 -1.86000 13.72000
- 0.00200
-GW 7 20 -1.51400 -1.86000 13.72000 -1.51400 1.86000 13.72000
- 0.00200
-GW 8 20 -1.51400 1.86000 13.72000 -1.51400 1.86000 10.00000
- 0.00200
+GW 1 20 1.51400 1.79100 10.00000 1.51400 -1.79100 10.00000 0.00200
+GW 2 20 1.51400 -1.79100 10.00000 1.51400 -1.79100 13.58200 0.00200
+GW 3 20 1.51400 -1.79100 13.58200 1.51400 1.79100 13.58200 0.00200
+GW 4 20 1.51400 1.79100 13.58200 1.51400 1.79100 10.00000 0.00200
+GW 5 20 -1.51400 1.86000 10.00000 -1.51400 -1.86000 10.00000 0.00200
+GW 6 20 -1.51400 -1.86000 10.00000 -1.51400 -1.86000 13.72000 0.00200
+GW 7 20 -1.51400 -1.86000 13.72000 -1.51400 1.86000 13.72000 0.00200
+GW 8 20 -1.51400 1.86000 13.72000 -1.51400 1.86000 10.00000 0.00200
GS 0 0 1.17600
GE 0
-GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-FR 0 3 0 0 18.0680 0.05000 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
- 0.00E+00
-RP 0 1 37 1001 6.90E+01 0.00E+00 0.00E+00 5.00E+00 1.00E+04
- 0.00E+00
+GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+FR 0 3 0 0 18.0680 0.05000 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 1 37 1001 6.90E+01 0.00E+00 0.00E+00 5.00E+00 1.00E+04 0.00E+00
EN
--- nec-2.orig/examples/w7gq.nec
+++ nec-2/examples/w7gq.nec
@@ -1,35 +1,21 @@
CM NEC Input File 2 element W7GQ 15m QUAD
-CM ARRL Antenna Handbook 12-2,Freq stepped .05, 3 times, starting
-at 18.068
-CM Scaled to 17 meters by GS=1.176, RP vertical pattern 0 to 90
-deg, 0 is up
+CM ARRL Antenna Handbook 12-2,Freq stepped .05, 3 times, starting at 18.068
+CM Scaled to 17 meters by GS=1.176, RP vertical pattern 0 to 90 deg, 0 is up
CM GW is wire spec,tag#,#of segments,x,y,z end 1;x,y,z end 2
CM EX is excitation,0 is voltage source,tag#and source segment
CM CE is end comment card
-GW 1 20 1.51400 1.79100 10.00000 1.51400 -1.79100 10.00000
- 0.00200
-GW 2 20 1.51400 -1.79100 10.00000 1.51400 -1.79100 13.58200
- 0.00200
-GW 3 20 1.51400 -1.79100 13.58200 1.51400 1.79100 13.58200
- 0.00200
-GW 4 20 1.51400 1.79100 13.58200 1.51400 1.79100 10.00000
- 0.00200
-GW 5 20 -1.51400 1.86000 10.00000 -1.51400 -1.86000 10.00000
- 0.00200
-GW 6 20 -1.51400 -1.86000 10.00000 -1.51400 -1.86000 13.72000
- 0.00200
-GW 7 20 -1.51400 -1.86000 13.72000 -1.51400 1.86000 13.72000
- 0.00200
-GW 8 20 -1.51400 1.86000 13.72000 -1.51400 1.86000 10.00000
- 0.00200
+GW 1 20 1.51400 1.79100 10.00000 1.51400 -1.79100 10.00000 0.00200
+GW 2 20 1.51400 -1.79100 10.00000 1.51400 -1.79100 13.58200 0.00200
+GW 3 20 1.51400 -1.79100 13.58200 1.51400 1.79100 13.58200 0.00200
+GW 4 20 1.51400 1.79100 13.58200 1.51400 1.79100 10.00000 0.00200
+GW 5 20 -1.51400 1.86000 10.00000 -1.51400 -1.86000 10.00000 0.00200
+GW 6 20 -1.51400 -1.86000 10.00000 -1.51400 -1.86000 13.72000 0.00200
+GW 7 20 -1.51400 -1.86000 13.72000 -1.51400 1.86000 13.72000 0.00200
+GW 8 20 -1.51400 1.86000 13.72000 -1.51400 1.86000 10.00000 0.00200
GS 0 0 1.17600
GE 0
-GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00
-0.00E+00 0.00E+00
-FR 0 3 0 0 18.0680 0.05000 0.00E+00 0.00E+00
-0.00E+00 0.00E+00
-EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00
-0.00E+00 0.00E+00
-RP 0 31 1 1001 0.00E+00 0.00E+00 3.00E+00 0.00E+00
-1.00E+04 0.00E+00
+GN 1 0 0 0 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+FR 0 3 0 0 18.0680 0.05000 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+EX 0 1 10 0 1.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00
+RP 0 31 1 1001 0.00E+00 0.00E+00 3.00E+00 0.00E+00 1.00E+04 0.00E+00
EN
--- nec-2.orig/nec/Makefile
+++ nec-2/nec/Makefile
@@ -1,13 +1,19 @@
RM= rm -f
F77= f77
-SRCS=nec2.f secnds.f
+SRCS=nec2.f nec2small.f secnds.f
OBJS=nec2.o secnds.o
+OBJSSMALL=nec2small.o secnds.o
FFLAGS= -O2
-all: $(OBJS)
+all: nec2 nec2small
+
+nec2: $(OBJS)
$(F77) -o nec2 $(OBJS)
+nec2small: $(OBJSSMALL)
+ $(F77) -o nec2small $(OBJSSMALL)
+
clean:
$(RM) *.o
- $(RM) nec2linux.c
$(RM) nec2
+ $(RM) nec2small
--- nec-2.orig/nec/nec2.1
+++ nec-2/nec/nec2.1
@@ -2,34 +2,60 @@
.\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection
.\" other parms are allowed: see man(7), man(1)
.SH NAME
-nec2 \- Numerical Electromagnetics Code (Antenna Modelling Program)
+nec2, nec2small \- Numerical Electromagnetics Code (Antenna Modelling Program)
.SH SYNOPSIS
.B nec2
+[\fIINPUT\fR] [\fIOUTPUT\fR]
+.br
+.B nec2small
+[\fIINPUT\fR] [\fIOUTPUT\fR]
.SH "DESCRIPTION"
.B nec2,
-is a versatile numerical Method of Moments antenna modelling code for the
+is a versatile numerical Boundary Element Method (commonly called
+Method of Moments) antenna modelling code for the
analysis of antennas and other metal structures. It solves
the integral equations for the currents induced on the structure
-by the sources or incident fields. The structure may either
+by sources or incident fields. The structure may either
be excited by voltage sources on the structure, or by an incident
plane wave of either elliptic or linear polarisation.
+The structure and excitation are described in the \fIINPUT\fR file
+and the output is written to \fIOUTPUT\fR.
.SH OPTIONS
-Due to the age of the program, it expects its input to be in the form
-of punched cards fed into a hopper. It doesn't currently take any
-options, instead the name of the input and output files must be
-entered once the program has been run.
+Due to the age of the program, it expects input in the form
+of punched cards fed into a hopper. It currently does not
+accept any options.
+
+If \fIOUTPUT\fR is
+omitted, output is written to stdout and if \fIINPUT\fR and
+\fIOUTPUT\fR are omitted then
+the input is taken from stdin and the output written to stdout.
+.PP
+The maximum size of problem which the code can handle must
+be hard coded at compile time and no dynamic memory allocation is
+performed. Two versions are therefore provided suitable for
+different sizes of problem,
+.B nec2
+is compiled for a maximum of 10000 wire segments and 5000
+surface patches, while
+.B nec2small
+is compiled for a maximum of 600 wire segments and 200 surface patches.
.SH "SEE ALSO"
-It is fully documented in the report
+somnec(1)
+.PP
+The NEC-2 code is fully documented in the report
.IR "Numerical Electromagnetics Code (NEC)
--- Method of Moments", available as a printed publication in three
+-- Method of Moments" by Burke and Poggio, which is
+available as a printed publication in three
parts covering the theory of operation, the program code and the
-users' manual.
+users' manual. An updated form of the users' manual part of
+this report can be found in
+/usr/share/doc/nec/NECdoc
.SH BUGS
.B nec2
-has been superseeded by
+has been superseded by
.B nec4,
-but this has not been made publically available, so it is
+but this revised code has not been made available to the public, so it is
possible that some bugs remain in this version.
Also note that many variant source codes exist based on the
--- nec-2.orig/nec/nec2.f
+++ nec-2/nec/nec2.f
@@ -24,13 +24,27 @@
C DOUBLE PRECISION 6/4/85
C
C ***
+C MODIFIED BY ALAN BAIN TO USE COMMAND LINE ARGUMENTS AS NAMES
+C OF INPUT AND OUTPUT FILES IF PROVIDED.
+C
+C ***
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
- CHARACTER AIN*2, ATST*2, INFILE*80, OTFILE*80
+C Change all these params
+C .. N is number segments
+C .. M is number patches
+C .. N2M = N+2*M, N3M = N+3*M
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
+
+ CHARACTER AIN*2, ATST*2, INFILE*256, OTFILE*256
C***
C INTEGER AIN,ATST,PNET
- integer*4 COM
+
+C..Command Line parsing..
+ INTEGER NARGS
+ LOGICAL FISVALID
+
+ INTEGER*4 COM
CHARACTER*6 HPOL,PNET
COMPLEX CM, FJ, VSANT, ETH, EPH, ZRATI, CUR, CURI, ZARRAY,
&ZRATI2
@@ -40,7 +54,7 @@
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
- COMMON /CMB/ CM(90000)
+ COMMON /CMB/ CM(1000000)
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
COMMON /SAVE/ IP( N2M), KCOM, COM(20,5), EPSR, SIG, SCRWLT,
@@ -89,40 +103,58 @@
C***
DATA LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/
706 CONTINUE
- PRINT 700
- 700 FORMAT('$ENTER DATA INPUT FILENAME [HIT RETURN FOR TERMINAL',
- &' INPUT] : ',/,'$ >')
- 701 FORMAT(A)
- READ( *,701,ERR=702) INFILE
- CALL STR0PC( INFILE, INFILE)
-C OPEN (UNIT=5,FILE=INFILE,STATUS='OLD',READONLY,ERR=702)
- IF( INFILE.NE.' ') THEN
- OPEN ( UNIT=1,FILE=INFILE,STATUS='OLD',ERR=702)
+C..Fortran 77 Extension to get number args..
+ NARGS=IARGC()
+C..Defaults for terminal IO
+ INFILE=''
+ OTFILE=''
+
+ IF (NARGS.GT.2) THEN
+ PRINT *,'Error'
+ PRINT *,'nec2 [] []'
+ STOP
+ ENDIF
+
+ IF (NARGS.GE.1) THEN
+ CALL GETARG(1,INFILE)
+ INQUIRE(FILE=INFILE,EXIST=FISVALID)
+ IF (.NOT.FISVALID) GOTO 702
ENDIF
- 707 CONTINUE
- PRINT 703
- 703 FORMAT('$ENTER DATA OUTPUT FILENAME [HIT RETURN FOR TERMINAL',
- &' OUTPUT] : ',/,'$ >')
- READ( *,701,ERR=704) OTFILE
- CALL STR0PC( OTFILE, OTFILE)
- IF( OTFILE.NE.' ') THEN
- OPEN ( UNIT=2,FILE=OTFILE,STATUS='NEW',ERR=704)
+ IF (NARGS.EQ.2) THEN
+ CALL GETARG(2,OTFILE)
+ ENDIF
+
+
+ IF( INFILE.NE.'') THEN
+ OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702)
+ ENDIF
+
+ IF( OTFILE.NE.'') THEN
+ OPEN ( UNIT=6,FILE=OTFILE,STATUS='UNKNOWN',ERR=704)
ENDIF
GOTO 705
- 702 print *, 'error on terminal input'
- CALL ERROR
- GOTO 706
- 704 CALL ERROR
- GOTO 707
-C***
+
+ 702 INLEN=LEN(INFILE)
+ CALL FILEERR('File not found',INFILE)
+ STOP
+
+ 703 CALL FILEERR('Unable to open input file',INFILE)
+ STOP
+
+ 704 CALL FILEERR('Unable to open output file for writing',
+ & OTFILE)
+ STOP
+
705 CONTINUE
CALL SECNDS(EXTIM)
FJ=(0.,1.)
- LD=600
+C** LD is max permissible N+M (see NM param)
+C** param from original NEC code
+ LD=NM
NXA(1)=0
- IRESRV=90000
+ IRESRV=1000000
C***
1 KCOM=0
IFRTMW=0
@@ -132,22 +164,22 @@
IF( KCOM.GT.5) KCOM=5
C***
- READ( 1,125) AIN,( COM( I, KCOM), I=1,19)
+ READ( 5,125) AIN,( COM( I, KCOM), I=1,19)
C***
CALL STR0PC( AIN, AIN)
if (KCOM .le. 0) then
- WRITE (2,126)
- WRITE (2,127)
- WRITE (2,128)
+ WRITE (6,126)
+ WRITE (6,127)
+ WRITE (6,128)
endif
- WRITE (2,129) ( COM( I, KCOM), I=1,19)
+ WRITE (6,129) ( COM( I, KCOM), I=1,19)
IF( AIN.EQ. ATST(11)) GOTO 2
if (AIN .ne. ATST(1)) then
- WRITE (2,130)
+ WRITE (6,130)
STOP
endif
@@ -182,7 +214,7 @@
C DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
C
C***
- WRITE (2,135)
+ WRITE (6,135)
IPLP1=0
IPLP2=0
IPLP3=0
@@ -214,15 +246,16 @@
C MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
C PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
C
-C14 READ(1,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
+C14 READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
C 1TMP6
C***
IPERF=0
C***
14 CALL READMN( AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2, TMP3,
&TMP4, TMP5, TMP6)
+ PRINT *,'Done READMN'
MPCNT= MPCNT+1
- WRITE (2,137) MPCNT, AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2
+ WRITE (6,137) MPCNT, AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2
&, TMP3, TMP4, TMP5, TMP6
IF( AIN.EQ. ATST(2)) GOTO 16
IF( AIN.EQ. ATST(3)) GOTO 17
@@ -248,16 +281,16 @@
IF( AIN.NE. ATST(13)) GOTO 15
CALL SECNDS( TMP1)
TMP1= TMP1- EXTIM
- WRITE (2,201) TMP1
+ WRITE (6,201) TMP1
STOP
- 15 WRITE (2,138)
+ 15 WRITE (6,138)
C
C FREQUENCY PARAMETERS
C
STOP
16 IFRQ= ITMP1
IF( ICASX.EQ.0) GOTO 8
- WRITE (2,303) AIN
+ WRITE (6,303) AIN
STOP
8 NFRQ= ITMP2
IF( NFRQ.EQ.0) NFRQ=1
@@ -299,7 +332,7 @@
NCTAG( NCOUP)= ITMP3
NCSEG( NCOUP)= ITMP4
GOTO 14
- 312 WRITE (2,313)
+ 312 WRITE (6,313)
C
C LOADING PARAMETERS
C
@@ -311,7 +344,7 @@
IF( ITMP1.EQ.(-1)) GOTO 14
18 NLOAD= NLOAD+1
IF( NLOAD.LE. LOADMX) GOTO 19
- WRITE (2,139)
+ WRITE (6,139)
STOP
19 LDTYP( NLOAD)= ITMP1
LDTAG( NLOAD)= ITMP2
@@ -319,7 +352,7 @@
LDTAGF( NLOAD)= ITMP3
LDTAGT( NLOAD)= ITMP4
IF( ITMP4.GE. ITMP3) GOTO 20
- WRITE (2,140) NLOAD, ITMP3, ITMP4
+ WRITE (6,140) NLOAD, ITMP3, ITMP4
STOP
20 ZLR( NLOAD)= TMP1
ZLI( NLOAD)= TMP2
@@ -330,7 +363,7 @@
GOTO 14
21 IFLOW=4
IF( ICASX.EQ.0) GOTO 10
- WRITE (2,303) AIN
+ WRITE (6,303) AIN
STOP
10 IF( IGO.GT.2) IGO=2
IF( ITMP1.NE.(-1)) GOTO 22
@@ -345,7 +378,7 @@
SIG= TMP2
IF( NRADL.EQ.0) GOTO 23
IF( IPERF.NE.2) GOTO 314
- WRITE (2,390)
+ WRITE (6,390)
STOP
314 SCRWLT= TMP3
SCRWRT= TMP4
@@ -377,7 +410,7 @@
GOTO 207
205 NSANT= NSANT+1
IF( NSANT.LE. NSMAX) GOTO 26
- 206 WRITE (2,141)
+ 206 WRITE (6,141)
STOP
26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3)
VSANT( NSANT)= CMPLX( TMP1, TMP2)
@@ -412,7 +445,7 @@
IF( ITMP2.EQ.(-1)) GOTO 14
29 NONET= NONET+1
IF( NONET.LE. NETMX) GOTO 30
- WRITE (2,142)
+ WRITE (6,142)
STOP
30 NTYP( NONET)=2
IF( AIN.EQ. ATST(6)) NTYP( NONET)=1
@@ -464,7 +497,7 @@
GOTO 209
32 NFEH=0
209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33
- WRITE (2,143)
+ WRITE (6,143)
33 NEAR= ITMP1
NRX= ITMP2
NRY= ITMP3
@@ -518,7 +551,7 @@
GOTO (41,46,53,71,78), IGO
322 IFLOW=12
IF( ICASX.EQ.0) GOTO 301
- WRITE (2,302)
+ WRITE (6,302)
STOP
301 IRNGF= IRESRV/2
C
@@ -591,11 +624,11 @@
C***
44 FR= FMHZ/ CVEL
WLAM= CVEL/ FMHZ
- WRITE (2,145) FMHZ, WLAM
- WRITE (2,196) RKH
+ WRITE (6,145) FMHZ, WLAM
+ WRITE (6,196) RKH
C FREQUENCY SCALING OF GEOMETRIC PARAMETERS
C*** FMHZS=FMHZ
- IF( IEXK.EQ.1) WRITE (2,321)
+ IF( IEXK.EQ.1) WRITE (6,321)
IF( N.EQ.0) GOTO 306
C***
DO 45 I=1, N
@@ -618,13 +651,13 @@
245 BI( J)= BITEMP( J)* FR2
C STRUCTURE SEGMENT LOADING
307 IGO=2
- 46 WRITE (2,146)
+ 46 WRITE (6,146)
IF( NLOAD.NE.0) CALL LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI
&, ZLC)
- IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE (2,147)
+ IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE (6,147)
C GROUND PARAMETER
- IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE (2,327)
- WRITE (2,148)
+ IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE (6,327)
+ WRITE (6,148)
IF( KSYMP.EQ.1) GOTO 49
FRATI=(1.,0.)
IF( IPERF.EQ.1) GOTO 48
@@ -638,23 +671,23 @@
SCRWR= SCRWRT/ WLAM
T1= FJ*2367.067D+0/ DFLOAT( NRADL)
T2= SCRWR* DFLOAT( NRADL)
- WRITE (2,170) NRADL, SCRWLT, SCRWRT
- WRITE (2,149)
+ WRITE (6,170) NRADL, SCRWLT, SCRWRT
+ WRITE (6,149)
47 IF( IPERF.EQ.2) GOTO 328
- WRITE (2,391)
+ WRITE (6,391)
GOTO 329
328 IF( NXA(1).EQ.0) READ( 21) AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
&YSA, NXA, NYA
FRATI=( EPSC-1.)/( EPSC+1.)
IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400
- WRITE (2,393) EPSCF, EPSC
+ WRITE (6,393) EPSCF, EPSC
STOP
- 400 WRITE (2,392)
- 329 WRITE (2,150) EPSR, SIG, EPSC
+ 400 WRITE (6,392)
+ 329 WRITE (6,150) EPSR, SIG, EPSC
GOTO 50
- 48 WRITE (2,151)
+ 48 WRITE (6,151)
GOTO 50
- 49 WRITE (2,152)
+ 49 WRITE (6,152)
C * * *
C FILL AND FACTOR PRIMARY INTERACTION MATRIX
C
@@ -680,7 +713,7 @@
&IX, NP, N1, MP, M1, NEQ, NEQ2)
323 CALL SECNDS( TIM1)
TIM2= TIM1- TIM2
- WRITE (2,153) TIM, TIM2
+ WRITE (6,153) TIM, TIM2
333 IGO=3
NTSOL=0
C WRITE N.G.F. FILE
@@ -695,7 +728,7 @@
INC=1
NPRINT=0
54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56
- IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE (2,154)
+ IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE (6,154)
TMP5= TA* XPR5
TMP4= TA* XPR4
IF( IXTYP.NE.4) GOTO 55
@@ -703,26 +736,26 @@
TMP2= XPR2/ WLAM
TMP3= XPR3/ WLAM
TMP6= XPR6/( WLAM* WLAM)
- WRITE (2,156) XPR1, XPR2, XPR3, XPR4, XPR5, XPR6
+ WRITE (6,156) XPR1, XPR2, XPR3, XPR4, XPR5, XPR6
GOTO 56
55 TMP1= TA* XPR1
TMP2= TA* XPR2
TMP3= TA* XPR3
TMP6= XPR6
- IF( IPTFLG.LE.0) WRITE (2,155) XPR1, XPR2, XPR3, HPOL( IXTYP),
+ IF( IPTFLG.LE.0) WRITE (6,155) XPR1, XPR2, XPR3, HPOL( IXTYP),
&XPR6
C
C MATRIX SOLVING (NETWK CALLS SOLVES)
C
56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR)
IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60
- WRITE (2,158)
+ WRITE (6,158)
ITMP3=0
ITMP1= NTYP(1)
DO 59 I=1,2
IF( ITMP1.EQ.3) ITMP1=2
- IF( ITMP1.EQ.2) WRITE (2,159)
- IF( ITMP1.EQ.1) WRITE (2,160)
+ IF( ITMP1.EQ.2) WRITE (6,159)
+ IF( ITMP1.EQ.1) WRITE (6,160)
DO 58 J=1, NONET
ITMP2= NTYP( J)
IF(( ITMP2/ ITMP1).EQ.1) GOTO 57
@@ -733,7 +766,7 @@
IF( ITMP2.GE.2.AND. X11I( J).LE.0.) X11I( J)= WLAM* SQRT(( X(
&ITMP5)- X( ITMP4))**2+( Y( ITMP5)- Y( ITMP4))**2+( Z( ITMP5)- Z(
&ITMP4))**2)
- WRITE (2,157) ITAG( ITMP4), ITMP4, ITAG( ITMP5), ITMP5, X11R( J)
+ WRITE (6,157) ITAG( ITMP4), ITMP4, ITAG( ITMP5), ITMP5, X11R( J)
&, X11I( J), X12R( J), X12I( J), X22R( J), X22I( J), PNET(2* ITMP2
&-1), PNET(2* ITMP2)
58 CONTINUE
@@ -760,11 +793,11 @@
IF( N.EQ.0) GOTO 308
IF( IPTFLG.EQ.(-1)) GOTO 63
IF( IPTFLG.GT.0) GOTO 62
- WRITE (2,161)
- WRITE (2,162)
+ WRITE (6,161)
+ WRITE (6,162)
GOTO 63
62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63
- WRITE (2,163) XPR3, HPOL( IXTYP), XPR6
+ WRITE (6,163) XPR3, HPOL( IXTYP), XPR6
63 PLOSS=0.
ITMP1=0
JUMP= IPTFLG+1
@@ -784,10 +817,10 @@
IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67
FNORM( INC)= CMAG
ISAVE= I
- 67 IF( IPTFLG.NE.3) WRITE (2,164) XPR1, XPR2, CMAG, PH, I
+ 67 IF( IPTFLG.NE.3) WRITE (6,164) XPR1, XPR2, CMAG, PH, I
GOTO 69
C***
- 68 WRITE (2,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
+ 68 WRITE (6,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
&CMAG, PH
IF( IPLP1.NE.1) GOTO 69
IF( IPLP2.EQ.1) WRITE( 8,*) CURI
@@ -795,7 +828,7 @@
IF( IPLP2.EQ.2) WRITE( 8,*) CMAG, PH
69 CONTINUE
IF( IPTFLQ.EQ.(-1)) GOTO 308
- WRITE (2,315)
+ WRITE (6,315)
ITMP1=0
FR=1.D-6/ FMHZ
DO 316 I=1, N
@@ -807,11 +840,11 @@
318 CURI= FR* CMPLX(- BII( I), BIR( I))
CMAG= ABS( CURI)
PH= CANG( CURI)
- WRITE (2,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
+ WRITE (6,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
&CMAG, PH
316 CONTINUE
308 IF( M.EQ.0) GOTO 310
- WRITE (2,197)
+ WRITE (6,197)
J= N-2
ITMP1= LD+1
DO 309 I=1, M
@@ -829,7 +862,7 @@
C 1X,EY, EZ
C***
EPHA= CANG( EPH)
- WRITE (2,198) I, X( ITMP1), Y( ITMP1), Z( ITMP1), ETHM, ETHA,
+ WRITE (6,198) I, X( ITMP1), Y( ITMP1), Z( ITMP1), ETHM, ETHA,
&EPHM, EPHA, EX, EY, EZ
IF( IPLP1.NE.1) GOTO 309
IF( IPLP3.EQ.1) WRITE( 8,*) EX
@@ -841,14 +874,14 @@
310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70
TMP1= PIN- PNLS- PLOSS
TMP2=100.* TMP1/ PIN
- WRITE (2,166) PIN, TMP1, PLOSS, PNLS, TMP2
+ WRITE (6,166) PIN, TMP1, PLOSS, PNLS, TMP2
70 CONTINUE
IGO=4
IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM)
IF( IFLOW.NE.7) GOTO 71
IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113
IF( NFRQ.NE.1) GOTO 120
- WRITE (2,135)
+ WRITE (6,135)
GOTO 14
C
C NEAR FIELD CALCULATION
@@ -858,7 +891,7 @@
CALL NFPAT
IF( MHZ.EQ. NFRQ) NEAR=-1
IF( NFRQ.NE.1) GOTO 78
- WRITE (2,135)
+ WRITE (6,135)
C
C STANDARD FAR FIELD CALCULATION
C
@@ -884,12 +917,12 @@
ITMP1= NTHI* NPHI
IF( ITMP1.LE. NORMF) GOTO 114
ITMP1= NORMF
- WRITE (2,181)
+ WRITE (6,181)
114 TMP1= FNORM(1)
DO 115 J=2, ITMP1
IF( FNORM( J).GT. TMP1) TMP1= FNORM( J)
115 CONTINUE
- WRITE (2,182) TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE
+ WRITE (6,182) TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE
DO 118 J=1, NPHI
ITMP2= NTHI*( J-1)
DO 116 I=1, NTHI
@@ -897,7 +930,7 @@
IF( ITMP3.GT. ITMP1) GOTO 117
TMP2= FNORM( ITMP3)/ TMP1
TMP3= DB20( TMP2)
- WRITE (2,183) XPR1, XPR2, TMP3, TMP2
+ WRITE (6,183) XPR1, XPR2, TMP3, TMP2
XPR1= XPR1+ XPR4
116 CONTINUE
117 XPR1= THETIS
@@ -906,19 +939,19 @@
XPR2= PHISS
119 IF( MHZ.EQ. NFRQ) IFAR=-1
IF( NFRQ.NE.1) GOTO 120
- WRITE (2,135)
+ WRITE (6,135)
GOTO 14
120 MHZ= MHZ+1
IF( MHZ.LE. NFRQ) GOTO 42
IF( IPED.EQ.0) GOTO 123
IF( NVQD.LT.1) GOTO 199
- WRITE (2,184) IVQD( NVQD), ZPNORM
+ WRITE (6,184) IVQD( NVQD), ZPNORM
GOTO 204
- 199 WRITE (2,184) ISANT( NSANT), ZPNORM
+ 199 WRITE (6,184) ISANT( NSANT), ZPNORM
204 ITMP1= NFRQ
IF( ITMP1.LE.( NORMF/4)) GOTO 121
ITMP1= NORMF/4
- WRITE (2,185)
+ WRITE (6,185)
121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ
IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1))
DO 122 I=1, ITMP1
@@ -927,12 +960,12 @@
TMP3= FNORM( ITMP2+1)/ ZPNORM
TMP4= FNORM( ITMP2+2)/ ZPNORM
TMP5= FNORM( ITMP2+3)
- WRITE (2,186) TMP1, FNORM( ITMP2), FNORM( ITMP2+1), FNORM( ITMP2
+ WRITE (6,186) TMP1, FNORM( ITMP2), FNORM( ITMP2+1), FNORM( ITMP2
&+2), FNORM( ITMP2+3), TMP2, TMP3, TMP4, TMP5
IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ
IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ
122 CONTINUE
- WRITE (2,135)
+ WRITE (6,135)
123 CONTINUE
NFRQ=1
MHZ=1
@@ -1071,7 +1104,7 @@
C ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -1085,7 +1118,7 @@
IPSYM=0
IF( NS.LT.1) RETURN
IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1
- WRITE (2,3)
+ WRITE (6,3)
STOP
1 ANG= ANG1* TA
DANG=( ANG2- ANG1)* TA/ NS
@@ -1150,7 +1183,7 @@
READ( NUNIT,END=3) ( AR( J), J= I1, I2)
2 CONTINUE
RETURN
- 3 WRITE (2,4) NUNIT, NBLKS, NEOF
+ 3 WRITE (6,4) NUNIT, NBLKS, NEOF
IF( NEOF.NE.777) STOP
NEOF=0
C
@@ -1168,7 +1201,7 @@
C CURRENT VECTOR CUR.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
@@ -1264,7 +1297,7 @@
C ***
IMPLICIT REAL (A-H,O-Z)
C CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CB, CC, CD, ZARRAY, EXK, EYK, EZK, EXS, EYS, EZS, EXC
&, EYC, EZC
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -1546,7 +1579,7 @@
C
C CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM
C
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CM, ZARRAY, ZAJ, EXK, EYK, EZK, EXS,
&EYS, EZS, EXC, EYC, EZC, SSX, D, DETER
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -1661,7 +1694,7 @@
C ***
IMPLICIT REAL (A-H,O-Z)
C CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX G11, G12, G21, G22, CM, EXK, EYK, EZK, EXS, EYS, EZS,
& EXC, EYC, EZC
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -1748,7 +1781,7 @@
C ***
IMPLICIT REAL (A-H,O-Z)
C COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CM, ZRATI, ZRATI2, T1, EXK, EYK, EZK, EXS, EYS, EZS,
&EXC, EYC, EZC, EMEL, CW, FRATI
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -1901,7 +1934,7 @@
C CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
&EXC, EYC, EZC
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -1992,7 +2025,7 @@
C
C CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS
C
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
&EXC, EYC, EZC
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -2112,7 +2145,7 @@
C CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
C BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.
C
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -2124,8 +2157,8 @@
NSCON=0
NPCON=0
IF( IGND.EQ.0) GOTO 3
- WRITE (2,54)
- IF( IGND.GT.0) WRITE (2,55)
+ WRITE (6,54)
+ IF( IGND.GT.0) WRITE (6,55)
IF( IPSYM.NE.2) GOTO 1
NP=2* NP
MP=2* MP
@@ -2149,7 +2182,7 @@
SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN
IF( IGND.LT.1) GOTO 5
IF( ZI1.GT.- SLEN) GOTO 4
- WRITE (2,56) I
+ WRITE (6,56) I
STOP
4 IF( ZI1.GT. SLEN) GOTO 5
ICON1( I)= I
@@ -2175,11 +2208,11 @@
ICON1( I)=0
8 IF( IGND.LT.1) GOTO 12
9 IF( ZI2.GT.- SLEN) GOTO 10
- WRITE (2,56) I
+ WRITE (6,56) I
STOP
10 IF( ZI2.GT. SLEN) GOTO 12
IF( ICON1( I).NE. I) GOTO 11
- WRITE (2,57) I
+ WRITE (6,57) I
STOP
11 ICON2( I)= I
Z2( I)=0.
@@ -2275,21 +2308,21 @@
24 I= I+1
GOTO 21
25 IF( NPCON.LE. NPMAX) GOTO 26
- WRITE (2,62) NPMAX
+ WRITE (6,62) NPMAX
STOP
- 26 WRITE (2,58) N, NP, IPSYM
- IF( M.GT.0) WRITE (2,61) M, MP
+ 26 WRITE (6,58) N, NP, IPSYM
+ IF( M.GT.0) WRITE (6,61) M, MP
ISEG=( N+ M)/( NP+ MP)
IF( ISEG.EQ.1) GOTO 30
IF( IPSYM) 28,27,29
27 STOP
- 28 WRITE (2,59) ISEG
+ 28 WRITE (6,59) ISEG
GOTO 30
29 IC= ISEG/2
IF( ISEG.EQ.8) IC=3
- WRITE (2,60) IC
+ WRITE (6,60) IC
30 IF( N.EQ.0) GOTO 48
- WRITE (2,50)
+ WRITE (6,50)
C ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE. PRINT JUNCTIONS
C OF 3 OR MORE SEG. ALSO FIND OLD SEG. CONNECTING TO NEW SEG.
ISEG=0
@@ -2351,14 +2384,14 @@
IF( ICONX( IX).NE.0) GOTO 41
NSCON= NSCON+1
IF( NSCON.LE. NSMAX) GOTO 40
- WRITE (2,62) NSMAX
+ WRITE (6,62) NSMAX
STOP
40 ISCON( NSCON)= IX
ICONX( IX)= NSCON
41 CONTINUE
42 IF( IC.LT.3) GOTO 43
ISEG= ISEG+1
- WRITE (2,51) ISEG,( JCO( I), I=1, IC)
+ WRITE (6,51) ISEG,( JCO( I), I=1, IC)
43 IF( IEND.EQ.1) GOTO 44
IEND=1
JEND=1
@@ -2370,7 +2403,7 @@
ZA= Z2( J)
GOTO 31
44 CONTINUE
- IF( ISEG.EQ.0) WRITE (2,52)
+ IF( ISEG.EQ.0) WRITE (6,52)
C FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES
IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48
DO 47 J=1, N1
@@ -2389,7 +2422,7 @@
47 CONTINUE
48 CONTINUE
RETURN
- 49 WRITE (2,53) IX
+ 49 WRITE (6,53) IX
C
STOP
50 FORMAT(//,9X,'- MULTIPLE WIRE JUNCTIONS -',/,1X,'JUNCTION',4X,
@@ -2422,7 +2455,7 @@
C
C COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.
C
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX Y11A, Y12A, CUR, Y11, Y12, Y22, YL, YIN, ZL, ZIN, RHO
&, VQD, VSANT, VQDS
COMMON /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
@@ -2444,7 +2477,7 @@
Y12A( L1)= CUR( K)* WLAM/ ZIN
1 CONTINUE
IF( ICOUP.LT. NCOUP) RETURN
- WRITE (2,6)
+ WRITE (6,6)
NPM1= NCOUP-1
DO 5 I=1, NPM1
ITT1= NCTAG( I)
@@ -2474,9 +2507,9 @@
YIN= Y11- YIN/( Y22+ YL)
ZIN=1./ YIN
DBC= DB10( GMAX)
- WRITE (2,7) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN
+ WRITE (6,7) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN
GOTO 5
- 4 WRITE (2,8) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C
+ 4 WRITE (6,8) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C
5 CONTINUE
C
RETURN
@@ -2500,7 +2533,7 @@
C DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.
C
C***
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
C***
CHARACTER *2 GM, ATST
CHARACTER *1 IFX,IFY,IFZ,IPT
@@ -2547,11 +2580,12 @@
IPHD=0
C***
1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD)
+ PRINT *, 'READ CARD ',GM
IF( N+ M.GT. LD) GOTO 37
IF( GM.EQ. ATST(9)) GOTO 27
IF( IPHD.EQ.1) GOTO 2
- WRITE (2,40)
- WRITE (2,41)
+ WRITE (6,40)
+ WRITE (6,41)
IPHD=1
2 IF( GM.EQ. ATST(11)) GOTO 10
ISCT=0
@@ -2575,7 +2609,7 @@
3 NWIRE= NWIRE+1
I1= N+1
I2= N+ NS
- WRITE (2,43) NWIRE, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
+ WRITE (6,43) NWIRE, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
&I2, ITG
IF( RAD.EQ.0) GOTO 4
XS1=1.
@@ -2587,9 +2621,9 @@
4 CALL READGM( GM, IX, IY, XS1, YS1, ZS1, DUMMY, DUMMY, DUMMY,
&DUMMY)
IF( GM.EQ. ATST(12)) GOTO 6
- 5 WRITE (2,48)
+ 5 WRITE (6,48)
STOP
- 6 WRITE (2,61) XS1, YS1, ZS1
+ 6 WRITE (6,61) XS1, YS1, ZS1
IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5
RAD= YS1
YS1=( ZS1/ YS1)**(1./( NS-1.))
@@ -2601,7 +2635,7 @@
8 NWIRE= NWIRE+1
I1= N+1
I2= N+ NS
- WRITE (2,38) NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG
+ WRITE (6,38) NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG
CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2)
C***
C
@@ -2611,7 +2645,7 @@
123 NWIRE= NWIRE+1
I1= N+1
I2= N+ NS
- WRITE (2,124) XW1, YW1, NWIRE, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
+ WRITE (6,124) XW1, YW1, NWIRE, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
&I2, ITG
CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG)
C
@@ -2626,7 +2660,7 @@
9 I1= M+1
NS= NS+1
IF( ITG.NE.0) GOTO 17
- WRITE (2,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
+ WRITE (6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1
IF( NS.GT.1) GOTO 14
XW2= XW2* TA
@@ -2660,14 +2694,14 @@
X4= XW1+ X3- XW2
Y4= YW1+ Y3- YW2
Z4= ZW1+ Z3- ZW2
- 12 WRITE (2,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
- WRITE (2,39) X3, Y3, Z3, X4, Y4, Z4
+ 12 WRITE (6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
+ WRITE (6,39) X3, Y3, Z3, X4, Y4, Z4
C
C GENERATE MULTIPLE-PATCH SURFACE
C
GOTO 16
13 I1= M+1
- WRITE (2,59) I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS
+ WRITE (6,59) I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS
C***
IF( ITG.LT.1.OR. NS.LT.1) GOTO 17
C 14 READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4
@@ -2677,12 +2711,12 @@
X4= XW1+ X3- XW2
Y4= YW1+ Y3- YW2
Z4= ZW1+ Z3- ZW2
- 15 WRITE (2,39) X3, Y3, Z3, X4, Y4, Z4
+ 15 WRITE (6,39) X3, Y3, Z3, X4, Y4, Z4
IF( GM.NE. ATST(11)) GOTO 17
16 CALL PATCH( ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, X3, Y3, Z3, X4
&, Y4, Z4)
GOTO 1
- 17 WRITE (2,60)
+ 17 WRITE (6,60)
C
C REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
C
@@ -2694,9 +2728,9 @@
IF( IX.NE.0) IX=1
IF( IY.NE.0) IY=1
IF( IZ.NE.0) IZ=1
- WRITE (2,44) IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG
+ WRITE (6,44) IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG
GOTO 20
- 19 WRITE (2,45) NS, ITG
+ 19 WRITE (6,45) NS, ITG
IX=-1
20 CALL REFLC( IX, IY, IZ, ITG, NS)
C
@@ -2721,12 +2755,12 @@
Y( I)= Y( I)* XW1
Z( I)= Z( I)* XW1
24 BI( I)= BI( I)* YW1
- 25 WRITE (2,46) XW1
+ 25 WRITE (6,46) XW1
C
C MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.
C
GOTO 1
- 26 WRITE (2,47) ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
+ 26 WRITE (6,47) ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
XW1= XW1* TA
YW1= YW1* TA
ZW1= ZW1* TA
@@ -2736,7 +2770,7 @@
C
GOTO 1
27 IF( N+ M.EQ.0) GOTO 28
- WRITE (2,52)
+ WRITE (6,52)
STOP
28 CALL GFIL( ITG)
NPSAV= NP
@@ -2763,8 +2797,8 @@
IPSYM= IPSAV
31 IF( N+ M.GT. LD) GOTO 37
IF( N.EQ.0) GOTO 33
- WRITE (2,53)
- WRITE (2,54)
+ WRITE (6,53)
+ WRITE (6,54)
DO 32 I=1, N
XW1= X2( I)- X( I)
YW1= Y2( I)- Y( I)
@@ -2785,7 +2819,7 @@
XW2= ASIN( XW2)* TD
YW2= ATGN2( YW1, XW1)* TD
C***
- WRITE (2,55) I, X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I),
+ WRITE (6,55) I, X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I),
&ICON1( I), I, ICON2( I), ITAG( I)
IF( IPLP1.NE.1) GOTO 320
WRITE( 8,*) X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I), ICON1
@@ -2793,25 +2827,25 @@
C***
320 CONTINUE
IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32
- WRITE (2,56)
+ WRITE (6,56)
STOP
32 CONTINUE
33 IF( M.EQ.0) GOTO 35
- WRITE (2,57)
+ WRITE (6,57)
J= LD+1
DO 34 I=1, M
J= J-1
XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J)
YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J)
ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J)
- WRITE (2,58) I, X( J), Y( J), Z( J), XW1, YW1, ZW1, BI( J), T1X(
+ WRITE (6,58) I, X( J), Y( J), Z( J), XW1, YW1, ZW1, BI( J), T1X(
& J), T1Y( J), T1Z( J), T2X( J), T2Y( J), T2Z( J)
34 CONTINUE
35 RETURN
- 36 WRITE (2,48)
- WRITE (2,49) GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
+ 36 WRITE (6,48)
+ WRITE (6,49) GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
STOP
- 37 WRITE (2,50)
+ 37 WRITE (6,50)
C
STOP
38 FORMAT(1X,I5,2X,'ARC RADIUS =',F9.5,2X,'FROM',F8.3,' TO',F8.3,
@@ -2890,7 +2924,7 @@
C COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
C CONSTANT CURRENTS. GROUND EFFECT INCLUDED.
C
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX TXK, TYK, TZK, TXS, TYS, TZS, TXC, TYC, TZC, EXK, EYK
&, EZK, EXS, EYS, EZS, EXC, EYC, EZC, EPX, EPY, ZRATI, REFS, REFPS
&, ZRSIN, ZRATX, T1, ZSCRN, ZRATI2, TEZS, TERS, TEZC, TERC, TEZK,
@@ -3126,7 +3160,7 @@
IMPLICIT REAL (A-H,O-Z)
C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C THIN WIRE APPROXIMATION.
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CON, GZ1, GZ2, GP1, GP2, GZP1, GZP2, EZS, ERS, EZC,
&ERC, EZK, ERK
COMMON /TMI/ ZPK, RKB2, IJX
@@ -3173,7 +3207,7 @@
C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C EXTENDED THIN WIRE APPROXIMATION.
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CON, GZ1, GZ2, GZP1, GZP2, GR1, GR2, GRP1, GRP2, EZS,
& EZC, ERS, ERC, GRK1, GRK2, EZK, ERK, GZZ1, GZZ2
COMMON /TMI/ ZPK, RKB2, IJX
@@ -3249,24 +3283,8 @@
C ***
C DOUBLE PRECISION 6/4/85
C
-C IMPLICIT REAL(A-H,O-Z)
-C ***
- SUBROUTINE ERROR
- IMPLICIT INTEGER (A-Z)
- CHARACTER MSG*80
-C CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,)
-C CALL ERRSNS( FNUM, RMSSTS, RMSSTV, IUNIT, CNDVAL)
- CALL STR0PC( MSG, MSG)
- IND= INDEX( MSG,',')
- PRINT1 , MSG( IND+2: MSGLEN)
- 1 FORMAT(//,' **** ERROR **** ',//,5X,A,//)
- RETURN
- END
-C ***
-C DOUBLE PRECISION 6/4/85
-C
SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
C ***
C
C ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD
@@ -3646,7 +3664,7 @@
REWIND IU2
REWIND IU3
REWIND IU4
- WRITE (2,4) TIME
+ WRITE (6,4) TIME
C
RETURN
4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5)
@@ -3664,7 +3682,7 @@
C TEXT. (MATRIX TRANSPOSED.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, D, ARJ
DIMENSION A( NDIM, NDIM), IP( NDIM)
COMMON /SCRATM/ D( N2M)
@@ -3721,7 +3739,7 @@
7 CONTINUE
8 CONTINUE
IF( IFLG.EQ.0) GOTO 9
- WRITE (2,10) R, DMAX
+ WRITE (6,10) R, DMAX
IFLG=0
9 CONTINUE
C
@@ -3874,7 +3892,7 @@
C FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY
C MATRIX (A)
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX SSX, DETER
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
@@ -3903,7 +3921,7 @@
NPSYM= NPBLK
NLSYM= NLAST
IMAT= NPBLK* NCOL
- WRITE (2,14) NBLOKS, NPBLK, NLAST
+ WRITE (6,14) NBLOKS, NPBLK, NLAST
GOTO 11
3 NPBLK= IMAX/ NCOL
IF( NPBLK.LT.1) GOTO 12
@@ -3911,14 +3929,14 @@
NBLOKS=( NROW-1)/ NPBLK
NLAST= NROW- NBLOKS* NPBLK
NBLOKS= NBLOKS+1
- WRITE (2,14) NBLOKS, NPBLK, NLAST
+ WRITE (6,14) NBLOKS, NPBLK, NLAST
IF( NROW* NROW.GT. IMX1) GOTO 4
ICASE=4
NBLSYM=1
NPSYM= NROW
NLSYM= NROW
IMAT= NROW* NROW
- WRITE (2,15)
+ WRITE (6,15)
GOTO 5
4 ICASE=5
NPSYM= IMAX/(2* NROW)
@@ -3928,7 +3946,7 @@
NBLSYM=( NROW-1)/ NPSYM
NLSYM= NROW- NBLSYM* NPSYM
NBLSYM= NBLSYM+1
- WRITE (2,16) NBLSYM, NPSYM, NLSYM
+ WRITE (6,16) NBLSYM, NPSYM, NLSYM
IMAT= NPSYM* NROW
5 NOP= NCOL/ NROW
IF( NOP* NROW.NE. NCOL) GOTO 13
@@ -3961,9 +3979,9 @@
9 SSX( I+ KK, J)= DETER
10 KK= KK*2
11 RETURN
- 12 WRITE (2,17) NROW, NCOL
+ 12 WRITE (6,17) NROW, NCOL
STOP
- 13 WRITE (2,18) NROW, NCOL
+ 13 WRITE (6,18) NROW, NCOL
C
STOP
14 FORMAT(//' MATRIX FILE STORAGE - NO. BLOCKS=',I5,' COLUMNS PE',
@@ -3982,7 +4000,7 @@
C FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
C OUT-OF-CORE STORAGE.
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
IRESX= IRESRV- IMAT
@@ -4031,13 +4049,13 @@
5 IC11= IB11+ NBLN
ID11= IC11+ NBLN
IX11= IMAT+1
- WRITE (2,11) NEQ2
+ WRITE (6,11) NEQ2
IF( ICASX.EQ.1) RETURN
- WRITE (2,8) ICASX
- WRITE (2,9) NBBX, NPBX, NLBX
- WRITE (2,10) NBBL, NPBL, NLBL
+ WRITE (6,8) ICASX
+ WRITE (6,9) NBBX, NPBX, NLBX
+ WRITE (6,10) NBBL, NPBL, NLBL
RETURN
- 6 WRITE (2,7) IRESRV, IMAT, NEQ, NEQ2
+ 6 WRITE (6,7) IRESRV, IMAT, NEQ, NEQ2
C
STOP
7 FORMAT(55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
@@ -4059,7 +4077,7 @@
C THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CIX, CIY, CIZ, EXA, ETH, EPH, CONST, CCX, CCY, CCZ,
&CDP, CUR
COMPLEX ZRATI, ZRSIN, RRV, RRH, RRV1, RRH1, RRV2, RRH2,
@@ -4274,7 +4292,7 @@
C CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
C SURFACE CURRENTS
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CT, CONS, SCUR, EX, EY, EZ
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
@@ -4310,7 +4328,7 @@
C GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /TMI/ ZPK, RKB2, IJ
ZDK= ZK- ZPK
RK= SQRT( RKB2+ ZDK* ZDK)
@@ -4334,14 +4352,14 @@
C GFIL READS THE N.G.F. FILE
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
integer*4 COM
COMPLEX CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
&EPSCF, FRATI
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
- COMMON /CMB/ CM(90000)
+ COMMON /CMB/ CM(1000000)
COMMON /ANGL/ SALP( NM)
COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
&KSYMP, IFAR, IPERF, T1, T2
@@ -4430,32 +4448,32 @@
9 REWIND 13
C WRITE(6,N) G.F. HEADING
10 REWIND IGFL
- WRITE (2,16)
- WRITE (2,14)
- WRITE (2,14)
- WRITE (2,17)
- WRITE (2,18) N1, M1
- IF( NOP.GT.1) WRITE (2,19) NOP
- WRITE (2,20) IMAT, ICASE
+ WRITE (6,16)
+ WRITE (6,14)
+ WRITE (6,14)
+ WRITE (6,17)
+ WRITE (6,18) N1, M1
+ IF( NOP.GT.1) WRITE (6,19) NOP
+ WRITE (6,20) IMAT, ICASE
IF( ICASE.LT.3) GOTO 11
NBL2= NEQ* NPEQ
- WRITE (2,21) NBL2
- 11 WRITE (2,22) FMHZ
- IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE (2,23)
- IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE (2,27)
- IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE (2,28)
- IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE (2,24) EPSR, SIG
- WRITE (2,17)
+ WRITE (6,21) NBL2
+ 11 WRITE (6,22) FMHZ
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE (6,23)
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE (6,27)
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE (6,28)
+ IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE (6,24) EPSR, SIG
+ WRITE (6,17)
DO 12 J=1, KCOM
- 12 WRITE (2,15) ( COM( I, J), I=1,19)
- WRITE (2,17)
- WRITE (2,14)
- WRITE (2,14)
- WRITE (2,16)
+ 12 WRITE (6,15) ( COM( I, J), I=1,19)
+ WRITE (6,17)
+ WRITE (6,14)
+ WRITE (6,14)
+ WRITE (6,16)
IF( IPRT.EQ.0) RETURN
- WRITE (2,25)
+ WRITE (6,25)
DO 13 I=1, N1
- 13 WRITE (2,26) I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I)
+ 13 WRITE (6,26) I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I)
C
RETURN
14 FORMAT(5X,'**************************************************',
@@ -4491,7 +4509,7 @@
C GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CUR, EPI, CIX, CIY, CIZ, EXA, XX1, XX2, U, U2, ERV,
&EZV, ERH, EPH
COMPLEX EZH, EX, EY, ETH, UX, ERD
@@ -4645,14 +4663,14 @@
C WRITE N.G.F. FILE
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
integer*4 COM
COMPLEX CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
&EPSCF, FRATI
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
- COMMON /CMB/ CM(90000)
+ COMMON /CMB/ CM(1000000)
COMMON /ANGL/ SALP( NM)
COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
&KSYMP, IFAR, IPERF, T1, T2
@@ -4728,7 +4746,7 @@
REWIND 13
REWIND 14
12 REWIND IGFL
- WRITE (2,13) IGFL, IMAT
+ WRITE (6,13) IGFL, IMAT
C
RETURN
13 FORMAT(///,' ****NUMERICAL GREEN S FUNCTION FILE ON TAPE',I3,
@@ -4741,7 +4759,7 @@
C ***
C INTEGRAND FOR H FIELD OF A WIRE
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /TMH/ ZPK, RHKS
RS= ZK- ZPK
RS= RHKS+ RS* RS
@@ -4765,14 +4783,14 @@
C (PROC. IRE, SEPT., 1937, PP.1203,1236.)
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX FJ, TPJ, U2, U, RK1, RK2, T1, T2, T3, T4, P1, RV, OMR
&, W, F, Q1, RH, V, G, XR1, XR2, X1, X2, X3, X4, X5, X6, X7, EZV,
&ERV, EZH, ERH, EPH, XX1, XX2, ECON, FBAR
COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
DIMENSION FJX(2), TPJX(2), ECONX(2)
EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX)
- DATA PI/3.141592654D+0/, FJX/0.,1./, TPJX/0.,6.283185308D+0/
+ DATA FJX/0.,1./, TPJX/0.,6.283185308D+0/
DATA ECONX/0.,-188.367/
SPPP= ZMH/ R1
SPPP2= SPPP* SPPP
@@ -4842,7 +4860,7 @@
SUBROUTINE GX( ZZ, RH, XK, GZ, GZP)
C ***
C SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX GZ, GZP
R2= ZZ* ZZ+ RH* RH
R= SQRT( R2)
@@ -4858,7 +4876,7 @@
&)
C ***
C SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP
R2= ZZ* ZZ+ RH* RH
R= SQRT( R2)
@@ -4905,7 +4923,7 @@
C SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
C SEGMENTS
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -4948,7 +4966,7 @@
25 CONTINUE
IF( A2.EQ. A1) GOTO 21
SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1)))
- WRITE (2,104) SANGLE
+ WRITE (6,104) SANGLE
104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
RETURN
21 IF( A1.NE. B1) GOTO 30
@@ -4967,7 +4985,7 @@
35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ)
TURN=2.* PI* HDIA
PITCH=(180./ PI)* ATAN( S/( PI* HDIA))
- 40 WRITE (2,105) PITCH, TURN
+ 40 WRITE (6,105) PITCH, TURN
105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,
&'THE LENGTH OF WIRE/TURN ''IS',F10.4)
RETURN
@@ -5044,7 +5062,7 @@
GOTO 1
14 NT=0
IF( NS- NM) 16,15,15
- 15 WRITE (2,18) Z
+ 15 WRITE (6,18) Z
GOTO 9
16 NS= NS*2
DZ= S/ NS
@@ -5068,7 +5086,7 @@
C ***
C HINTG COMPUTES THE H FIELD OF A PATCH CURRENT
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
&ZRATI2, GAM, F1X, F1Y, F1Z, F2X, F2Y, F2Z, RRV, RRH, T1, FRATI
COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
@@ -5158,7 +5176,7 @@
C HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT
C ON A SEGMENT INCLUDING GROUND EFFECTS.
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
&ZRATI2, T1, HPK, HPS, HPC, QX, QY, QZ, RRV, RRH, ZRATX, FRATI
COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
@@ -5272,7 +5290,7 @@
C ***
C CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK
DIMENSION FJX(2), FJKX(2)
EQUIVALENCE(FJ,FJX),(FJK,FJKX)
@@ -5333,7 +5351,7 @@
C 4 FUNCTIONS AT THE POINT (X,Y).
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX F1, F2, F3, F4, A, B, C, D, FX1, FX2, FX3, FX4, P1,
&P2, P3, P4, A11, A12, A13, A14, A21, A22, A23, A24, A31, A32, A33
&, A34, A41, A42, A43, A44, B11, B12, B13, B14, B21, B22, B23, B24
@@ -5566,7 +5584,7 @@
GOTO 1
14 NT=0
IF( NS- NM) 16,15,15
- 15 WRITE (2,20) Z
+ 15 WRITE (6,20) Z
C
C HALVE STEP SIZE
C
@@ -5602,12 +5620,12 @@
C TAG NUMBER ITAGI. IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
IF( MX.GT.0) GOTO 1
- WRITE (2,6)
+ WRITE (6,6)
STOP
1 ICNT=0
IF( ITAGI.NE.0) GOTO 2
@@ -5619,7 +5637,7 @@
ICNT= ICNT+1
IF( ICNT.EQ. MX) GOTO 5
3 CONTINUE
- 4 WRITE (2,7) ITAGI
+ 4 WRITE (6,7) ITAGI
STOP
5 ISEGNO= I
C
@@ -5641,7 +5659,7 @@
C RALSTONS TEXT.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, D, AJR
INTEGER R, R1, R2, PJ, PR
LOGICAL L1, L2, L3
@@ -5732,7 +5750,7 @@
14 CONTINUE
15 CONTINUE
IF( IFLG.EQ.0) GOTO 16
- WRITE (2,17) J2, DMAX
+ WRITE (6,17) J2, DMAX
IFLG=0
16 CONTINUE
C
@@ -5749,7 +5767,7 @@
C TYPES OF LOADING
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX ZARRAY, ZT, TPCJ, ZINT
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
@@ -5766,7 +5784,7 @@
C INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING
C INFORMATION.
C
- WRITE (2,25)
+ WRITE (6,25)
DO 1 I= N2, N
1 ZARRAY( I)=(0.,0.)
C
@@ -5776,7 +5794,7 @@
ISTEP=0
2 ISTEP= ISTEP+1
IF( ISTEP.LE. NLOAD) GOTO 5
- IF( IWARN.EQ.1) WRITE (2,26)
+ IF( IWARN.EQ.1) WRITE (6,26)
IF( N1+2* M1.GT.0) GOTO 4
NOP= N/ NP
IF( NOP.EQ.1) GOTO 4
@@ -5788,7 +5806,7 @@
3 ZARRAY( L1)= ZT
4 RETURN
5 IF( LDTYP( ISTEP).LE.5) GOTO 6
- WRITE (2,27) LDTYP( ISTEP)
+ WRITE (6,27) LDTYP( ISTEP)
STOP
6 LDTAGS= LDTAG( ISTEP)
JUMP= LDTYP( ISTEP)+1
@@ -5803,7 +5821,7 @@
L1= LDTAGF( ISTEP)
L2= LDTAGT( ISTEP)
IF( L1.GT. N1) GOTO 7
- WRITE (2,29)
+ WRITE (6,29)
STOP
7 DO 17 I= L1, L2
IF( LDTAGS.EQ.0) GOTO 8
@@ -5845,7 +5863,7 @@
ZARRAY( I)= ZARRAY( I)+ ZT
17 CONTINUE
IF( ICHK.NE.0) GOTO 18
- WRITE (2,28) LDTAGS
+ WRITE (6,28) LDTAGS
C
C PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT
C
@@ -5876,7 +5894,7 @@
&'REAL',6X,'IMAGINARY',4X,'MHOS/METER')
26 FORMAT(/,10X,'NOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED',
&' TWICE - IMPEDANCES ADDED')
- 27 FORMAT(/,10X,'IMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ',I3)
+ 27 FORMAT(/,10X,'IMPROPER LOAD TYPE CHOSEN, REQUESTED TYPE IS ',I3)
&
28 FORMAT(/,10X,'LOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =',
&I5)
@@ -5896,7 +5914,7 @@
C BLOCKS OF DESCENDING ORDER.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, B, Y, SUM
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
@@ -5966,7 +5984,7 @@
C S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, TEMP
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
@@ -6035,7 +6053,7 @@
C RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -6140,7 +6158,7 @@
C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EX, EY, EZ, CUR, ACX, BCX, CCX, EXK, EYK, EZK, EXS,
&EYS, EZS, EXC, EYC, EZC, ZRATI, ZRATI2, T1, FRATI
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -6267,7 +6285,7 @@
C PRESENT.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX CMN, RHNT, YMIT, RHS, ZPED, EINC, VSANT, VLT, CUR,
&VSRC, RHNX, VQD, VQDS, CUX, CM, CMB, CMC, CMD
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -6319,7 +6337,7 @@
IPNT( IROW1)= NSEG1
8 CONTINUE
9 IF( IROW1.LT. NDIMNP) GOTO 10
- WRITE (2,59)
+ WRITE (6,59)
STOP
10 IF( IROW1.LT.2) GOTO 14
DO 12 I=1, IROW1
@@ -6348,7 +6366,7 @@
NTSC= IPNT( J)
13 CONTINUE
ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1)))
- WRITE (2,58) ASM, NTEQ, NTSC, ASA
+ WRITE (6,58) ASM, NTEQ, NTSC, ASA
C
C SOLUTION OF NETWORK EQUATIONS
C
@@ -6440,7 +6458,7 @@
NTSCA( NTSC)= NSEG2
VSRC( NTSC)= VSANT( ISC2)
33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34
- WRITE (2,59)
+ WRITE (6,59)
C
C FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
C NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
@@ -6514,8 +6532,8 @@
CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M,
&NEQ, NEQ2, NEQZ2)
CALL CABC( EINC)
- IF( NPRINT.EQ.0) WRITE (2,61)
- IF( NPRINT.EQ.0) WRITE (2,60)
+ IF( NPRINT.EQ.0) WRITE (6,61)
+ IF( NPRINT.EQ.0) WRITE (6,60)
DO 46 I=1, NTEQ
IROW1= NTEQA( I)
VLT= RHNT( I)* SI( IROW1)* WLAM
@@ -6525,7 +6543,7 @@
IROW2= ITAG( IROW1)
PWR=.5* REAL( VLT* CONJG( CUX))
PNLS= PNLS- PWR
- 46 IF( NPRINT.EQ.0) WRITE (2,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
+ 46 IF( NPRINT.EQ.0) WRITE (6,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
&, PWR
IF( NTSC.EQ.0) GOTO 49
DO 47 I=1, NTSC
@@ -6537,7 +6555,7 @@
IROW2= ITAG( IROW1)
PWR=.5* REAL( VLT* CONJG( CUX))
PNLS= PNLS- PWR
- 47 IF( NPRINT.EQ.0) WRITE (2,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
+ 47 IF( NPRINT.EQ.0) WRITE (6,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
&, PWR
C
C SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
@@ -6548,8 +6566,8 @@
CALL CABC( EINC)
NTSC=0
49 IF( NSANT+ NVQD.EQ.0) RETURN
- WRITE (2,63)
- WRITE (2,60)
+ WRITE (6,63)
+ WRITE (6,60)
IF( NSANT.EQ.0) GOTO 56
DO 55 I=1, NSANT
ISC1= ISANT( I)
@@ -6572,7 +6590,7 @@
PIN= PIN+ PWR
IF( IROW1.NE.0) PNLS= PNLS+ PWR
IROW2= ITAG( ISC1)
- 55 WRITE (2,62) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
+ 55 WRITE (6,62) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
56 IF( NVQD.EQ.0) RETURN
DO 57 I=1, NVQD
ISC1= IVQD( I)
@@ -6587,7 +6605,7 @@
PWR=.5* REAL( VLT* CONJG( CUX))
PIN= PIN+ PWR
IROW2= ITAG( ISC1)
- 57 WRITE (2,64) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
+ 57 WRITE (6,64) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
C
RETURN
58 FORMAT(///,3X,'MAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT',
@@ -6611,7 +6629,7 @@
C ***
C COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EX, EY, EZ
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
@@ -6625,9 +6643,9 @@
COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
DATA TA/1.745329252D-02/
IF( NFEH.EQ.1) GOTO 1
- WRITE (2,10)
+ WRITE (6,10)
GOTO 2
- 1 WRITE (2,12)
+ 1 WRITE (6,12)
2 ZNRT= ZNR- DZNR
DO 9 I=1, NRZ
ZNRT= ZNRT+ DZNR
@@ -6665,7 +6683,7 @@
TMP5= ABS( EZ)
TMP6= CANG( EZ)
C***
- WRITE (2,11) XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6
+ WRITE (6,11) XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6
IF( IPLP1.NE.2) GOTO 9
GOTO (14,15,16), IPLP4
14 XXX= XOB
@@ -6714,7 +6732,7 @@
C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEXHX,HY,HZ,CUR,ACX, BCX, CCX, EXK, EYK, EZK, EXS, EYS,
&EZS, EXC, EYC, EZC
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -6799,7 +6817,7 @@
C ***
C PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -6887,7 +6905,7 @@
BI( MI)=.5*( XA+ XST)
S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST
IF( S1X.GT.0.9998) GOTO 6
- WRITE (2,14)
+ WRITE (6,14)
STOP
6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI)
T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI)
@@ -7000,7 +7018,7 @@
C ***
C INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, E, E1,
&E2, E3, E4, E5, E6, E7, E8, E9
COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
@@ -7093,12 +7111,12 @@
C PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
CHARACTER*6 IFORM, IVAR
CHARACTER *(*) IA
DIMENSION IVAR(13), IA(1), IFORM(8), IN(3), INT(3), FL(6), FLT(6
&)
- INTEGER HALL
+ INTEGER HALL
C
C NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW
C
@@ -7155,7 +7173,7 @@
IVAR( K)= IFORM(7)
K= K+1
IVAR( K)= IFORM(8)
- WRITE (2,IVAR) ( INT( I), I=1, NINT),( FLT( J), J=1, NFLT),
+ WRITE (6,IVAR) ( INT( I), I=1, NINT),( FLT( J), J=1, NFLT),
* ( IA( L), L=1, ICHAR)
RETURN
END
@@ -7166,7 +7184,7 @@
C ***
C FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX VQDS, CURD, CCJ, V, EXK, EYK, EZK, EXS, EYS, EZS, EXC
&, EYC, EZC, ETK, ETS, ETC, VSANT, VQD, E, ZARRAY
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
@@ -7296,7 +7314,7 @@
C ***
C COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
C INTEGER HBLK,HCIR,HCLIF
CHARACTER*6 IGNTP, IGAX, IGTP, HPOL, HCIR, HCLIF, HBLK
CHARACTER*6 ISENS
@@ -7326,30 +7344,30 @@
DATA PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/
DATA NORMAX/1200/
IF( IFAR.LT.2) GOTO 2
- WRITE (2,35)
+ WRITE (6,35)
IF( IFAR.LE.3) GOTO 1
- WRITE (2,36) NRADL, SCRWLT, SCRWRT
+ WRITE (6,36) NRADL, SCRWLT, SCRWRT
IF( IFAR.EQ.4) GOTO 2
1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1)
IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR
CL= CLT/ WLAM
CH= CHT/ WLAM
ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96))
- WRITE (2,37) HCLIF, CLT, CHT, EPSR2, SIG2
+ WRITE (6,37) HCLIF, CLT, CHT, EPSR2, SIG2
2 IF( IFAR.NE.1) GOTO 3
- WRITE (2,41)
+ WRITE (6,41)
GOTO 5
3 I=2* IPD+1
J= I+1
ITMP1=2* IAX+1
ITMP2= ITMP1+1
- WRITE (2,38)
+ WRITE (6,38)
IF( RFLD.LT.1.D-20) GOTO 4
EXRM=1./ RFLD
EXRA= RFLD/ WLAM
EXRA=-360.*( EXRA- AINT( EXRA))
- WRITE (2,39) RFLD, EXRM, EXRA
- 4 WRITE (2,40) IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2)
+ WRITE (6,39) RFLD, EXRM, EXRA
+ 4 WRITE (6,40) IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2)
5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7
IF( IXTYP.EQ.4) GOTO 6
PRAD=0.
@@ -7468,7 +7486,7 @@
C GO TO 29
C***
C28 WRITE(6,43) RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
- 27 WRITE (2,42) THET, PHI, TMP5, TMP6, GTOT, AXRAT, TILTA, ISENS,
+ 27 WRITE (6,42) THET, PHI, TMP5, TMP6, GTOT, AXRAT, TILTA, ISENS,
ÐM, ETHA, EPHM, EPHA
IF( IPLP1.NE.3) GOTO 299
IF( IPLP3.EQ.0) GOTO 290
@@ -7484,7 +7502,7 @@
IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*) PHI, TMP6
IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*) PHI, GTOT
GOTO 299
- 28 WRITE (2,43) RFLD, PHI, THET, ETHM, ETHA, EPHM, EPHA, ERDM, ERDA
+ 28 WRITE (6,43) RFLD, PHI, THET, ETHM, ETHA, EPHM, EPHA, ERDM, ERDA
&
C***
299 CONTINUE
@@ -7495,12 +7513,12 @@
TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4)))
PINT= PINT/ TMP3
TMP3= TMP3/ PI
- WRITE (2,44) PINT, TMP3
+ WRITE (6,44) PINT, TMP3
30 IF( INOR.EQ.0) GOTO 34
IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR
ITMP1=( INOR-1)*2+1
ITMP2= ITMP1+1
- WRITE (2,45) IGNTP( ITMP1), IGNTP( ITMP2), GMAX
+ WRITE (6,45) IGNTP( ITMP1), IGNTP( ITMP2), GMAX
ITMP2= NPH* NTH
IF( ITMP2.GT. NORMAX) ITMP2= NORMAX
ITMP1=( ITMP2+2)/3
@@ -7524,14 +7542,14 @@
IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32
TSTOR2= GAIN( ITMP3)- GMAX
PINT= GAIN( ITMP4)- GMAX
- 31 WRITE (2,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2, TMP5, TMP6,
+ 31 WRITE (6,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2, TMP5, TMP6,
& PINT
GOTO 34
32 IF( ITMP2.EQ.2) GOTO 33
TSTOR2= GAIN( ITMP3)- GMAX
- WRITE (2,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2
+ WRITE (6,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2
GOTO 34
- 33 WRITE (2,46) TMP1, TMP2, TSTOR1
+ 33 WRITE (6,46) TMP1, TMP2, TSTOR1
C
34 RETURN
35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//)
@@ -7574,7 +7592,7 @@
SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD)
C ***
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
INTEGER*4 NTOT
INTEGER*4 NINT
INTEGER*4 NFLT
@@ -7582,7 +7600,7 @@
INTEGER IARR( NINT), BP( NTOT), EP( NTOT)
DIMENSION RARR( NFLT)
CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132
- READ (1, 10) LINE
+ READ (5, 10) LINE
10 FORMAT(A)
NLIN= LEN(LINE)
@@ -7637,7 +7655,7 @@
IF( INDE.EQ.0) THEN
BUFFER( NLEN: NLEN)='.'
ELSE
- BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
+ BUFFER1= BUFFER(1: INDE-1)//'.'// BUFFER( INDE: NLEN-1)
BUFFER= BUFFER1
ENDIF
ENDIF
@@ -7654,8 +7672,8 @@
Z2= RARR(6)
RAD= RARR(7)
RETURN
- 110 WRITE (2,*) ' GEOMETRY DATA CARD ERROR'
- WRITE (2,*) LINE(1: MAX(1, NLIN-1))
+ 110 WRITE (6,*) ' GEOMETRY DATA CARD ERROR'
+ WRITE (6,*) LINE(1: MAX(1, NLIN-1))
STOP
END
C ***
@@ -7664,7 +7682,7 @@
SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6)
C ***
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
INTEGER*4 NTOT
INTEGER*4 NINT
INTEGER*4 NFLT
@@ -7672,7 +7690,7 @@
INTEGER IARR( NINT), BP( NTOT), EP( NTOT)
DIMENSION RARR( NFLT)
CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132
- READ (1,10) LINE
+ READ (5,10) LINE
10 FORMAT(A)
NLIN= LEN(LINE)
CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
@@ -7724,7 +7742,7 @@
IF( INDE.EQ.0) THEN
BUFFER( NLEN: NLEN)='.'
ELSE
- BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
+ BUFFER1= BUFFER(1: INDE-1)//'.'// BUFFER( INDE: NLEN-1)
BUFFER= BUFFER1
ENDIF
ENDIF
@@ -7742,8 +7760,8 @@
F5= RARR(5)
F6= RARR(6)
RETURN
- 110 WRITE (2,*) ' FAULTY DATA CARD AFTER GEOMETRY SECTION'
- WRITE (2,*) LINE(1: MAX(1, NLIN-1))
+ 110 WRITE (6,*) ' FAULTY DATA CARD AFTER GEOMETRY SECTION'
+ WRITE (6,*) LINE(1: MAX(1, NLIN-1))
STOP
END
C ***
@@ -7754,7 +7772,7 @@
C REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
C TO BLOCKS OF COLUMNS ON TAPE16
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX B, BX
COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
&NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
@@ -7791,7 +7809,7 @@
C STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -7818,7 +7836,7 @@
E1= Z( I)
E2= Z2( I)
IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1
- WRITE (2,24) I
+ WRITE (6,24) I
STOP
1 X( NX)= X( I)
Y( NX)= Y( I)
@@ -7838,7 +7856,7 @@
NXX= NXX-1
NX= NXX- M+ M1
IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4
- WRITE (2,25) I
+ WRITE (6,25) I
STOP
4 X( NX)= X( NXX)
Y( NX)= Y( NXX)
@@ -7862,7 +7880,7 @@
E1= Y( I)
E2= Y2( I)
IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7
- WRITE (2,24) I
+ WRITE (6,24) I
STOP
7 X( NX)= X( I)
Y( NX)=- E1
@@ -7882,7 +7900,7 @@
NXX= NXX-1
NX= NXX- M+ M1
IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10
- WRITE (2,25) I
+ WRITE (6,25) I
STOP
10 X( NX)= X( NXX)
Y( NX)=- Y( NXX)
@@ -7906,7 +7924,7 @@
E1= X( I)
E2= X2( I)
IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13
- WRITE (2,24) I
+ WRITE (6,24) I
STOP
13 X( NX)=- E1
Y( NX)= Y( I)
@@ -7925,7 +7943,7 @@
NXX= NXX-1
NX= NXX- M+ M1
IF( ABS( X( NXX)).GT.1.D-10) GOTO 16
- WRITE (2,25) I
+ WRITE (6,25) I
STOP
16 X( NX)=- X( NXX)
Y( NX)= Y( NXX)
@@ -8020,7 +8038,7 @@
ZE= B
S= B- A
IF( S.GE.0.) GOTO 1
- WRITE (2,18)
+ WRITE (6,18)
STOP
1 EP= S/(1.E4* NM)
ZEND= ZE- EP
@@ -8097,7 +8115,7 @@
GOTO 3
14 NT=0
IF( NS.LT. NM) GOTO 15
- WRITE (2,19) Z
+ WRITE (6,19) Z
GOTO 10
15 NS= NS*2
DZ= S/ NS
@@ -8119,7 +8137,7 @@
C ***
C COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -8242,7 +8260,7 @@
XXI= QP*(1.-.5* XXI)/(1.- XXI)
CC=1./( CDH- XXI* SDH)
RETURN
- 24 WRITE (2,25) I
+ 24 WRITE (6,25) I
C
STOP
25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
@@ -8257,7 +8275,7 @@
C THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX E, ERV, EZV, ERH, EZH, EPH, T1, EXK, EYK, EZK, EXS,
&EYS, EZS, EXC, EYC, EZC, XX1, XX2, U, U2, ZRATI, ZRATI2, FRATI,
&ER, ET, HRV, HZV, HRH
@@ -8377,7 +8395,7 @@
C ***
C SOLVE FOR CURRENT IN N.G.F. PROCEDURE
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, B, C, D, SUM, XY, Y
COMMON /SCRATM/ Y( N2M)
COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
@@ -8503,7 +8521,7 @@
C SOLUTION IS RETURNED THROUGH VECTOR B. (MATRIX TRANSPOSED.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, B, Y, SUM
INTEGER PI
COMMON /SCRATM/ Y( N2M)
@@ -8549,7 +8567,7 @@
C MATRIX EQ.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX A, B, Y, SUM, SSX
COMMON /SMAT/ SSX(16,16)
COMMON /SCRATM/ Y( N2M)
@@ -8667,7 +8685,7 @@
C ***
C COMPUTE BASIS FUNCTION I
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -8795,7 +8813,7 @@
27 JSNO= JSNOP
AX( JSNO)=-1.
RETURN
- 28 WRITE (2,29) I
+ 28 WRITE (6,29) I
C
STOP
29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
@@ -8809,7 +8827,7 @@
C TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
DEN= ABS( F2R)
TR= ABS( F2I)
IF( DEN.LT. TR) DEN= TR
@@ -8829,7 +8847,7 @@
C ***
C COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -8865,7 +8883,7 @@
CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO))
JCO( JSNO)= J
RETURN
- 9 WRITE (2,10) J
+ 9 WRITE (6,10) J
C
STOP
10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5)
@@ -8878,7 +8896,7 @@
C CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
C DIRECTIONS ON A PATCH
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
&ZRATI2, T1, ER, Q1, Q2, RRV, RRH, EDP, FRATI
COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
@@ -8969,7 +8987,7 @@
C WIRE OF NS SEGMENTS.
C
IMPLICIT REAL (A-H,O-Z)
- PARAMETER ( NM=600, N2M=800, N3M=1000)
+ PARAMETER ( NM=10000, N2M=15000, N3M=20000)
COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
&Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
& N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
@@ -9027,14 +9045,14 @@
C ***
C DOUBLE PRECISION 6/4/85
C
- FUNCTION ZINT( SIGL, ROLAM)
+ COMPLEX FUNCTION ZINT( SIGL, ROLAM)
C ***
C
C ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE
C
C
IMPLICIT REAL (A-H,O-Z)
- COMPLEX TH, PH, F, G, FJ, CN, BR1, BR2, ZINT
+ COMPLEX TH, PH, F, G, FJ, CN, BR1, BR2
COMPLEX CC1, CC2, CC3, CC4, CC5, CC6, CC7, CC8, CC9, CC10,
&CC11, CC12, CC13, CC14
DIMENSION FJX(2), CNX(2), CCN(28)
@@ -9083,9 +9101,10 @@
RETURN
END
+C .. Convert a string to upper case
SUBROUTINE STR0PC( STRING, STRING1)
CHARACTER *(*) STRING, STRING1
- INTEGER*4 I, J, IC
+ INTEGER*4 I, IC
INTEGER IS_PC
IS_PC = 0
@@ -9093,9 +9112,9 @@
DO 150, I=1, LEN( STRING)
IC= ICHAR( STRING( I: I))
- if (is_pc .ne. 0) then
+ IF (IS_PC .NE. 0) THEN
IF( IC.GE.97.AND. IC.LE.122) IC= IC-32
- endif
+ ENDIF
STRING1( I: I)= CHAR( IC)
150 CONTINUE
@@ -9103,3 +9122,21 @@
RETURN
END
+
+ SUBROUTINE FILEERR(MSG, FILE)
+ IMPLICIT NONE
+ CHARACTER *(*) MSG,FILE
+ INTEGER I
+
+ DO I=LEN(FILE),1,-1
+ IF (FILE(I:I).NE.' ') GOTO 100
+ ENDDO
+
+ 100 CONTINUE
+
+ PRINT *, 'Error:'
+ PRINT *, MSG
+ PRINT *, FILE(1:I)
+ RETURN
+ END
+
--- nec-2.orig/nec/nec2small.1
+++ nec-2/nec/nec2small.1
@@ -0,0 +1 @@
+.so man1/nec2.1
--- nec-2.orig/nec/nec2small.f
+++ nec-2/nec/nec2small.f
@@ -0,0 +1,9137 @@
+C PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14,
+C 1TAPE15,TAPE16,TAPE20,TAPE21)
+C
+C NUMERICAL ELECTROMAGNETICS CODE (NEC2) DEVELOPED AT LAWRENCE
+C LIVERMORE LAB., LIVERMORE, CA. (CONTACT G. BURKE AT 415-422-8414
+C FOR PROBLEMS WITH THE NEC CODE. FOR PROBLEMS WITH THE VAX IMPLEM-
+C ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415
+C 422-5936)
+C FILE CREATED 4/11/80.
+C
+C ***********NOTICE**********
+C THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK
+C SPONSORED BY THE UNITED STATES GOVERNMENT. NEITHER THE UNITED
+C STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF
+C THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR
+C THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
+C ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
+C COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT
+C OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
+C INFRINGE PRIVATELY-OWNED RIGHTS.
+C
+C***
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+C ***
+C MODIFIED BY ALAN BAIN TO USE COMMAND LINE ARGUMENTS AS NAMES
+C OF INPUT AND OUTPUT FILES IF PROVIDED.
+C
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C Change all these params and LD
+C .. N is number segments
+C .. M is number patches
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+
+ CHARACTER AIN*2, ATST*2, INFILE*256, OTFILE*256
+C***
+C INTEGER AIN,ATST,PNET
+C..Command Line parsing..
+ INTEGER NARGS
+ LOGICAL FISVALID
+
+ INTEGER*4 COM
+ CHARACTER*6 HPOL,PNET
+ COMPLEX CM, FJ, VSANT, ETH, EPH, ZRATI, CUR, CURI, ZARRAY,
+ &ZRATI2
+ COMPLEX EX, EY, EZ, ZPED, VQD, VQDS, T1, Y11A, Y12A, EPSC, U,
+ & U2, XX1, XX2
+ COMPLEX AR1, AR2, AR3, EPSCF, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /CMB/ CM(90000)
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SAVE/ IP( N2M), KCOM, COM(20,5), EPSR, SIG, SCRWLT,
+ &SCRWRT, FMHZ
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ COMMON /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
+ &20)
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ COMMON /NETCX/ ZPED, PIN, PNLS, NEQ, NPEQ, NEQ2, NONET, NTSOL,
+ &NPRINT, MASYM, ISEG1(150), ISEG2(150), X11R(150), X11I(150),
+ &X12R(150), X12I(150), X22R(150), X22I(150), NTYP(150)
+ COMMON /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
+ &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
+ &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
+ &
+ COMMON /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
+ &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
+C***
+ COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
+C***
+ COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
+ DIMENSION CAB(1), SAB(1), X2(1), Y2(1), Z2(1)
+ DIMENSION LDTYP(200), LDTAG(200), LDTAGF(200), LDTAGT(200),
+ & ZLR(200), ZLI(200), ZLC(200)
+ DIMENSION ATST(22), PNET(6), HPOL(3), IX( N2M)
+ DIMENSION FNORM(200)
+C***
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ DIMENSION XTEMP( NM), YTEMP( NM), ZTEMP( NM), SITEMP( NM),
+ &BITEMP( NM)
+ EQUIVALENCE(CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ DATA ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP',
+ &'CM','NX','EN','TL','PT','KH','NH','PQ','EK','WG','CP','PL'/
+ DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/
+ DATA PNET/6H ,2H ,6HSTRAIG,2HHT,6HCROSSE,1HD/
+ DATA TA/1.745329252D-02/, CVEL/299.8/
+C***
+ DATA LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/
+ 706 CONTINUE
+C..Fortran 77 Extension to get number args..
+ NARGS=IARGC()
+C..Defaults for terminal IO
+ INFILE=''
+ OTFILE=''
+
+ IF (NARGS.GT.2) THEN
+ PRINT *,'Error'
+ PRINT *,'nec2 [] []'
+ STOP
+ ENDIF
+
+ IF (NARGS.GE.1) THEN
+ CALL GETARG(1,INFILE)
+ INQUIRE(FILE=INFILE,EXIST=FISVALID)
+ IF (.NOT.FISVALID) GOTO 702
+ ENDIF
+
+ IF (NARGS.EQ.2) THEN
+ CALL GETARG(2,OTFILE)
+ ENDIF
+
+
+ IF( INFILE.NE.'') THEN
+ OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702)
+ ENDIF
+
+ IF( OTFILE.NE.'') THEN
+ OPEN ( UNIT=6,FILE=OTFILE,STATUS='UNKNOWN',ERR=704)
+ ENDIF
+ GOTO 705
+
+ 702 INLEN=LEN(INFILE)
+ CALL FILEERR('File not found',INFILE)
+ STOP
+
+ 703 CALL FILEERR('Unable to open input file',INFILE)
+ STOP
+
+ 704 CALL FILEERR('Unable to open output file for writing',
+ & OTFILE)
+ STOP
+
+C***
+ 705 CONTINUE
+ CALL SECNDS(EXTIM)
+ FJ=(0.,1.)
+ LD=NM
+ NXA(1)=0
+ IRESRV=90000
+C***
+ 1 KCOM=0
+ IFRTMW=0
+C***
+ IFRTMP=0
+ 2 KCOM= KCOM+1
+ IF( KCOM.GT.5) KCOM=5
+C***
+
+ READ( 5,125) AIN,( COM( I, KCOM), I=1,19)
+C***
+ CALL STR0PC( AIN, AIN)
+
+ if (KCOM .le. 0) then
+ WRITE (6,126)
+ WRITE (6,127)
+ WRITE (6,128)
+ endif
+
+ WRITE (6,129) ( COM( I, KCOM), I=1,19)
+
+ IF( AIN.EQ. ATST(11)) GOTO 2
+
+ if (AIN .ne. ATST(1)) then
+ WRITE (6,130)
+ STOP
+ endif
+
+C 4 CONTINUE
+
+ DO 5 I=1, LD
+ 5 ZARRAY( I)=(0.,0.)
+ MPCNT=0
+C
+C SET UP GEOMETRY DATA IN SUBROUTINE DATAGN
+C
+ IMAT=0
+ CALL DATAGN
+ IFLOW=1
+C
+C CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION
+C
+ IF( IMAT.EQ.0) GOTO 326
+ NEQ= N1+2* M1
+ NEQ2= N- N1+2*( M- M1)+ NSCON+2* NPCON
+ CALL FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
+ GOTO 6
+ 326 NEQ= N+2* M
+ NEQ2=0
+ IB11=1
+ IC11=1
+ ID11=1
+ IX11=1
+ ICASX=0
+ 6 NPEQ= NP+2* MP
+C
+C DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
+C
+C***
+ WRITE (6,135)
+ IPLP1=0
+ IPLP2=0
+ IPLP3=0
+C***
+ IPLP4=0
+ IGO=1
+ FMHZS= CVEL
+ NFRQ=1
+ RKH=1.
+ IEXK=0
+ IXTYP=0
+ NLOAD=0
+ NONET=0
+ NEAR=-1
+ IPTFLG=-2
+ IPTFLQ=-1
+ IFAR=-1
+ ZRATI=(1.,0.)
+ IPED=0
+ IRNGF=0
+ NCOUP=0
+ ICOUP=0
+ IF( ICASX.GT.0) GOTO 14
+ FMHZ= CVEL
+ NLODF=0
+ KSYMP=1
+ NRADL=0
+C
+C MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
+C PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
+C
+C14 READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
+C 1TMP6
+C***
+ IPERF=0
+C***
+ 14 CALL READMN( AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2, TMP3,
+ &TMP4, TMP5, TMP6)
+ PRINT *,'Done READMN'
+ MPCNT= MPCNT+1
+ WRITE (6,137) MPCNT, AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2
+ &, TMP3, TMP4, TMP5, TMP6
+ IF( AIN.EQ. ATST(2)) GOTO 16
+ IF( AIN.EQ. ATST(3)) GOTO 17
+ IF( AIN.EQ. ATST(4)) GOTO 21
+ IF( AIN.EQ. ATST(5)) GOTO 24
+ IF( AIN.EQ. ATST(6)) GOTO 28
+ IF( AIN.EQ. ATST(14)) GOTO 28
+ IF( AIN.EQ. ATST(15)) GOTO 31
+ IF( AIN.EQ. ATST(18)) GOTO 319
+ IF( AIN.EQ. ATST(7)) GOTO 37
+ IF( AIN.EQ. ATST(8)) GOTO 32
+ IF( AIN.EQ. ATST(17)) GOTO 208
+ IF( AIN.EQ. ATST(9)) GOTO 34
+ IF( AIN.EQ. ATST(10)) GOTO 36
+ IF( AIN.EQ. ATST(16)) GOTO 305
+ IF( AIN.EQ. ATST(19)) GOTO 320
+ IF( AIN.EQ. ATST(12)) GOTO 1
+ IF( AIN.EQ. ATST(20)) GOTO 322
+C***
+ IF( AIN.EQ. ATST(21)) GOTO 304
+C***
+ IF( AIN.EQ. ATST(22)) GOTO 330
+ IF( AIN.NE. ATST(13)) GOTO 15
+ CALL SECNDS( TMP1)
+ TMP1= TMP1- EXTIM
+ WRITE (6,201) TMP1
+ STOP
+ 15 WRITE (6,138)
+C
+C FREQUENCY PARAMETERS
+C
+ STOP
+ 16 IFRQ= ITMP1
+ IF( ICASX.EQ.0) GOTO 8
+ WRITE (6,303) AIN
+ STOP
+ 8 NFRQ= ITMP2
+ IF( NFRQ.EQ.0) NFRQ=1
+ FMHZ= TMP1
+ DELFRQ= TMP2
+ IF( IPED.EQ.1) ZPNORM=0.
+ IGO=1
+ IFLOW=1
+C
+C MATRIX INTEGRATION LIMIT
+C
+ GOTO 14
+ 305 RKH= TMP1
+ IF( IGO.GT.2) IGO=2
+ IFLOW=1
+C
+C EXTENDED THIN WIRE KERNEL OPTION
+C
+ GOTO 14
+ 320 IEXK=1
+ IF( ITMP1.EQ.-1) IEXK=0
+ IF( IGO.GT.2) IGO=2
+ IFLOW=1
+C
+C MAXIMUM COUPLING BETWEEN ANTENNAS
+C
+ GOTO 14
+ 304 IF( IFLOW.NE.2) NCOUP=0
+ ICOUP=0
+ IFLOW=2
+ IF( ITMP2.EQ.0) GOTO 14
+ NCOUP= NCOUP+1
+ IF( NCOUP.GT.5) GOTO 312
+ NCTAG( NCOUP)= ITMP1
+ NCSEG( NCOUP)= ITMP2
+ IF( ITMP4.EQ.0) GOTO 14
+ NCOUP= NCOUP+1
+ IF( NCOUP.GT.5) GOTO 312
+ NCTAG( NCOUP)= ITMP3
+ NCSEG( NCOUP)= ITMP4
+ GOTO 14
+ 312 WRITE (6,313)
+C
+C LOADING PARAMETERS
+C
+ STOP
+ 17 IF( IFLOW.EQ.3) GOTO 18
+ NLOAD=0
+ IFLOW=3
+ IF( IGO.GT.2) IGO=2
+ IF( ITMP1.EQ.(-1)) GOTO 14
+ 18 NLOAD= NLOAD+1
+ IF( NLOAD.LE. LOADMX) GOTO 19
+ WRITE (6,139)
+ STOP
+ 19 LDTYP( NLOAD)= ITMP1
+ LDTAG( NLOAD)= ITMP2
+ IF( ITMP4.EQ.0) ITMP4= ITMP3
+ LDTAGF( NLOAD)= ITMP3
+ LDTAGT( NLOAD)= ITMP4
+ IF( ITMP4.GE. ITMP3) GOTO 20
+ WRITE (6,140) NLOAD, ITMP3, ITMP4
+ STOP
+ 20 ZLR( NLOAD)= TMP1
+ ZLI( NLOAD)= TMP2
+ ZLC( NLOAD)= TMP3
+C
+C GROUND PARAMETERS UNDER THE ANTENNA
+C
+ GOTO 14
+ 21 IFLOW=4
+ IF( ICASX.EQ.0) GOTO 10
+ WRITE (6,303) AIN
+ STOP
+ 10 IF( IGO.GT.2) IGO=2
+ IF( ITMP1.NE.(-1)) GOTO 22
+ KSYMP=1
+ NRADL=0
+ IPERF=0
+ GOTO 14
+ 22 IPERF= ITMP1
+ NRADL= ITMP2
+ KSYMP=2
+ EPSR= TMP1
+ SIG= TMP2
+ IF( NRADL.EQ.0) GOTO 23
+ IF( IPERF.NE.2) GOTO 314
+ WRITE (6,390)
+ STOP
+ 314 SCRWLT= TMP3
+ SCRWRT= TMP4
+ GOTO 14
+ 23 EPSR2= TMP3
+ SIG2= TMP4
+ CLT= TMP5
+ CHT= TMP6
+C
+C EXCITATION PARAMETERS
+C
+ GOTO 14
+ 24 IF( IFLOW.EQ.5) GOTO 25
+ NSANT=0
+ NVQD=0
+ IPED=0
+ IFLOW=5
+ IF( IGO.GT.3) IGO=3
+ 25 MASYM= ITMP4/10
+ IF( ITMP1.GT.0.AND. ITMP1.NE.5) GOTO 27
+ IXTYP= ITMP1
+ NTSOL=0
+ IF( IXTYP.EQ.0) GOTO 205
+ NVQD= NVQD+1
+ IF( NVQD.GT. NSMAX) GOTO 206
+ IVQD( NVQD)= ISEGNO( ITMP2, ITMP3)
+ VQD( NVQD)= CMPLX( TMP1, TMP2)
+ IF( ABS( VQD( NVQD)).LT.1.D-20) VQD( NVQD)=(1.,0.)
+ GOTO 207
+ 205 NSANT= NSANT+1
+ IF( NSANT.LE. NSMAX) GOTO 26
+ 206 WRITE (6,141)
+ STOP
+ 26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3)
+ VSANT( NSANT)= CMPLX( TMP1, TMP2)
+ IF( ABS( VSANT( NSANT)).LT.1.D-20) VSANT( NSANT)=(1.,0.)
+ 207 IPED= ITMP4- MASYM*10
+ ZPNORM= TMP3
+ IF( IPED.EQ.1.AND. ZPNORM.GT.0) IPED=2
+ GOTO 14
+ 27 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) NTSOL=0
+ IXTYP= ITMP1
+ NTHI= ITMP2
+ NPHI= ITMP3
+ XPR1= TMP1
+ XPR2= TMP2
+ XPR3= TMP3
+ XPR4= TMP4
+ XPR5= TMP5
+ XPR6= TMP6
+ NSANT=0
+ NVQD=0
+ THETIS= XPR1
+ PHISS= XPR2
+C
+C NETWORK PARAMETERS
+C
+ GOTO 14
+ 28 IF( IFLOW.EQ.6) GOTO 29
+ NONET=0
+ NTSOL=0
+ IFLOW=6
+ IF( IGO.GT.3) IGO=3
+ IF( ITMP2.EQ.(-1)) GOTO 14
+ 29 NONET= NONET+1
+ IF( NONET.LE. NETMX) GOTO 30
+ WRITE (6,142)
+ STOP
+ 30 NTYP( NONET)=2
+ IF( AIN.EQ. ATST(6)) NTYP( NONET)=1
+ ISEG1( NONET)= ISEGNO( ITMP1, ITMP2)
+ ISEG2( NONET)= ISEGNO( ITMP3, ITMP4)
+ X11R( NONET)= TMP1
+ X11I( NONET)= TMP2
+ X12R( NONET)= TMP3
+ X12I( NONET)= TMP4
+ X22R( NONET)= TMP5
+ X22I( NONET)= TMP6
+ IF( NTYP( NONET).EQ.1.OR. TMP1.GT.0.) GOTO 14
+ NTYP( NONET)=3
+C***
+C
+C PLOT FLAGS
+C
+ X11R( NONET)=- TMP1
+ 330 IPLP1= ITMP1
+ IPLP2= ITMP2
+ IPLP3= ITMP3
+C***
+ IPLP4= ITMP4
+C
+C PRINT CONTROL FOR CURRENT
+C
+ GOTO 14
+ 31 IPTFLG= ITMP1
+ IPTAG= ITMP2
+ IPTAGF= ITMP3
+ IPTAGT= ITMP4
+ IF( ITMP3.EQ.0.AND. IPTFLG.NE.-1) IPTFLG=-2
+ IF( ITMP4.EQ.0) IPTAGT= IPTAGF
+C
+C WRITE CONTROL FOR CHARGE
+C
+ GOTO 14
+ 319 IPTFLQ= ITMP1
+ IPTAQ= ITMP2
+ IPTAQF= ITMP3
+ IPTAQT= ITMP4
+ IF( ITMP3.EQ.0.AND. IPTFLQ.NE.-1) IPTFLQ=-2
+ IF( ITMP4.EQ.0) IPTAQT= IPTAQF
+C
+C NEAR FIELD CALCULATION PARAMETERS
+C
+ GOTO 14
+ 208 NFEH=1
+ GOTO 209
+ 32 NFEH=0
+ 209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33
+ WRITE (6,143)
+ 33 NEAR= ITMP1
+ NRX= ITMP2
+ NRY= ITMP3
+ NRZ= ITMP4
+ XNR= TMP1
+ YNR= TMP2
+ ZNR= TMP3
+ DXNR= TMP4
+ DYNR= TMP5
+ DZNR= TMP6
+ IFLOW=8
+ IF( NFRQ.NE.1) GOTO 14
+C
+C GROUND REPRESENTATION
+C
+ GOTO (41,46,53,71,72), IGO
+ 34 EPSR2= TMP1
+ SIG2= TMP2
+ CLT= TMP3
+ CHT= TMP4
+ IFLOW=9
+C
+C STANDARD OBSERVATION ANGLE PARAMETERS
+C
+ GOTO 14
+ 36 IFAR= ITMP1
+ NTH= ITMP2
+ NPH= ITMP3
+ IF( NTH.EQ.0) NTH=1
+ IF( NPH.EQ.0) NPH=1
+ IPD= ITMP4/10
+ IAVP= ITMP4- IPD*10
+ INOR= IPD/10
+ IPD= IPD- INOR*10
+ IAX= INOR/10
+ INOR= INOR- IAX*10
+ IF( IAX.NE.0) IAX=1
+ IF( IPD.NE.0) IPD=1
+ IF( NTH.LT.2.OR. NPH.LT.2) IAVP=0
+ IF( IFAR.EQ.1) IAVP=0
+ THETS= TMP1
+ PHIS= TMP2
+ DTH= TMP3
+ DPH= TMP4
+ RFLD= TMP5
+ GNOR= TMP6
+ IFLOW=10
+C
+C WRITE NUMERICAL GREEN'S FUNCTION TAPE
+C
+ GOTO (41,46,53,71,78), IGO
+ 322 IFLOW=12
+ IF( ICASX.EQ.0) GOTO 301
+ WRITE (6,302)
+ STOP
+ 301 IRNGF= IRESRV/2
+C
+C EXECUTE CARD - CALC. INCLUDING RADIATED FIELDS
+C
+ GOTO (41,46,52,52,52), IGO
+ 37 IF( IFLOW.EQ.10.AND. ITMP1.EQ.0) GOTO 14
+ IF( NFRQ.EQ.1.AND. ITMP1.EQ.0.AND. IFLOW.GT.7) GOTO 14
+ IF( ITMP1.NE.0) GOTO 39
+ IF( IFLOW.GT.7) GOTO 38
+ IFLOW=7
+ GOTO 40
+ 38 IFLOW=11
+ GOTO 40
+ 39 IFAR=0
+ RFLD=0.
+ IPD=0
+ IAVP=0
+ INOR=0
+ IAX=0
+ NTH=91
+ NPH=1
+ THETS=0.
+ PHIS=0.
+ DTH=1.0
+ DPH=0.
+ IF( ITMP1.EQ.2) PHIS=90.
+ IF( ITMP1.NE.3) GOTO 40
+ NPH=2
+ DPH=90.
+C
+C END OF THE MAIN INPUT SECTION
+C
+C BEGINNING OF THE FREQUENCY DO LOOP
+C
+ 40 GOTO (41,46,53,71,78), IGO
+C***
+ 41 MHZ=1
+ IF( N.EQ.0.OR. IFRTMW.EQ.1) GOTO 406
+ IFRTMW=1
+ DO 445 I=1, N
+ XTEMP( I)= X( I)
+ YTEMP( I)= Y( I)
+ ZTEMP( I)= Z( I)
+ SITEMP( I)= SI( I)
+ BITEMP( I)= BI( I)
+ 445 CONTINUE
+ 406 IF( M.EQ.0.OR. IFRTMP.EQ.1) GOTO 407
+ IFRTMP=1
+ J= LD+1
+ DO 545 I=1, M
+ J= J-1
+ XTEMP( J)= X( J)
+ YTEMP( J)= Y( J)
+ ZTEMP( J)= Z( J)
+ BITEMP( J)= BI( J)
+ 545 CONTINUE
+ 407 CONTINUE
+C***
+C CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX. (A)
+ FMHZ1= FMHZ
+ IF( IMAT.EQ.0) CALL FBLOCK( NPEQ, NEQ, IRESRV, IRNGF, IPSYM)
+ 42 IF( MHZ.EQ.1) GOTO 44
+C FMHZ=FMHZ+DELFRQ
+C***
+ IF( IFRQ.EQ.1) GOTO 43
+ FMHZ= FMHZ1+( MHZ-1)* DELFRQ
+ GOTO 44
+ 43 FMHZ= FMHZ* DELFRQ
+C***
+ 44 FR= FMHZ/ CVEL
+ WLAM= CVEL/ FMHZ
+ WRITE (6,145) FMHZ, WLAM
+ WRITE (6,196) RKH
+C FREQUENCY SCALING OF GEOMETRIC PARAMETERS
+C*** FMHZS=FMHZ
+ IF( IEXK.EQ.1) WRITE (6,321)
+ IF( N.EQ.0) GOTO 306
+C***
+ DO 45 I=1, N
+ X( I)= XTEMP( I)* FR
+ Y( I)= YTEMP( I)* FR
+ Z( I)= ZTEMP( I)* FR
+ SI( I)= SITEMP( I)* FR
+C***
+ 45 BI( I)= BITEMP( I)* FR
+ 306 IF( M.EQ.0) GOTO 307
+ FR2= FR* FR
+ J= LD+1
+ DO 245 I=1, M
+C***
+ J= J-1
+ X( J)= XTEMP( J)* FR
+ Y( J)= YTEMP( J)* FR
+ Z( J)= ZTEMP( J)* FR
+C***
+ 245 BI( J)= BITEMP( J)* FR2
+C STRUCTURE SEGMENT LOADING
+ 307 IGO=2
+ 46 WRITE (6,146)
+ IF( NLOAD.NE.0) CALL LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI
+ &, ZLC)
+ IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE (6,147)
+C GROUND PARAMETER
+ IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE (6,327)
+ WRITE (6,148)
+ IF( KSYMP.EQ.1) GOTO 49
+ FRATI=(1.,0.)
+ IF( IPERF.EQ.1) GOTO 48
+ IF( SIG.LT.0.) SIG=- SIG/(59.96* WLAM)
+ EPSC= CMPLX( EPSR,- SIG* WLAM*59.96)
+ ZRATI=1./ SQRT( EPSC)
+ U= ZRATI
+ U2= U* U
+ IF( NRADL.EQ.0) GOTO 47
+ SCRWL= SCRWLT/ WLAM
+ SCRWR= SCRWRT/ WLAM
+ T1= FJ*2367.067D+0/ DFLOAT( NRADL)
+ T2= SCRWR* DFLOAT( NRADL)
+ WRITE (6,170) NRADL, SCRWLT, SCRWRT
+ WRITE (6,149)
+ 47 IF( IPERF.EQ.2) GOTO 328
+ WRITE (6,391)
+ GOTO 329
+ 328 IF( NXA(1).EQ.0) READ( 21) AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
+ &YSA, NXA, NYA
+ FRATI=( EPSC-1.)/( EPSC+1.)
+ IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400
+ WRITE (6,393) EPSCF, EPSC
+ STOP
+ 400 WRITE (6,392)
+ 329 WRITE (6,150) EPSR, SIG, EPSC
+ GOTO 50
+ 48 WRITE (6,151)
+ GOTO 50
+ 49 WRITE (6,152)
+C * * *
+C FILL AND FACTOR PRIMARY INTERACTION MATRIX
+C
+ 50 CONTINUE
+ CALL SECNDS( TIM1)
+ IF( ICASX.NE.0) GOTO 324
+ CALL CMSET( NEQ, CM, RKH, IEXK)
+ CALL SECNDS( TIM2)
+ TIM= TIM2- TIM1
+ CALL FACTRS( NPEQ, NEQ, CM, IP, IX,11,12,13,14)
+C
+C N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)
+C
+C ****
+ GOTO 323
+C ****
+ 324 IF( NEQ2.EQ.0) GOTO 333
+ CALL CMNGF( CM( IB11), CM( IC11), CM( ID11), NPBX, NEQ, NEQ2, RKH
+ &, IEXK)
+ CALL SECNDS( TIM2)
+ TIM= TIM2- TIM1
+ CALL FACGF( CM, CM( IB11), CM( IC11), CM( ID11), CM( IX11), IP,
+ &IX, NP, N1, MP, M1, NEQ, NEQ2)
+ 323 CALL SECNDS( TIM1)
+ TIM2= TIM1- TIM2
+ WRITE (6,153) TIM, TIM2
+ 333 IGO=3
+ NTSOL=0
+C WRITE N.G.F. FILE
+ IF( IFLOW.NE.12) GOTO 53
+ 52 CALL GFOUT
+C
+C EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)
+C
+ GOTO 14
+ 53 NTHIC=1
+ NPHIC=1
+ INC=1
+ NPRINT=0
+ 54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56
+ IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE (6,154)
+ TMP5= TA* XPR5
+ TMP4= TA* XPR4
+ IF( IXTYP.NE.4) GOTO 55
+ TMP1= XPR1/ WLAM
+ TMP2= XPR2/ WLAM
+ TMP3= XPR3/ WLAM
+ TMP6= XPR6/( WLAM* WLAM)
+ WRITE (6,156) XPR1, XPR2, XPR3, XPR4, XPR5, XPR6
+ GOTO 56
+ 55 TMP1= TA* XPR1
+ TMP2= TA* XPR2
+ TMP3= TA* XPR3
+ TMP6= XPR6
+ IF( IPTFLG.LE.0) WRITE (6,155) XPR1, XPR2, XPR3, HPOL( IXTYP),
+ &XPR6
+C
+C MATRIX SOLVING (NETWK CALLS SOLVES)
+C
+ 56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR)
+ IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60
+ WRITE (6,158)
+ ITMP3=0
+ ITMP1= NTYP(1)
+ DO 59 I=1,2
+ IF( ITMP1.EQ.3) ITMP1=2
+ IF( ITMP1.EQ.2) WRITE (6,159)
+ IF( ITMP1.EQ.1) WRITE (6,160)
+ DO 58 J=1, NONET
+ ITMP2= NTYP( J)
+ IF(( ITMP2/ ITMP1).EQ.1) GOTO 57
+ ITMP3= ITMP2
+ GOTO 58
+ 57 ITMP4= ISEG1( J)
+ ITMP5= ISEG2( J)
+ IF( ITMP2.GE.2.AND. X11I( J).LE.0.) X11I( J)= WLAM* SQRT(( X(
+ &ITMP5)- X( ITMP4))**2+( Y( ITMP5)- Y( ITMP4))**2+( Z( ITMP5)- Z(
+ &ITMP4))**2)
+ WRITE (6,157) ITAG( ITMP4), ITMP4, ITAG( ITMP5), ITMP5, X11R( J)
+ &, X11I( J), X12R( J), X12I( J), X22R( J), X22I( J), PNET(2* ITMP2
+ &-1), PNET(2* ITMP2)
+ 58 CONTINUE
+ IF( ITMP3.EQ.0) GOTO 60
+ ITMP1= ITMP3
+ 59 CONTINUE
+ 60 CONTINUE
+ IF( INC.GT.1.AND. IPTFLG.GT.0) NPRINT=1
+ CALL NETWK( CM, CM( IB11), CM( IC11), CM( ID11), IP, CUR)
+ NTSOL=1
+ IF( IPED.EQ.0) GOTO 61
+ ITMP1= MHZ+4*( MHZ-1)
+ IF( ITMP1.GT.( NORMF-3)) GOTO 61
+ FNORM( ITMP1)= REAL( ZPED)
+ FNORM( ITMP1+1)= AIMAG( ZPED)
+ FNORM( ITMP1+2)= ABS( ZPED)
+ FNORM( ITMP1+3)= CANG( ZPED)
+ IF( IPED.EQ.2) GOTO 61
+ IF( FNORM( ITMP1+2).GT. ZPNORM) ZPNORM= FNORM( ITMP1+2)
+C
+C PRINTING STRUCTURE CURRENTS
+C
+ 61 CONTINUE
+ IF( N.EQ.0) GOTO 308
+ IF( IPTFLG.EQ.(-1)) GOTO 63
+ IF( IPTFLG.GT.0) GOTO 62
+ WRITE (6,161)
+ WRITE (6,162)
+ GOTO 63
+ 62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63
+ WRITE (6,163) XPR3, HPOL( IXTYP), XPR6
+ 63 PLOSS=0.
+ ITMP1=0
+ JUMP= IPTFLG+1
+ DO 69 I=1, N
+ CURI= CUR( I)* WLAM
+ CMAG= ABS( CURI)
+ PH= CANG( CURI)
+ IF( NLOAD.EQ.0.AND. NLODF.EQ.0) GOTO 64
+ IF( ABS( REAL( ZARRAY( I))).LT.1.D-20) GOTO 64
+ PLOSS= PLOSS+.5* CMAG* CMAG* REAL( ZARRAY( I))* SI( I)
+ 64 IF( JUMP) 68,69,65
+ 65 IF( IPTAG.EQ.0) GOTO 66
+ IF( ITAG( I).NE. IPTAG) GOTO 69
+ 66 ITMP1= ITMP1+1
+ IF( ITMP1.LT. IPTAGF.OR. ITMP1.GT. IPTAGT) GOTO 69
+ IF( IPTFLG.EQ.0) GOTO 68
+ IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67
+ FNORM( INC)= CMAG
+ ISAVE= I
+ 67 IF( IPTFLG.NE.3) WRITE (6,164) XPR1, XPR2, CMAG, PH, I
+ GOTO 69
+C***
+ 68 WRITE (6,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
+ &CMAG, PH
+ IF( IPLP1.NE.1) GOTO 69
+ IF( IPLP2.EQ.1) WRITE( 8,*) CURI
+C***
+ IF( IPLP2.EQ.2) WRITE( 8,*) CMAG, PH
+ 69 CONTINUE
+ IF( IPTFLQ.EQ.(-1)) GOTO 308
+ WRITE (6,315)
+ ITMP1=0
+ FR=1.D-6/ FMHZ
+ DO 316 I=1, N
+ IF( IPTFLQ.EQ.(-2)) GOTO 318
+ IF( IPTAQ.EQ.0) GOTO 317
+ IF( ITAG( I).NE. IPTAQ) GOTO 316
+ 317 ITMP1= ITMP1+1
+ IF( ITMP1.LT. IPTAQF.OR. ITMP1.GT. IPTAQT) GOTO 316
+ 318 CURI= FR* CMPLX(- BII( I), BIR( I))
+ CMAG= ABS( CURI)
+ PH= CANG( CURI)
+ WRITE (6,165) I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
+ &CMAG, PH
+ 316 CONTINUE
+ 308 IF( M.EQ.0) GOTO 310
+ WRITE (6,197)
+ J= N-2
+ ITMP1= LD+1
+ DO 309 I=1, M
+ J= J+3
+ ITMP1= ITMP1-1
+ EX= CUR( J)
+ EY= CUR( J+1)
+ EZ= CUR( J+2)
+ ETH= EX* T1X( ITMP1)+ EY* T1Y( ITMP1)+ EZ* T1Z( ITMP1)
+ EPH= EX* T2X( ITMP1)+ EY* T2Y( ITMP1)+ EZ* T2Z( ITMP1)
+ ETHM= ABS( ETH)
+ ETHA= CANG( ETH)
+ EPHM= ABS( EPH)
+C309 WRITE(6,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E
+C 1X,EY, EZ
+C***
+ EPHA= CANG( EPH)
+ WRITE (6,198) I, X( ITMP1), Y( ITMP1), Z( ITMP1), ETHM, ETHA,
+ &EPHM, EPHA, EX, EY, EZ
+ IF( IPLP1.NE.1) GOTO 309
+ IF( IPLP3.EQ.1) WRITE( 8,*) EX
+ IF( IPLP3.EQ.2) WRITE( 8,*) EY
+ IF( IPLP3.EQ.3) WRITE( 8,*) EZ
+ IF( IPLP3.EQ.4) WRITE( 8,*) EX, EY, EZ
+C***
+ 309 CONTINUE
+ 310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70
+ TMP1= PIN- PNLS- PLOSS
+ TMP2=100.* TMP1/ PIN
+ WRITE (6,166) PIN, TMP1, PLOSS, PNLS, TMP2
+ 70 CONTINUE
+ IGO=4
+ IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM)
+ IF( IFLOW.NE.7) GOTO 71
+ IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113
+ IF( NFRQ.NE.1) GOTO 120
+ WRITE (6,135)
+ GOTO 14
+C
+C NEAR FIELD CALCULATION
+C
+ 71 IGO=5
+ 72 IF( NEAR.EQ.(-1)) GOTO 78
+ CALL NFPAT
+ IF( MHZ.EQ. NFRQ) NEAR=-1
+ IF( NFRQ.NE.1) GOTO 78
+ WRITE (6,135)
+C
+C STANDARD FAR FIELD CALCULATION
+C
+ GOTO 14
+ 78 IF( IFAR.EQ.-1) GOTO 113
+ PINR= PIN
+ PNLR= PNLS
+ CALL RDPAT
+ 113 IF( IXTYP.EQ.0.OR. IXTYP.GE.4) GOTO 119
+ NTHIC= NTHIC+1
+ INC= INC+1
+ XPR1= XPR1+ XPR4
+ IF( NTHIC.LE. NTHI) GOTO 54
+ NTHIC=1
+ XPR1= THETIS
+ XPR2= XPR2+ XPR5
+ NPHIC= NPHIC+1
+ IF( NPHIC.LE. NPHI) GOTO 54
+ NPHIC=1
+ XPR2= PHISS
+C NORMALIZED RECEIVING PATTERN PRINTED
+ IF( IPTFLG.LT.2) GOTO 119
+ ITMP1= NTHI* NPHI
+ IF( ITMP1.LE. NORMF) GOTO 114
+ ITMP1= NORMF
+ WRITE (6,181)
+ 114 TMP1= FNORM(1)
+ DO 115 J=2, ITMP1
+ IF( FNORM( J).GT. TMP1) TMP1= FNORM( J)
+ 115 CONTINUE
+ WRITE (6,182) TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE
+ DO 118 J=1, NPHI
+ ITMP2= NTHI*( J-1)
+ DO 116 I=1, NTHI
+ ITMP3= I+ ITMP2
+ IF( ITMP3.GT. ITMP1) GOTO 117
+ TMP2= FNORM( ITMP3)/ TMP1
+ TMP3= DB20( TMP2)
+ WRITE (6,183) XPR1, XPR2, TMP3, TMP2
+ XPR1= XPR1+ XPR4
+ 116 CONTINUE
+ 117 XPR1= THETIS
+ XPR2= XPR2+ XPR5
+ 118 CONTINUE
+ XPR2= PHISS
+ 119 IF( MHZ.EQ. NFRQ) IFAR=-1
+ IF( NFRQ.NE.1) GOTO 120
+ WRITE (6,135)
+ GOTO 14
+ 120 MHZ= MHZ+1
+ IF( MHZ.LE. NFRQ) GOTO 42
+ IF( IPED.EQ.0) GOTO 123
+ IF( NVQD.LT.1) GOTO 199
+ WRITE (6,184) IVQD( NVQD), ZPNORM
+ GOTO 204
+ 199 WRITE (6,184) ISANT( NSANT), ZPNORM
+ 204 ITMP1= NFRQ
+ IF( ITMP1.LE.( NORMF/4)) GOTO 121
+ ITMP1= NORMF/4
+ WRITE (6,185)
+ 121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ
+ IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1))
+ DO 122 I=1, ITMP1
+ ITMP2= I+4*( I-1)
+ TMP2= FNORM( ITMP2)/ ZPNORM
+ TMP3= FNORM( ITMP2+1)/ ZPNORM
+ TMP4= FNORM( ITMP2+2)/ ZPNORM
+ TMP5= FNORM( ITMP2+3)
+ WRITE (6,186) TMP1, FNORM( ITMP2), FNORM( ITMP2+1), FNORM( ITMP2
+ &+2), FNORM( ITMP2+3), TMP2, TMP3, TMP4, TMP5
+ IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ
+ IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ
+ 122 CONTINUE
+ WRITE (6,135)
+ 123 CONTINUE
+ NFRQ=1
+ MHZ=1
+ GOTO 14
+ 125 FORMAT(A2,19A4)
+ 126 FORMAT('1')
+ 127 FORMAT(///,33X,'************************************',//,36X,
+ &'NUMERICAL ELECTROMAGNETICS CODE',//,33X,
+ &'************************************')
+ 128 FORMAT(////,37X,'- - - - COMMENTS - - - -',//)
+C 129 FORMAT(25X,20A4)
+ 129 FORMAT(' ', 20A4)
+ 130 FORMAT(///,10X,'INCORRECT LABEL FOR A COMMENT CARD')
+ 135 FORMAT(/////)
+ 136 FORMAT(A2,I3,3I5,6E10.3)
+ 137 FORMAT(1X,'***** DATA CARD NO.',I3,3X,A2,1X,I3,3(1X,I5),6(1X,1P,E
+ &12.5))
+ 138 FORMAT(///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION')
+ 139 FORMAT(///,10X,'NUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTED'
+ &)
+ 140 FORMAT(///,10X,'DATA FAULT ON LOADING CARD NO.=',I5,5X,'ITAG S',
+ &'TEP1=',I5,' IS GREATER THAN ITAG STEP2=',I5)
+ 141 FORMAT(///,10X,'NUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO',
+ &'TTED')
+ 142 FORMAT(///,10X,'NUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTED'
+ &)
+ 143 FORMAT(///,10X,'WHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ONE
+ & NEAR FIELD CARD CAN BE USED -',/,10X,'LAST CARD READ IS USED')
+ 145 FORMAT(////,33X,'- - - - - - FREQUENCY - - - - - -',//,36X,'FR',
+ &'EQUENCY=',1P,E11.4,' MHZ',/,36X,'WAVELENGTH=',E11.4,' METERS')
+ 146 FORMAT(///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -')
+ 147 FORMAT(/,35X,'THIS STRUCTURE IS NOT LOADED')
+ 148 FORMAT(///,34X,'- - - ANTENNA ENVIRONMENT - - -',/)
+ 149 FORMAT(40X,'MEDIUM UNDER SCREEN -')
+ 150 FORMAT(40X,'RELATIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIV',
+ &'ITY=',1P,E10.3,' MHOS/METER',/,40X,
+ &'COMPLEX DIELECTRIC CONSTANT=',2E12.5)
+ 151 FORMAT(42X,'PERFECT GROUND')
+ 152 FORMAT(44X,'FREE SPACE')
+ 153 FORMAT(///,32X,'- - - MATRIX TIMING - - -',//,24X,'FILL=',F9.3,
+ &' SEC., FACTOR=',F9.3,' SEC.')
+ 154 FORMAT(///,40X,'- - - EXCITATION - - -')
+ 155 FORMAT(/,4X,'PLANE WAVE',4X,'THETA=',F7.2,' DEG, PHI=',F7.2,
+ &' DEG, ETA=',F7.2,' DEG, TYPE -',A6,'= AXIAL RATIO=',F6.3)
+ 156 FORMAT(/,31X,'POSITION (METERS)',14X,'ORIENTATION (DEG)=/',28X,
+ &'X',12X,'Y',12X,'Z',10X,'ALPHA',5X,'BETA',4X,'DIPOLE MOMENT',//,4
+ &X,'CURRENT SOURCE',1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3)
+ 157 FORMAT(4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2)
+ 158 FORMAT(///,44X,'- - - NETWORK DATA - - -')
+ 159 FORMAT(/,6X,'- FROM - - TO -',11X,'TRANSMISSION LINE',15X,
+ &'- - SHUNT ADMITTANCES (MHOS) - -',14X,'LINE',/,6X,
+ &'TAG SEG.',' TAG SEG.',6X,'IMPEDANCE',6X,'LENGTH',12X,
+ &'- END ONE -',17X,'- END TWO -',12X,'TYPE',/,6X,
+ &'NO. NO. NO. NO.',9X,'OHM''S',8X,'METERS',9X,'REAL',10X,
+ &'IMAG.',9X,'REAL',10X,'IMAG.')
+ 160 FORMAT(/,6X,'- FROM -',4X,'- TO -',26X,'- - ADMITTANCE MATRIX',
+ &' ELEMENTS (MHOS) - -',/,6X,'TAG SEG. TAG SEG.',13X,'(ON',
+ &'E,ONE)',19X,'(ONE,TWO)',19X,'(TWO,TWO)',/,6X,'NO. NO. NO.',
+ &' NO.',8X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.',9X,'REAL',10
+ &X,'IMAG.')
+ 161 FORMAT(///,29X,'- - - CURRENTS AND LOCATION - - -',//,33X,'DIS',
+ &'TANCES IN WAVELENGTHS')
+ 162 FORMAT(//,2X,'SEG.',2X,'TAG',4X,'COORD. OF SEG. CENTER',5X,'SEG.'
+ &,12X,'- - - CURRENT (AMPS) - - -',/,2X,'NO.',3X,'NO.',5X,'X',8X,
+ &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
+ 163 FORMAT(///,33X,'- - - RECEIVING PATTERN PARAMETERS - - -',/,43X,
+ &'ETA=',F7.2,' DEGREES',/,43X,'TYPE -',A6,/,43X,'AXIAL RATIO=',F6.
+ &3,//,11X,'THETA',6X,'PHI',10X,'- CURRENT -',9X,'SEG',/,11X,
+ &'(DEG)',5X,'(DEG)',7X,'MAGNITUDE',4X,'PHASE',6X,'NO.',/)
+ 164 FORMAT(10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5)
+ 165 FORMAT(1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3)
+ 166 FORMAT(///,40X,'- - - POWER BUDGET - - -',//,43X,'INPUT PO',
+ &'WER =',1P,E11.4,' WATTS',/,43X,'RADIATED POWER=',E11.4,
+ &' WATTS',/,43X,'STRUCTURE LOSS=',E11.4,' WATTS',/,43X,
+ &'NETWORK LOSS =',E11.4,' WATTS',/,43X,'EFFICIENCY =',0P,F7.2,
+ &' PERCENT')
+ 170 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
+ &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
+ &' METERS')
+ 181 FORMAT(///,4X,'RECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA',
+ &'TED')
+ 182 FORMAT(///,32X,'- - - NORMALIZED RECEIVING PATTERN - - -',/,41X,
+ &'NORMALIZATION FACTOR=',1P,E11.4,/,41X,'ETA=',0P,F7.2,' DEGREES',
+ &/,41X,'TYPE -',A6,/,41X,'AXIAL RATIO=',F6.3,/,41X,'SEGMENT NO.=',
+ &I5,//,21X,'THETA',6X,'PHI',9X,'- PATTERN -',/,21X,'(DEG)',5X,
+ &'(DEG)',8X,'DB',8X,'MAGNITUDE',/)
+ 183 FORMAT(20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)
+ 184 FORMAT(///,36X,'- - - INPUT IMPEDANCE DATA - - -',/,45X,'SO',
+ &'URCE SEGMENT NO.',I4,/,45X,'NORMALIZATION FACTOR=',1P,E12.5,//,7
+ &X,'FREQ.',13X,'- - UNNORMALIZED IMPEDANCE - -',21X,'-',
+ &' - NORMALIZED IMPEDANCE - -',/,19X,'RESISTANCE',4X,'REACTA',
+ &'NCE',6X,'MAGNITUDE',4X,'PHASE',7X,'RESISTANCE',4X,'REACTANCE',6X
+ &,'MAGNITUDE',4X,'PHASE',/,8X,'MHZ',11X,'OHMS',10X,'OHMS',11X,
+ &'OHMS',5X,'DEGREES',47X,'DEGREES',/)
+ 185 FORMAT(///,4X,'STORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A',
+ &'RRAY TRUNCATED')
+ 186 FORMAT(3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,E
+ &12.5),3X,E12.5,2X,0P,F7.2)
+ 196 FORMAT(////,20X,'APPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT',
+ &'S MORE THAN',F8.3,' WAVELENGTHS APART')
+ 197 FORMAT(////,41X,'- - - - SURFACE PATCH CURRENTS - - - -',//,50X,
+ &'DISTANCE IN WAVELENGTHS',/,50X,'CURRENT IN AMPS/METER',//,28X,
+ &'- - SURFACE COMPONENTS - -',19X,'- - - RECTANGULAR COM',
+ &'PONENTS - - -',/,6X,'PATCH CENTER',6X,'TANGENT VECTOR 1',3X,
+ &'TANGENT VECTOR 2',11X,'X',19X,'Y',19X,'Z',/,5X,'X',6X,'Y',6X,'Z'
+ &,5X,'MAG.',7X,'PHASE',3X,'MAG.',7X,'PHASE',3(4X,'REAL',6X,'IMAG.'
+ &))
+ 198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)
+ 201 FORMAT(/,' RUN TIME =',F10.3)
+ 315 FORMAT(///,34X,'- - - CHARGE DENSITIES - - -',//,36X,
+ &'DISTANCES IN WAVELENGTHS',///,2X,'SEG.',2X,'TAG',4X,
+ &'COORD. OF SEG. CENTER',5X,'SEG.',10X,
+ &'CHARGE DENSITY (COULOMBS/METER)',/,2X,'NO.',3X,'NO.',5X,'X',8X,
+ &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
+ &
+ 321 FORMAT(/,20X,'THE EXTENDED THIN WIRE KERNEL WILL BE USED')
+ 303 FORMAT(/,' ERROR - ',A2,' CARD IS NOT ALLOWED WITH N.G.F.')
+ 327 FORMAT(/,35X,' LOADING ONLY IN N.G.F. SECTION')
+ 302 FORMAT(' ERROR - N.G.F. IN USE. CANNOT WRITE NEW N.G.F.')
+ 313 FORMAT(/,' NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE'
+ &,'DS LIMIT')
+ 390 FORMAT(' RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO'
+ &,'MMERFELD GROUND OPTION')
+ 391 FORMAT(40X,'FINITE GROUND. REFLECTION COEFFICIENT APPROXIMATION'
+ &)
+ 392 FORMAT(40X,'FINITE GROUND. SOMMERFELD SOLUTION')
+ 393 FORMAT(/,' ERROR IN GROUND PARAMETERS -',/,' COMPLEX DIELECTRIC',
+ &' CONSTANT FROM FILE IS',1P,2E12.5,/,32X,'REQUESTED',2E12.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE ARC( ITG, NS, RADA, ANG1, ANG2, RAD)
+C ***
+C
+C ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ DIMENSION X2(1), Y2(1), Z2(1)
+ EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
+ DATA TA/.01745329252D+0/
+ IST= N+1
+ N= N+ NS
+ NP= N
+ MP= M
+ IPSYM=0
+ IF( NS.LT.1) RETURN
+ IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1
+ WRITE (6,3)
+ STOP
+ 1 ANG= ANG1* TA
+ DANG=( ANG2- ANG1)* TA/ NS
+ XS1= RADA* COS( ANG)
+ ZS1= RADA* SIN( ANG)
+ DO 2 I= IST, N
+ ANG= ANG+ DANG
+ XS2= RADA* COS( ANG)
+ ZS2= RADA* SIN( ANG)
+ X( I)= XS1
+ Y( I)=0.
+ Z( I)= ZS1
+ X2( I)= XS2
+ Y2( I)=0.
+ Z2( I)= ZS2
+ XS1= XS2
+ ZS1= ZS2
+ BI( I)= RAD
+ 2 ITAG( I)= ITG
+C
+ RETURN
+ 3 FORMAT(' ERROR -- ARC ANGLE EXCEEDS 360. DEGREES')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ FUNCTION ATGN2( X, Y)
+C ***
+C
+C ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ IF( X) 3,1,3
+ 1 IF( Y) 3,2,3
+ 2 ATGN2=0.
+ RETURN
+ 3 ATGN2= ATAN2( X, Y)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE BLCKOT( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
+C ***
+C
+C BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES
+C FOR THE OUT-OF-CORE MATRIX SOLUTION.
+C
+ IMPLICIT REAL (A-H,O-Z)
+C LOGICAL ENF
+ COMPLEX AR
+ DIMENSION AR(1000)
+ I1=( IX1+1)/2
+ I2=( IX2+1)/2
+ 1 WRITE( NUNIT) ( AR( J), J= I1, I2)
+ RETURN
+ ENTRY BLCKIN( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
+ I1=( IX1+1)/2
+ I2=( IX2+1)/2
+ DO 2 I=1, NBLKS
+C IF (ENF(NUNIT)) GO TO 3
+ READ( NUNIT,END=3) ( AR( J), J= I1, I2)
+ 2 CONTINUE
+ RETURN
+ 3 WRITE (6,4) NUNIT, NBLKS, NEOF
+ IF( NEOF.NE.777) STOP
+ NEOF=0
+C
+ RETURN
+ 4 FORMAT(' EOF ON UNIT',I3,' NBLKS= ',I3,' NEOF= ',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CABC( CURX)
+C ***
+C
+C CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
+C COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
+C CURRENT VECTOR CUR.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ COMMON /ANGL/ SALP( NM)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ DIMENSION CURX(1), CCJX(2)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ EQUIVALENCE(CCJ,CCJX)
+ DATA TP/6.283185308D+0/, CCJX/0.,-0.01666666667D+0/
+ IF( N.EQ.0) GOTO 6
+ DO 1 I=1, N
+ AIR( I)=0.
+ AII( I)=0.
+ BIR( I)=0.
+ BII( I)=0.
+ CIR( I)=0.
+ 1 CII( I)=0.
+ DO 2 I=1, N
+ AR= REAL( CURX( I))
+ AI= AIMAG( CURX( I))
+ CALL TBF( I,1)
+ DO 2 JX=1, JSNO
+ J= JCO( JX)
+ AIR( J)= AIR( J)+ AX( JX)* AR
+ AII( J)= AII( J)+ AX( JX)* AI
+ BIR( J)= BIR( J)+ BX( JX)* AR
+ BII( J)= BII( J)+ BX( JX)* AI
+ CIR( J)= CIR( J)+ CX( JX)* AR
+ 2 CII( J)= CII( J)+ CX( JX)* AI
+ IF( NQDS.EQ.0) GOTO 4
+ DO 3 IS=1, NQDS
+ I= IQDS( IS)
+ JX= ICON1( I)
+ ICON1( I)=0
+ CALL TBF( I,0)
+ ICON1( I)= JX
+ SH= SI( I)*.5
+ CURD= CCJ* VQDS( IS)/(( LOG(2.* SH/ BI( I))-1.)*( BX( JSNO)* COS(
+ & TP* SH)+ CX( JSNO)* SIN( TP* SH))* WLAM)
+ AR= REAL( CURD)
+ AI= AIMAG( CURD)
+ DO 3 JX=1, JSNO
+ J= JCO( JX)
+ AIR( J)= AIR( J)+ AX( JX)* AR
+ AII( J)= AII( J)+ AX( JX)* AI
+ BIR( J)= BIR( J)+ BX( JX)* AR
+ BII( J)= BII( J)+ BX( JX)* AI
+ CIR( J)= CIR( J)+ CX( JX)* AR
+ 3 CII( J)= CII( J)+ CX( JX)* AI
+ 4 DO 5 I=1, N
+ 5 CURX( I)= CMPLX( AIR( I)+ CIR( I), AII( I)+ CII( I))
+C CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
+ 6 IF( M.EQ.0) RETURN
+ K= LD- M
+ JCO1= N+2* M+1
+ JCO2= JCO1+ M
+ DO 7 I=1, M
+ K= K+1
+ JCO1= JCO1-2
+ JCO2= JCO2-3
+ CS1= CURX( JCO1)
+ CS2= CURX( JCO1+1)
+ CURX( JCO2)= CS1* T1X( K)+ CS2* T2X( K)
+ CURX( JCO2+1)= CS1* T1Y( K)+ CS2* T2Y( K)
+ 7 CURX( JCO2+2)= CS1* T1Z( K)+ CS2* T2Z( K)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ FUNCTION CANG( Z)
+C ***
+C
+C CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX Z
+ CANG= ATGN2( AIMAG( Z), REAL( Z))*57.29577951D+0
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMNGF( CB, CC, CD, NB, NC, ND, RKHX, IEXKX)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CB, CC, CD, ZARRAY, EXK, EYK, EZK, EXS, EYS, EZS, EXC
+ &, EYC, EZC
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION CB( NB,1), CC( NC,1), CD( ND,1)
+ RKH= RKHX
+ IEXK= IEXKX
+ M1EQ=2* M1
+ M2EQ= M1EQ+1
+ MEQ=2* M
+ NEQP= ND- NPCON*2
+ NEQS= NEQP- NSCON
+ NEQSP= NEQS+ NC
+ NEQN= NC+ N- N1
+ ITX=1
+ IF( NSCON.GT.0) ITX=2
+ IF( ICASX.EQ.1) GOTO 1
+ REWIND 12
+ REWIND 14
+ REWIND 15
+ IF( ICASX.GT.2) GOTO 5
+ 1 DO 4 J=1, ND
+ DO 2 I=1, ND
+ 2 CD( I, J)=(0.,0.)
+ DO 3 I=1, NB
+ CB( I, J)=(0.,0.)
+ 3 CC( I, J)=(0.,0.)
+ 4 CONTINUE
+ 5 IST= N- N1+1
+ IT= NPBX
+C LOOP THRU 24 FILLS B. FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS)
+ ISV=- NPBX
+ DO 24 IBLK=1, NBBX
+ ISV= ISV+ NPBX
+ IF( IBLK.EQ. NBBX) IT= NLBX
+ IF( ICASX.LT.3) GOTO 7
+ DO 6 J=1, ND
+ DO 6 I=1, IT
+ 6 CB( I, J)=(0.,0.)
+ 7 I1= ISV+1
+ I2= ISV+ IT
+ IN2= I2
+ IF( IN2.GT. N1) IN2= N1
+ IM1= I1- N1
+ IM2= I2- N1
+ IF( IM1.LT.1) IM1=1
+ IMX=1
+ IF( I1.LE. N1) IMX= N1- I1+2
+C FILL B(WW),B(WS). FOR ICASX=1,2 FILL D(WW),D(WS)
+ IF( N2.GT. N) GOTO 12
+ DO 11 J= N2, N
+ CALL TRIO( J)
+ DO 9 I=1, JSNO
+ JSS= JCO( I)
+C SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT
+ IF( JSS.LT. N2) GOTO 8
+ JCO( I)= JSS- N1
+C SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT
+ GOTO 9
+ 8 JCO( I)= NEQS+ ICONX( JSS)
+ 9 CONTINUE
+ IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
+ IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
+ &)
+ IF( ICASX.GT.2) GOTO 11
+ CALL CMWW( J, N2, N, CD, ND, CD, ND,1)
+C LOADING IN D(WW)
+ IF( M2.LE. M) CALL CMWS( J, M2EQ, MEQ, CD(1, IST), ND, CD, ND,1)
+ IF( NLOAD.EQ.0) GOTO 11
+ IR= J- N1
+ EXK= ZARRAY( J)
+ DO 10 I=1, JSNO
+ JSS= JCO( I)
+ 10 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
+ 11 CONTINUE
+C FILL B(WW)PRIME
+ 12 IF( NSCON.EQ.0) GOTO 20
+ DO 19 I=1, NSCON
+C SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICH
+C CONNECT TO NEW SEGMENTS
+ J= ISCON( I)
+ CALL TRIO( J)
+ JSS=0
+ DO 15 IX=1, JSNO
+ IR= JCO( IX)
+ IF( IR.LT. N2) GOTO 13
+ IR= IR- N1
+ GOTO 14
+ 13 IR= ICONX( IR)
+ IF( IR.EQ.0) GOTO 15
+ IR= NEQS+ IR
+ 14 JSS= JSS+1
+ JCO( JSS)= IR
+ AX( JSS)= AX( IX)
+ BX( JSS)= BX( IX)
+ CX( JSS)= CX( IX)
+ 15 CONTINUE
+ JSNO= JSS
+ IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
+C SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OF
+C MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEW
+C SEGMENT ON END OPPOSITE PATCH.
+ IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
+ &)
+ IF( I1.LE. IN2) CALL CMSW( J, I, I1, IN2, CB, CB,0, NB,-1)
+ IF( NLODF.EQ.0) GOTO 17
+ JX= J- ISV
+ IF( JX.LT.1.OR. JX.GT. IT) GOTO 17
+ EXK= ZARRAY( J)
+ DO 16 IX=1, JSNO
+ JSS= JCO( IX)
+C SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTS
+C EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS.
+ 16 CB( JX, JSS)= CB( JX, JSS)-( AX( IX)+ CX( IX))* EXK
+ 17 CALL TBF( J,1)
+ JSX= JSNO
+ JSNO=1
+ IR= JCO(1)
+ JCO(1)= NEQS+ I
+ DO 19 IX=1, JSX
+ IF( IX.EQ.1) GOTO 18
+ IR= JCO( IX)
+ AX(1)= AX( IX)
+ BX(1)= BX( IX)
+ CX(1)= CX( IX)
+ 18 IF( IR.GT. N1) GOTO 19
+ IF( ICONX( IR).NE.0) GOTO 19
+ IF( I1.LE. IN2) CALL CMWW( IR, I1, IN2, CB, NB, CB, NB,0)
+C LOADING FOR B(WW)PRIME
+ IF( IM1.LE. IM2) CALL CMWS( IR, IM1, IM2, CB( IMX,1), NB, CB, NB,
+ &0)
+ IF( NLODF.EQ.0) GOTO 19
+ JX= IR- ISV
+ IF( JX.LT.1.OR. JX.GT. IT) GOTO 19
+ EXK= ZARRAY( IR)
+ JSS= JCO(1)
+ CB( JX, JSS)= CB( JX, JSS)-( AX(1)+ CX(1))* EXK
+ 19 CONTINUE
+ 20 IF( NPCON.EQ.0) GOTO 22
+C FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR
+C PATCHES THAT CONNECT TO NEW SEGMENTS
+ JSS= NEQP
+ DO 21 I=1, NPCON
+ IX= IPCON( I)*2+ N1- ISV
+ IR= IX-1
+ JSS= JSS+1
+ IF( IR.GT.0.AND. IR.LE. IT) CB( IR, JSS)=(1.,0.)
+ JSS= JSS+1
+ IF( IX.GT.0.AND. IX.LE. IT) CB( IX, JSS)=(1.,0.)
+ 21 CONTINUE
+C FILL B(SW) AND B(SS)
+ 22 IF( M2.GT. M) GOTO 23
+ IF( I1.LE. IN2) CALL CMSW( M2, M, I1, IN2, CB(1, IST), CB, N1, NB
+ &,0)
+ IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CB( IMX, IST), NB,0)
+ &
+ 23 IF( ICASX.EQ.1) GOTO 24
+ WRITE( 14) (( CB( I, J), I=1, IT), J=1, ND)
+C FILLING B COMPLETE. START ON C AND D
+ 24 CONTINUE
+ IT= NPBL
+ ISV=- NPBL
+ DO 43 IBLK=1, NBBL
+ ISV= ISV+ NPBL
+ ISVV= ISV+ NC
+ IF( IBLK.EQ. NBBL) IT= NLBL
+ IF( ICASX.LT.3) GOTO 27
+ DO 26 J=1, IT
+ DO 25 I=1, NC
+ 25 CC( I, J)=(0.,0.)
+ DO 26 I=1, ND
+ 26 CD( I, J)=(0.,0.)
+ 27 I1= ISVV+1
+ I2= ISVV+ IT
+ IN1= I1- M1EQ
+ IN2= I2- M1EQ
+ IF( IN2.GT. N) IN2= N
+ IM1= I1- N
+ IM2= I2- N
+ IF( IM1.LT. M2EQ) IM1= M2EQ
+ IF( IM2.GT. MEQ) IM2= MEQ
+ IMX=1
+ IF( IN1.LE. IN2) IMX= NEQN- I1+2
+ IF( ICASX.LT.3) GOTO 32
+C SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2
+ IF( N2.GT. N) GOTO 32
+ DO 31 J= N2, N
+ CALL TRIO( J)
+ DO 29 I=1, JSNO
+ JSS= JCO( I)
+ IF( JSS.LT. N2) GOTO 28
+ JCO( I)= JSS- N1
+ GOTO 29
+ 28 JCO( I)= NEQS+ ICONX( JSS)
+ 29 CONTINUE
+ IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CD, ND, CD, ND,1)
+ IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CD(1, IMX), ND, CD, ND,1
+ &)
+ IF( NLOAD.EQ.0) GOTO 31
+ IR= J- N1- ISV
+ IF( IR.LT.1.OR. IR.GT. IT) GOTO 31
+ EXK= ZARRAY( J)
+ DO 30 I=1, JSNO
+ JSS= JCO( I)
+ 30 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
+ 31 CONTINUE
+C FILL D(SW) AND D(SS)
+ 32 IF( M2.GT. M) GOTO 33
+ IF( IN1.LE. IN2) CALL CMSW( M2, M, IN1, IN2, CD( IST,1), CD, N1,
+ &ND,1)
+ IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CD( IST, IMX), ND,1)
+ &
+C FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME.
+ 33 IF( N1.LT.1) GOTO 39
+ DO 37 J=1, N1
+ CALL TRIO( J)
+ IF( NSCON.EQ.0) GOTO 36
+ DO 35 IX=1, JSNO
+ JSS= JCO( IX)
+ IF( JSS.LT. N2) GOTO 34
+ JCO( IX)= JSS+ M1EQ
+ GOTO 35
+ 34 IR= ICONX( JSS)
+ IF( IR.NE.0) JCO( IX)= NEQSP+ IR
+ 35 CONTINUE
+ 36 IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CC, NC, CD, ND, ITX)
+ IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CC(1, IMX), NC, CD(1,
+ &IMX), ND, ITX)
+ 37 CONTINUE
+C FILL C(WW)PRIME
+ IF( NSCON.EQ.0) GOTO 39
+ DO 38 IX=1, NSCON
+ IR= ISCON( IX)
+ JSS= NEQS+ IX- ISV
+ IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
+ 38 CONTINUE
+ 39 IF( NPCON.EQ.0) GOTO 41
+C FILL C(SS)PRIME
+ JSS= NEQP- ISV
+ DO 40 I=1, NPCON
+ IX= IPCON( I)*2+ N1
+ IR= IX-1
+ JSS= JSS+1
+ IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
+ JSS= JSS+1
+ IF( JSS.GT.0.AND. JSS.LE. IT) CC( IX, JSS)=(1.,0.)
+ 40 CONTINUE
+C FILL C(SW) AND C(SS)
+ 41 IF( M1.LT.1) GOTO 42
+ IF( IN1.LE. IN2) CALL CMSW(1, M1, IN1, IN2, CC( N2,1), CC,0, NC,1
+ &)
+ IF( IM1.LE. IM2) CALL CMSS(1, M1, IM1, IM2, CC( N2, IMX), NC,1)
+ 42 CONTINUE
+ IF( ICASX.EQ.1) GOTO 43
+ WRITE( 12) (( CD( J, I), J=1, ND), I=1, IT)
+ WRITE( 15) (( CC( J, I), J=1, NC), I=1, IT)
+ 43 CONTINUE
+ IF( ICASX.EQ.1) RETURN
+ REWIND 12
+ REWIND 14
+ REWIND 15
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMSET( NROW, CM, RKHX, IEXKX)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM
+C
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CM, ZARRAY, ZAJ, EXK, EYK, EZK, EXS,
+ &EYS, EZS, EXC, EYC, EZC, SSX, D, DETER
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SMAT/ SSX(16,16)
+ COMMON /SCRATM/ D( N2M)
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ DIMENSION CM( NROW,1)
+ MP2=2* MP
+ NPEQ= NP+ MP2
+ NEQ= N+2* M
+ NOP= NEQ/ NPEQ
+ IF( ICASE.GT.2) REWIND 11
+ RKH= RKHX
+ IEXK= IEXKX
+ IOUT=2* NPBLK* NROW
+C
+C CYCLE OVER MATRIX BLOCKS
+C
+ IT= NPBLK
+ DO 13 IXBLK1=1, NBLOKS
+ ISV=( IXBLK1-1)* NPBLK
+ IF( IXBLK1.EQ. NBLOKS) IT= NLAST
+ DO 1 I=1, NROW
+ DO 1 J=1, IT
+ 1 CM( I, J)=(0.,0.)
+ I1= ISV+1
+ I2= ISV+ IT
+ IN2= I2
+ IF( IN2.GT. NP) IN2= NP
+ IM1= I1- NP
+ IM2= I2- NP
+ IF( IM1.LT.1) IM1=1
+ IST=1
+ IF( I1.LE. NP) IST= NP- I1+2
+C
+C WIRE SOURCE LOOP
+C
+ IF( N.EQ.0) GOTO 5
+ DO 4 J=1, N
+ CALL TRIO( J)
+ DO 2 I=1, JSNO
+ IJ= JCO( I)
+ 2 JCO( I)=(( IJ-1)/ NP)* MP2+ IJ
+ IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CM, NROW, CM, NROW,1)
+ IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CM(1, IST), NROW, CM,
+ &NROW,1)
+C
+C MATRIX ELEMENTS MODIFIED BY LOADING
+C
+ IF( NLOAD.EQ.0) GOTO 4
+ IF( J.GT. NP) GOTO 4
+ IPR= J- ISV
+ IF( IPR.LT.1.OR. IPR.GT. IT) GOTO 4
+ ZAJ= ZARRAY( J)
+ DO 3 I=1, JSNO
+ JSS= JCO( I)
+ 3 CM( JSS, IPR)= CM( JSS, IPR)-( AX( I)+ CX( I))* ZAJ
+ 4 CONTINUE
+C MATRIX ELEMENTS FOR PATCH CURRENT SOURCES
+ 5 IF( M.EQ.0) GOTO 7
+ JM1=1- MP
+ JM2=0
+ JST=1- MP2
+ DO 6 I=1, NOP
+ JM1= JM1+ MP
+ JM2= JM2+ MP
+ JST= JST+ NPEQ
+ IF( I1.LE. IN2) CALL CMSW( JM1, JM2, I1, IN2, CM( JST,1), CM,0,
+ &NROW,1)
+ IF( IM1.LE. IM2) CALL CMSS( JM1, JM2, IM1, IM2, CM( JST, IST),
+ &NROW,1)
+ 6 CONTINUE
+ 7 IF( ICASE.EQ.1) GOTO 13
+C COMBINE ELEMENTS FOR SYMMETRY MODES
+ IF( ICASE.EQ.3) GOTO 12
+ DO 11 I=1, IT
+ DO 11 J=1, NPEQ
+ DO 8 K=1, NOP
+ KA= J+( K-1)* NPEQ
+ 8 D( K)= CM( KA, I)
+ DETER= D(1)
+ DO 9 KK=2, NOP
+ 9 DETER= DETER+ D( KK)
+ CM( J, I)= DETER
+ DO 11 K=2, NOP
+ KA= J+( K-1)* NPEQ
+ DETER= D(1)
+ DO 10 KK=2, NOP
+ 10 DETER= DETER+ D( KK)* SSX( K, KK)
+ CM( KA, I)= DETER
+ 11 CONTINUE
+C WRITE BLOCK FOR OUT-OF-CORE CASES.
+ IF( ICASE.LT.3) GOTO 13
+ 12 CALL BLCKOT( CM,11,1, IOUT,1,31)
+ 13 CONTINUE
+ IF( ICASE.GT.2) REWIND 11
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMSS( J1, J2, IM1, IM2, CM, NROW, ITRP)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX G11, G12, G21, G22, CM, EXK, EYK, EZK, EXS, EYS, EZS,
+ & EXC, EYC, EZC
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ DIMENSION CM( NROW,1)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ LDP= LD+1
+ I1=( IM1+1)/2
+ I2=( IM2+1)/2
+ ICOMP= I1*2-3
+ II1=-1
+C LOOP OVER OBSERVATION PATCHES
+ IF( ICOMP+2.LT. IM1) II1=-2
+ DO 5 I= I1, I2
+ IL= LDP- I
+ ICOMP= ICOMP+2
+ II1= II1+2
+ II2= II1+1
+ T1XI= T1X( IL)* SALP( IL)
+ T1YI= T1Y( IL)* SALP( IL)
+ T1ZI= T1Z( IL)* SALP( IL)
+ T2XI= T2X( IL)* SALP( IL)
+ T2YI= T2Y( IL)* SALP( IL)
+ T2ZI= T2Z( IL)* SALP( IL)
+ XI= X( IL)
+ YI= Y( IL)
+ ZI= Z( IL)
+C LOOP OVER SOURCE PATCHES
+ JJ1=-1
+ DO 5 J= J1, J2
+ JL= LDP- J
+ JJ1= JJ1+2
+ JJ2= JJ1+1
+ S= BI( JL)
+ XJ= X( JL)
+ YJ= Y( JL)
+ ZJ= Z( JL)
+ T1XJ= T1X( JL)
+ T1YJ= T1Y( JL)
+ T1ZJ= T1Z( JL)
+ T2XJ= T2X( JL)
+ T2YJ= T2Y( JL)
+ T2ZJ= T2Z( JL)
+ CALL HINTG( XI, YI, ZI)
+ G11=-( T2XI* EXK+ T2YI* EYK+ T2ZI* EZK)
+ G12=-( T2XI* EXS+ T2YI* EYS+ T2ZI* EZS)
+ G21=-( T1XI* EXK+ T1YI* EYK+ T1ZI* EZK)
+ G22=-( T1XI* EXS+ T1YI* EYS+ T1ZI* EZS)
+ IF( I.NE. J) GOTO 1
+ G11= G11-.5
+ G22= G22+.5
+C NORMAL FILL
+ 1 IF( ITRP.NE.0) GOTO 3
+ IF( ICOMP.LT. IM1) GOTO 2
+ CM( II1, JJ1)= G11
+ CM( II1, JJ2)= G12
+ 2 IF( ICOMP.GE. IM2) GOTO 5
+ CM( II2, JJ1)= G21
+ CM( II2, JJ2)= G22
+C TRANSPOSED FILL
+ GOTO 5
+ 3 IF( ICOMP.LT. IM1) GOTO 4
+ CM( JJ1, II1)= G11
+ CM( JJ2, II1)= G12
+ 4 IF( ICOMP.GE. IM2) GOTO 5
+ CM( JJ1, II2)= G21
+ CM( JJ2, II2)= G22
+ 5 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMSW( J1, J2, I1, I2, CM, CW, NCW, NROW, ITRP)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CM, ZRATI, ZRATI2, T1, EXK, EYK, EZK, EXS, EYS, EZS,
+ &EXC, EYC, EZC, EMEL, CW, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ DIMENSION CAB(1), SAB(1), CM( NROW,1), CW( NROW,1)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), EMEL(9
+ &)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG),(CAB,ALP),(SAB,BET)
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ DATA PI/3.141592654D+0/
+ LDP= LD+1
+ NEQS= N- N1+2*( M- M1)
+ IF( ITRP.LT.0) GOTO 13
+ K=0
+C OBSERVATION LOOP
+ ICGO=1
+ DO 12 I= I1, I2
+ K= K+1
+ XI= X( I)
+ YI= Y( I)
+ ZI= Z( I)
+ CABI= CAB( I)
+ SABI= SAB( I)
+ SALPI= SALP( I)
+ IPCH=0
+ IF( ICON1( I).LT.10000) GOTO 1
+ IPCH= ICON1( I)-10000
+ FSIGN=-1.
+ 1 IF( ICON2( I).LT.10000) GOTO 2
+ IPCH= ICON2( I)-10000
+ FSIGN=1.
+C SOURCE LOOP
+ 2 JL=0
+ DO 12 J= J1, J2
+ JS= LDP- J
+ JL= JL+2
+ T1XJ= T1X( JS)
+ T1YJ= T1Y( JS)
+ T1ZJ= T1Z( JS)
+ T2XJ= T2X( JS)
+ T2YJ= T2Y( JS)
+ T2ZJ= T2Z( JS)
+ XJ= X( JS)
+ YJ= Y( JS)
+ ZJ= Z( JS)
+C GROUND LOOP
+ S= BI( JS)
+ DO 12 IP=1, KSYMP
+ IPGND= IP
+ IF( IPCH.NE. J.AND. ICGO.EQ.1) GOTO 9
+ IF( IP.EQ.2) GOTO 9
+ IF( ICGO.GT.1) GOTO 6
+ CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
+ PY= PI* SI( I)* FSIGN
+ PX= SIN( PY)
+ PY= COS( PY)
+ EXC= EMEL(9)* FSIGN
+ CALL TRIO( I)
+ IF( I.GT. N1) GOTO 3
+ IL= NEQS+ ICONX( I)
+ GOTO 4
+ 3 IL= I- NCW
+ IF( I.LE. NP) IL=(( IL-1)/ NP)*2* MP+ IL
+ 4 IF( ITRP.NE.0) GOTO 5
+ CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
+ &* PY)
+ GOTO 6
+ 5 CW( IL, K)= CW( IL, K)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
+ &* PY)
+ 6 IF( ITRP.NE.0) GOTO 7
+ CM( K, JL-1)= EMEL( ICGO)
+ CM( K, JL)= EMEL( ICGO+4)
+ GOTO 8
+ 7 CM( JL-1, K)= EMEL( ICGO)
+ CM( JL, K)= EMEL( ICGO+4)
+ 8 ICGO= ICGO+1
+ IF( ICGO.EQ.5) ICGO=1
+ GOTO 11
+ 9 CALL UNERE( XI, YI, ZI)
+C NORMAL FILL
+ IF( ITRP.NE.0) GOTO 10
+ CM( K, JL-1)= CM( K, JL-1)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
+ CM( K, JL)= CM( K, JL)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
+C TRANSPOSED FILL
+ GOTO 11
+ 10 CM( JL-1, K)= CM( JL-1, K)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
+ CM( JL, K)= CM( JL, K)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
+ 11 CONTINUE
+ 12 CONTINUE
+C FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON
+C OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY
+ RETURN
+ 13 IF( J1.LT. I1.OR. J1.GT. I2) GOTO 16
+ IPCH= ICON1( J1)
+ IF( IPCH.LT.10000) GOTO 14
+ IPCH= IPCH-10000
+ FSIGN=-1.
+ GOTO 15
+ 14 IPCH= ICON2( J1)
+ IF( IPCH.LT.10000) GOTO 16
+ IPCH= IPCH-10000
+ FSIGN=1.
+ 15 IF( IPCH.GT. M1) GOTO 16
+ JS= LDP- IPCH
+ IPGND=1
+ T1XJ= T1X( JS)
+ T1YJ= T1Y( JS)
+ T1ZJ= T1Z( JS)
+ T2XJ= T2X( JS)
+ T2YJ= T2Y( JS)
+ T2ZJ= T2Z( JS)
+ XJ= X( JS)
+ YJ= Y( JS)
+ ZJ= Z( JS)
+ S= BI( JS)
+ XI= X( J1)
+ YI= Y( J1)
+ ZI= Z( J1)
+ CABI= CAB( J1)
+ SABI= SAB( J1)
+ SALPI= SALP( J1)
+ CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
+ PY= PI* SI( J1)* FSIGN
+ PX= SIN( PY)
+ PY= COS( PY)
+ EXC= EMEL(9)* FSIGN
+ IL= JCO( JSNO)
+ K= J1- I1+1
+ CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
+ &* PY)
+ 16 RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMWS( J, I1, I2, CM, NR, CW, NW, ITRP)
+C ***
+C
+C CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
+ &EXC, EYC, EZC
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ DIMENSION CM( NR,1), CW( NW,1), CAB(1), SAB(1)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ EQUIVALENCE(CAB,ALP),(SAB,BET),(T1X,SI),(T1Y,ALP),(T1Z,BET)
+ EQUIVALENCE(T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
+ LDP= LD+1
+ S= SI( J)
+ B= BI( J)
+ XJ= X( J)
+ YJ= Y( J)
+ ZJ= Z( J)
+ CABJ= CAB( J)
+ SABJ= SAB( J)
+C
+C OBSERVATION LOOP
+C
+ SALPJ= SALP( J)
+ IPR=0
+ DO 9 I= I1, I2
+ IPR= IPR+1
+ IPATCH=( I+1)/2
+ IK= I-( I/2)*2
+ IF( IK.EQ.0.AND. IPR.NE.1) GOTO 1
+ JS= LDP- IPATCH
+ XI= X( JS)
+ YI= Y( JS)
+ ZI= Z( JS)
+ CALL HSFLD( XI, YI, ZI,0.)
+ IF( IK.EQ.0) GOTO 1
+ TX= T2X( JS)
+ TY= T2Y( JS)
+ TZ= T2Z( JS)
+ GOTO 2
+ 1 TX= T1X( JS)
+ TY= T1Y( JS)
+ TZ= T1Z( JS)
+ 2 ETK=-( EXK* TX+ EYK* TY+ EZK* TZ)* SALP( JS)
+ ETS=-( EXS* TX+ EYS* TY+ EZS* TZ)* SALP( JS)
+C
+C FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTION
+C DATA.
+C
+ ETC=-( EXC* TX+ EYC* TY+ EZC* TZ)* SALP( JS)
+C NORMAL FILL
+ IF( ITRP.NE.0) GOTO 4
+ DO 3 IJ=1, JSNO
+ JX= JCO( IJ)
+ 3 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ GOTO 9
+C TRANSPOSED FILL
+ 4 IF( ITRP.EQ.2) GOTO 6
+ DO 5 IJ=1, JSNO
+ JX= JCO( IJ)
+ 5 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+C TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW)
+ GOTO 9
+ 6 DO 8 IJ=1, JSNO
+ JX= JCO( IJ)
+ IF( JX.GT. NR) GOTO 7
+ CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ GOTO 8
+ 7 JX= JX- NR
+ CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ 8 CONTINUE
+ 9 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CMWW( J, I1, I2, CM, NR, CW, NW, ITRP)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS
+C
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
+ &EXC, EYC, EZC
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ DIMENSION CM( NR,1), CW( NW,1), CAB(1), SAB(1)
+C SET SOURCE SEGMENT PARAMETERS
+ EQUIVALENCE(CAB,ALP),(SAB,BET)
+ S= SI( J)
+ B= BI( J)
+ XJ= X( J)
+ YJ= Y( J)
+ ZJ= Z( J)
+ CABJ= CAB( J)
+ SABJ= SAB( J)
+ SALPJ= SALP( J)
+C DECIDE WETHER EXT. T.W. APPROX. CAN BE USED
+ IF( IEXK.EQ.0) GOTO 16
+ IPR= ICON1( J)
+ IF( IPR) 1,6,2
+ 1 IPR=- IPR
+ IF(- ICON1( IPR).NE. J) GOTO 7
+ GOTO 4
+ 2 IF( IPR.NE. J) GOTO 3
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
+ GOTO 5
+ 3 IF( ICON2( IPR).NE. J) GOTO 7
+ 4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 7
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
+ 5 IND1=0
+ GOTO 8
+ 6 IND1=1
+ GOTO 8
+ 7 IND1=2
+ 8 IPR= ICON2( J)
+ IF( IPR) 9,14,10
+ 9 IPR=- IPR
+ IF(- ICON2( IPR).NE. J) GOTO 15
+ GOTO 12
+ 10 IF( IPR.NE. J) GOTO 11
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
+ GOTO 13
+ 11 IF( ICON1( IPR).NE. J) GOTO 15
+ 12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 15
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
+ 13 IND2=0
+ GOTO 16
+ 14 IND2=1
+ GOTO 16
+ 15 IND2=2
+C
+C OBSERVATION LOOP
+C
+ 16 CONTINUE
+ IPR=0
+ DO 23 I= I1, I2
+ IPR= IPR+1
+ IJ= I- J
+ XI= X( I)
+ YI= Y( I)
+ ZI= Z( I)
+ AI= BI( I)
+ CABI= CAB( I)
+ SABI= SAB( I)
+ SALPI= SALP( I)
+ CALL EFLD( XI, YI, ZI, AI, IJ)
+ ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
+ ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
+C
+C FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTION
+C DATA.
+C
+ ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
+C NORMAL FILL
+ IF( ITRP.NE.0) GOTO 18
+ DO 17 IJ=1, JSNO
+ JX= JCO( IJ)
+ 17 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ GOTO 23
+C TRANSPOSED FILL
+ 18 IF( ITRP.EQ.2) GOTO 20
+ DO 19 IJ=1, JSNO
+ JX= JCO( IJ)
+ 19 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+C TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME. (=CW)
+ GOTO 23
+ 20 DO 22 IJ=1, JSNO
+ JX= JCO( IJ)
+ IF( JX.GT. NR) GOTO 21
+ CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ GOTO 22
+ 21 JX= JX- NR
+ CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
+ &IJ)
+ 22 CONTINUE
+ 23 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE CONECT( IGND)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
+C BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.
+C
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ DIMENSION X2(1), Y2(1), Z2(1)
+ EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
+ DATA JMAX/30/, SMIN/1.D-3/, NSMAX/50/, NPMAX/10/
+ NSCON=0
+ NPCON=0
+ IF( IGND.EQ.0) GOTO 3
+ WRITE (6,54)
+ IF( IGND.GT.0) WRITE (6,55)
+ IF( IPSYM.NE.2) GOTO 1
+ NP=2* NP
+ MP=2* MP
+ 1 IF( IABS( IPSYM).LE.2) GOTO 2
+ NP= N
+ MP= M
+ 2 IF( NP.GT. N) STOP
+ IF( NP.EQ. N.AND. MP.EQ. M) IPSYM=0
+ 3 IF( N.EQ.0) GOTO 26
+ DO 15 I=1, N
+ ICONX( I)=0
+ XI1= X( I)
+ YI1= Y( I)
+ ZI1= Z( I)
+ XI2= X2( I)
+ YI2= Y2( I)
+ ZI2= Z2( I)
+C
+C DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.
+C
+ SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN
+ IF( IGND.LT.1) GOTO 5
+ IF( ZI1.GT.- SLEN) GOTO 4
+ WRITE (6,56) I
+ STOP
+ 4 IF( ZI1.GT. SLEN) GOTO 5
+ ICON1( I)= I
+ Z( I)=0.
+ GOTO 9
+ 5 IC= I
+ DO 7 J=2, N
+ IC= IC+1
+ IF( IC.GT. N) IC=1
+ SEP= ABS( XI1- X( IC))+ ABS( YI1- Y( IC))+ ABS( ZI1- Z( IC))
+ IF( SEP.GT. SLEN) GOTO 6
+ ICON1( I)=- IC
+ GOTO 8
+ 6 SEP= ABS( XI1- X2( IC))+ ABS( YI1- Y2( IC))+ ABS( ZI1- Z2( IC))
+ IF( SEP.GT. SLEN) GOTO 7
+ ICON1( I)= IC
+ GOTO 8
+ 7 CONTINUE
+ IF( I.LT. N2.AND. ICON1( I).GT.10000) GOTO 8
+C
+C DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.
+C
+ ICON1( I)=0
+ 8 IF( IGND.LT.1) GOTO 12
+ 9 IF( ZI2.GT.- SLEN) GOTO 10
+ WRITE (6,56) I
+ STOP
+ 10 IF( ZI2.GT. SLEN) GOTO 12
+ IF( ICON1( I).NE. I) GOTO 11
+ WRITE (6,57) I
+ STOP
+ 11 ICON2( I)= I
+ Z2( I)=0.
+ GOTO 15
+ 12 IC= I
+ DO 14 J=2, N
+ IC= IC+1
+ IF( IC.GT. N) IC=1
+ SEP= ABS( XI2- X( IC))+ ABS( YI2- Y( IC))+ ABS( ZI2- Z( IC))
+ IF( SEP.GT. SLEN) GOTO 13
+ ICON2( I)= IC
+ GOTO 15
+ 13 SEP= ABS( XI2- X2( IC))+ ABS( YI2- Y2( IC))+ ABS( ZI2- Z2( IC))
+ IF( SEP.GT. SLEN) GOTO 14
+ ICON2( I)=- IC
+ GOTO 15
+ 14 CONTINUE
+ IF( I.LT. N2.AND. ICON2( I).GT.10000) GOTO 15
+ ICON2( I)=0
+ 15 CONTINUE
+C FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES
+ IF( M.EQ.0) GOTO 26
+ IX= LD+1- M1
+ I= M2
+ 16 IF( I.GT. M) GOTO 20
+ IX= IX-1
+ XS= X( IX)
+ YS= Y( IX)
+ ZS= Z( IX)
+ DO 18 ISEG=1, N
+ XI1= X( ISEG)
+ YI1= Y( ISEG)
+ ZI1= Z( ISEG)
+ XI2= X2( ISEG)
+ YI2= Y2( ISEG)
+ ZI2= Z2( ISEG)
+C FOR FIRST END OF SEGMENT
+ SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
+ SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
+C CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.
+ IF( SEP.GT. SLEN) GOTO 17
+ ICON1( ISEG)=10000+ I
+ IC=0
+ CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
+ &YS, ZS)
+ GOTO 19
+ 17 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
+ IF( SEP.GT. SLEN) GOTO 18
+ ICON2( ISEG)=10000+ I
+ IC=0
+ CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
+ &YS, ZS)
+ GOTO 19
+ 18 CONTINUE
+ 19 I= I+1
+C REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.
+ GOTO 16
+ 20 IF( M1.EQ.0.OR. N2.GT. N) GOTO 26
+ IX= LD+1
+ I=1
+ 21 IF( I.GT. M1) GOTO 25
+ IX= IX-1
+ XS= X( IX)
+ YS= Y( IX)
+ ZS= Z( IX)
+ DO 23 ISEG= N2, N
+ XI1= X( ISEG)
+ YI1= Y( ISEG)
+ ZI1= Z( ISEG)
+ XI2= X2( ISEG)
+ YI2= Y2( ISEG)
+ ZI2= Z2( ISEG)
+ SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
+ SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
+ IF( SEP.GT. SLEN) GOTO 22
+ ICON1( ISEG)=10001+ M
+ IC=1
+ NPCON= NPCON+1
+ IPCON( NPCON)= I
+ CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
+ &YS, ZS)
+ GOTO 24
+ 22 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
+ IF( SEP.GT. SLEN) GOTO 23
+ ICON2( ISEG)=10001+ M
+ IC=1
+ NPCON= NPCON+1
+ IPCON( NPCON)= I
+ CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
+ &YS, ZS)
+ GOTO 24
+ 23 CONTINUE
+ 24 I= I+1
+ GOTO 21
+ 25 IF( NPCON.LE. NPMAX) GOTO 26
+ WRITE (6,62) NPMAX
+ STOP
+ 26 WRITE (6,58) N, NP, IPSYM
+ IF( M.GT.0) WRITE (6,61) M, MP
+ ISEG=( N+ M)/( NP+ MP)
+ IF( ISEG.EQ.1) GOTO 30
+ IF( IPSYM) 28,27,29
+ 27 STOP
+ 28 WRITE (6,59) ISEG
+ GOTO 30
+ 29 IC= ISEG/2
+ IF( ISEG.EQ.8) IC=3
+ WRITE (6,60) IC
+ 30 IF( N.EQ.0) GOTO 48
+ WRITE (6,50)
+C ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE. PRINT JUNCTIONS
+C OF 3 OR MORE SEG. ALSO FIND OLD SEG. CONNECTING TO NEW SEG.
+ ISEG=0
+ DO 44 J=1, N
+ IEND=-1
+ JEND=-1
+ IX= ICON1( J)
+ IC=1
+ JCO(1)=- J
+ XA= X( J)
+ YA= Y( J)
+ ZA= Z( J)
+ 31 IF( IX.EQ.0) GOTO 43
+ IF( IX.EQ. J) GOTO 43
+ IF( IX.GT.10000) GOTO 43
+ NSFLG=0
+ 32 IF( IX) 33,49,34
+ 33 IX=- IX
+ GOTO 35
+ 34 JEND=- JEND
+ 35 IF( IX.EQ. J) GOTO 37
+ IF( IX.LT. J) GOTO 43
+ IC= IC+1
+ IF( IC.GT. JMAX) GOTO 49
+ JCO( IC)= IX* JEND
+ IF( IX.GT. N1) NSFLG=1
+ IF( JEND.EQ.1) GOTO 36
+ XA= XA+ X( IX)
+ YA= YA+ Y( IX)
+ ZA= ZA+ Z( IX)
+ IX= ICON1( IX)
+ GOTO 32
+ 36 XA= XA+ X2( IX)
+ YA= YA+ Y2( IX)
+ ZA= ZA+ Z2( IX)
+ IX= ICON2( IX)
+ GOTO 32
+ 37 SEP= IC
+ XA= XA/ SEP
+ YA= YA/ SEP
+ ZA= ZA/ SEP
+ DO 39 I=1, IC
+ IX= JCO( I)
+ IF( IX.GT.0) GOTO 38
+ IX=- IX
+ X( IX)= XA
+ Y( IX)= YA
+ Z( IX)= ZA
+ GOTO 39
+ 38 X2( IX)= XA
+ Y2( IX)= YA
+ Z2( IX)= ZA
+ 39 CONTINUE
+ IF( N1.EQ.0) GOTO 42
+ IF( NSFLG.EQ.0) GOTO 42
+ DO 41 I=1, IC
+ IX= IABS( JCO( I))
+ IF( IX.GT. N1) GOTO 41
+ IF( ICONX( IX).NE.0) GOTO 41
+ NSCON= NSCON+1
+ IF( NSCON.LE. NSMAX) GOTO 40
+ WRITE (6,62) NSMAX
+ STOP
+ 40 ISCON( NSCON)= IX
+ ICONX( IX)= NSCON
+ 41 CONTINUE
+ 42 IF( IC.LT.3) GOTO 43
+ ISEG= ISEG+1
+ WRITE (6,51) ISEG,( JCO( I), I=1, IC)
+ 43 IF( IEND.EQ.1) GOTO 44
+ IEND=1
+ JEND=1
+ IX= ICON2( J)
+ IC=1
+ JCO(1)= J
+ XA= X2( J)
+ YA= Y2( J)
+ ZA= Z2( J)
+ GOTO 31
+ 44 CONTINUE
+ IF( ISEG.EQ.0) WRITE (6,52)
+C FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES
+ IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48
+ DO 47 J=1, N1
+ IX= ICON1( J)
+ IF( IX.LT.10000) GOTO 45
+ IX= IX-10000
+ IF( IX.GT. M1) GOTO 46
+ 45 IX= ICON2( J)
+ IF( IX.LT.10000) GOTO 47
+ IX= IX-10000
+ IF( IX.LT. M2) GOTO 47
+ 46 IF( ICONX( J).NE.0) GOTO 47
+ NSCON= NSCON+1
+ ISCON( NSCON)= J
+ ICONX( J)= NSCON
+ 47 CONTINUE
+ 48 CONTINUE
+ RETURN
+ 49 WRITE (6,53) IX
+C
+ STOP
+ 50 FORMAT(//,9X,'- MULTIPLE WIRE JUNCTIONS -',/,1X,'JUNCTION',4X,
+ &'SEGMENTS (- FOR END 1, + FOR END 2)')
+ 51 FORMAT(1X,I5,5X,20I5,/,(11X,20I5))
+ 52 FORMAT(2X,'NONE')
+ 53 FORMAT(' CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
+ 54 FORMAT(/,3X,'GROUND PLANE SPECIFIED.')
+ 55 FORMAT(/,3X,'WHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ',
+ &'INTERPOLATED TO IMAGE IN GROUND PLANE.',/)
+ 56 FORMAT(' GEOMETRY DATA ERROR-- SEGMENT',I5,' EXTENDS BELOW GRO',
+ &'UND')
+ 57 FORMAT(' GEOMETRY DATA ERROR--SEGMENT',I5,' LIES IN GROUND ',
+ &'PLANE.')
+ 58 FORMAT(/,3X,'TOTAL SEGMENTS USED=',I5,5X,'NO. SEG. IN ','A SY',
+ &'MMETRIC CELL=',I5,5X,'SYMMETRY FLAG=',I3)
+ 59 FORMAT(' STRUCTURE HAS',I4,' FOLD ROTATIONAL SYMMETRY',/)
+ 60 FORMAT(' STRUCTURE HAS',I2,' PLANES OF SYMMETRY',/)
+ 61 FORMAT(3X,'TOTAL PATCHES USED=',I5,6X,'NO. PATCHES IN A SYMMET',
+ &'RIC CELL=',I5)
+ 62 FORMAT(' ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS',
+ &'OR PATCHES EXCEEDS LIMIT OF',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE COUPLE( CUR, WLAM)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.
+C
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX Y11A, Y12A, CUR, Y11, Y12, Y22, YL, YIN, ZL, ZIN, RHO
+ &, VQD, VSANT, VQDS
+ COMMON /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
+ &20)
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ DIMENSION CUR(1)
+ IF( NSANT.NE.1.OR. NVQD.NE.0) RETURN
+ J= ISEGNO( NCTAG( ICOUP+1), NCSEG( ICOUP+1))
+ IF( J.NE. ISANT(1)) RETURN
+ ICOUP= ICOUP+1
+ ZIN= VSANT(1)
+ Y11A( ICOUP)= CUR( J)* WLAM/ ZIN
+ L1=( ICOUP-1)*( NCOUP-1)
+ DO 1 I=1, NCOUP
+ IF( I.EQ. ICOUP) GOTO 1
+ K= ISEGNO( NCTAG( I), NCSEG( I))
+ L1= L1+1
+ Y12A( L1)= CUR( K)* WLAM/ ZIN
+ 1 CONTINUE
+ IF( ICOUP.LT. NCOUP) RETURN
+ WRITE (6,6)
+ NPM1= NCOUP-1
+ DO 5 I=1, NPM1
+ ITT1= NCTAG( I)
+ ITS1= NCSEG( I)
+ ISG1= ISEGNO( ITT1, ITS1)
+ L1= I+1
+ DO 5 J= L1, NCOUP
+ ITT2= NCTAG( J)
+ ITS2= NCSEG( J)
+ ISG2= ISEGNO( ITT2, ITS2)
+ J1= J+( I-1)* NPM1-1
+ J2= I+( J-1)* NPM1
+ Y11= Y11A( I)
+ Y22= Y11A( J)
+ Y12=.5*( Y12A( J1)+ Y12A( J2))
+ YIN= Y12* Y12
+ DBC= ABS( YIN)
+ C= DBC/(2.* REAL( Y11)* REAL( Y22)- REAL( YIN))
+ IF( C.LT.0..OR. C.GT.1.) GOTO 4
+ IF( C.LT..01) GOTO 2
+ GMAX=(1.- SQRT(1.- C* C))/ C
+ GOTO 3
+ 2 GMAX=.5*( C+.25* C* C* C)
+ 3 RHO= GMAX* CONJG( YIN)/ DBC
+ YL=((1.- RHO)/(1.+ RHO)+1.)* REAL( Y22)- Y22
+ ZL=1./ YL
+ YIN= Y11- YIN/( Y22+ YL)
+ ZIN=1./ YIN
+ DBC= DB10( GMAX)
+ WRITE (6,7) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN
+ GOTO 5
+ 4 WRITE (6,8) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C
+ 5 CONTINUE
+C
+ RETURN
+ 6 FORMAT(///,36X,'- - - ISOLATION DATA - - -',//,6X,'- - COUPLIN',
+ &'G BETWEEN - -',8X,'MAXIMUM',15X,'- - - FOR MAXIMUM COUPLING - ',
+ &'- -',/,12X,'SEG.',14X,'SEG.',3X,'COUPLING',4X,'LOAD IMPEDANCE ',
+ &'(2ND SEG.)',7X,'INPUT IMPEDANCE',/,2X,'TAG/SEG.',3X,'NO.',4X,
+ &'TAG/''SEG.',3X,'NO.',6X,'(DB)',8X,'REAL',9X,'IMAG.',9X,'REAL',9X
+ &,'IMAG.')
+ 7 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5))
+ 8 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),'**ERROR** COUPLING IS NOT BETWE',
+ &'EN 0 AND 1. (=',1P,E12.5,')')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE DATAGN
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.
+C
+C***
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+C***
+ CHARACTER *2 GM, ATST
+ CHARACTER *1 IFX,IFY,IFZ,IPT
+
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+C***
+ COMMON /ANGL/ SALP( NM)
+C***
+ COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
+ DIMENSION X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1),
+ &T2Y(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1),
+ & IPT(4)
+C***
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET),(CAB,ALP),(SAB,BET)
+C***
+ data atst/'GW','GX','GR','GS','GE','GM','SP','SM','GF','GA',
+ $ 'SC','GC','GH'/
+* DATA ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA,
+* &2HSC,2HGC,2HGH/
+ DATA IFX/1H ,1HX/, IFY/1H ,1HY/, IFZ/1H ,1HZ/
+ DATA TA/0.01745329252D+0/, TD/57.29577951D+0/, IPT/1HP,1HR,1HT,
+ &1HQ/
+ IPSYM=0
+ NWIRE=0
+ N=0
+ NP=0
+ M=0
+ MP=0
+ N1=0
+ N2=1
+ M1=0
+ M2=1
+ ISCT=0
+
+C
+C READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION
+C REQUESTED
+C
+C***
+C 1 READ (5,42) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
+ IPHD=0
+C***
+ 1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD)
+ PRINT *, 'READ CARD ',GM
+ IF( N+ M.GT. LD) GOTO 37
+ IF( GM.EQ. ATST(9)) GOTO 27
+ IF( IPHD.EQ.1) GOTO 2
+ WRITE (6,40)
+ WRITE (6,41)
+ IPHD=1
+ 2 IF( GM.EQ. ATST(11)) GOTO 10
+ ISCT=0
+ IF( GM.EQ. ATST(1)) GOTO 3
+ IF( GM.EQ. ATST(2)) GOTO 18
+ IF( GM.EQ. ATST(3)) GOTO 19
+ IF( GM.EQ. ATST(4)) GOTO 21
+ IF( GM.EQ. ATST(7)) GOTO 9
+ IF( GM.EQ. ATST(8)) GOTO 13
+ IF( GM.EQ. ATST(5)) GOTO 29
+ IF( GM.EQ. ATST(6)) GOTO 26
+C***
+ IF( GM.EQ. ATST(10)) GOTO 8
+C***
+ IF( GM.EQ. ATST(13)) GOTO 123
+C
+C GENERATE SEGMENT DATA FOR STRAIGHT WIRE.
+C
+ GOTO 36
+
+ 3 NWIRE= NWIRE+1
+ I1= N+1
+ I2= N+ NS
+ WRITE (6,43) NWIRE, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
+ &I2, ITG
+ IF( RAD.EQ.0) GOTO 4
+ XS1=1.
+ YS1=1.
+C***
+ GOTO 7
+C 4 READ (5,42) GM,IX,IY,XS1,YS1,ZS1
+C***
+ 4 CALL READGM( GM, IX, IY, XS1, YS1, ZS1, DUMMY, DUMMY, DUMMY,
+ &DUMMY)
+ IF( GM.EQ. ATST(12)) GOTO 6
+ 5 WRITE (6,48)
+ STOP
+ 6 WRITE (6,61) XS1, YS1, ZS1
+ IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5
+ RAD= YS1
+ YS1=( ZS1/ YS1)**(1./( NS-1.))
+ 7 CALL WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, XS1, YS1, NS, ITG)
+C
+C GENERATE SEGMENT DATA FOR WIRE ARC
+C
+ GOTO 1
+ 8 NWIRE= NWIRE+1
+ I1= N+1
+ I2= N+ NS
+ WRITE (6,38) NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG
+ CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2)
+C***
+C
+C GENERATE HELIX
+C
+ GOTO 1
+ 123 NWIRE= NWIRE+1
+ I1= N+1
+ I2= N+ NS
+ WRITE (6,124) XW1, YW1, NWIRE, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
+ &I2, ITG
+ CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG)
+C
+ GOTO 1
+C***
+C
+C GENERATE SINGLE NEW PATCH
+C
+ 124 FORMAT(5X,'HELIX STRUCTURE- AXIAL SPACING BETWEEN TURNS =',F8.3
+ &,' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X,F
+ &8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)
+ 9 I1= M+1
+ NS= NS+1
+ IF( ITG.NE.0) GOTO 17
+ WRITE (6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
+ IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1
+ IF( NS.GT.1) GOTO 14
+ XW2= XW2* TA
+ YW2= YW2* TA
+ GOTO 16
+ 10 IF( ISCT.EQ.0) GOTO 17
+ I1= M+1
+ NS= NS+1
+ IF( ITG.NE.0) GOTO 17
+ IF( NS.NE.2.AND. NS.NE.4) GOTO 17
+ XS1= X4
+ YS1= Y4
+ ZS1= Z4
+ XS2= X3
+ YS2= Y3
+ ZS2= Z3
+ X3= XW1
+ Y3= YW1
+ Z3= ZW1
+ IF( NS.NE.4) GOTO 11
+ X4= XW2
+ Y4= YW2
+ Z4= ZW2
+ 11 XW1= XS1
+ YW1= YS1
+ ZW1= ZS1
+ XW2= XS2
+ YW2= YS2
+ ZW2= ZS2
+ IF( NS.EQ.4) GOTO 12
+ X4= XW1+ X3- XW2
+ Y4= YW1+ Y3- YW2
+ Z4= ZW1+ Z3- ZW2
+ 12 WRITE (6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
+ WRITE (6,39) X3, Y3, Z3, X4, Y4, Z4
+C
+C GENERATE MULTIPLE-PATCH SURFACE
+C
+ GOTO 16
+ 13 I1= M+1
+ WRITE (6,59) I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS
+C***
+ IF( ITG.LT.1.OR. NS.LT.1) GOTO 17
+C 14 READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4
+C***
+ 14 CALL READGM( GM, IX, IY, X3, Y3, Z3, X4, Y4, Z4, DUMMY)
+ IF( NS.NE.2.AND. ITG.LT.1) GOTO 15
+ X4= XW1+ X3- XW2
+ Y4= YW1+ Y3- YW2
+ Z4= ZW1+ Z3- ZW2
+ 15 WRITE (6,39) X3, Y3, Z3, X4, Y4, Z4
+ IF( GM.NE. ATST(11)) GOTO 17
+ 16 CALL PATCH( ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, X3, Y3, Z3, X4
+ &, Y4, Z4)
+ GOTO 1
+ 17 WRITE (6,60)
+C
+C REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
+C
+ STOP
+ 18 IY= NS/10
+ IZ= NS- IY*10
+ IX= IY/10
+ IY= IY- IX*10
+ IF( IX.NE.0) IX=1
+ IF( IY.NE.0) IY=1
+ IF( IZ.NE.0) IZ=1
+ WRITE (6,44) IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG
+ GOTO 20
+ 19 WRITE (6,45) NS, ITG
+ IX=-1
+ 20 CALL REFLC( IX, IY, IZ, ITG, NS)
+C
+C SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.
+C
+ GOTO 1
+ 21 IF( N.LT. N2) GOTO 23
+ DO 22 I= N2, N
+ X( I)= X( I)* XW1
+ Y( I)= Y( I)* XW1
+ Z( I)= Z( I)* XW1
+ X2( I)= X2( I)* XW1
+ Y2( I)= Y2( I)* XW1
+ Z2( I)= Z2( I)* XW1
+ 22 BI( I)= BI( I)* XW1
+ 23 IF( M.LT. M2) GOTO 25
+ YW1= XW1* XW1
+ IX= LD+1- M
+ IY= LD- M1
+ DO 24 I= IX, IY
+ X( I)= X( I)* XW1
+ Y( I)= Y( I)* XW1
+ Z( I)= Z( I)* XW1
+ 24 BI( I)= BI( I)* YW1
+ 25 WRITE (6,46) XW1
+C
+C MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.
+C
+ GOTO 1
+ 26 WRITE (6,47) ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
+ XW1= XW1* TA
+ YW1= YW1* TA
+ ZW1= ZW1* TA
+ CALL MOVE( XW1, YW1, ZW1, XW2, YW2, ZW2, INT( RAD+.5), NS, ITG)
+C
+C READ NUMERICAL GREEN'S FUNCTION TAPE
+C
+ GOTO 1
+ 27 IF( N+ M.EQ.0) GOTO 28
+ WRITE (6,52)
+ STOP
+ 28 CALL GFIL( ITG)
+ NPSAV= NP
+ MPSAV= MP
+ IPSAV= IPSYM
+C
+C TERMINATE STRUCTURE GEOMETRY INPUT.
+C
+C***
+ GOTO 1
+ 29 IF( NS.EQ.0) GOTO 290
+ IPLP1=1
+ IPLP2=1
+C***
+ 290 IX= N1+ M1
+ IF( IX.EQ.0) GOTO 30
+ NP= N
+ MP= M
+ IPSYM=0
+ 30 CALL CONECT( ITG)
+ IF( IX.EQ.0) GOTO 31
+ NP= NPSAV
+ MP= MPSAV
+ IPSYM= IPSAV
+ 31 IF( N+ M.GT. LD) GOTO 37
+ IF( N.EQ.0) GOTO 33
+ WRITE (6,53)
+ WRITE (6,54)
+ DO 32 I=1, N
+ XW1= X2( I)- X( I)
+ YW1= Y2( I)- Y( I)
+ ZW1= Z2( I)- Z( I)
+ X( I)=( X( I)+ X2( I))*.5
+ Y( I)=( Y( I)+ Y2( I))*.5
+ Z( I)=( Z( I)+ Z2( I))*.5
+ XW2= XW1* XW1+ YW1* YW1+ ZW1* ZW1
+ YW2= SQRT( XW2)
+ YW2=( XW2/ YW2+ YW2)*.5
+ SI( I)= YW2
+ CAB( I)= XW1/ YW2
+ SAB( I)= YW1/ YW2
+ XW2= ZW1/ YW2
+ IF( XW2.GT.1.) XW2=1.
+ IF( XW2.LT.-1.) XW2=-1.
+ SALP( I)= XW2
+ XW2= ASIN( XW2)* TD
+ YW2= ATGN2( YW1, XW1)* TD
+C***
+ WRITE (6,55) I, X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I),
+ &ICON1( I), I, ICON2( I), ITAG( I)
+ IF( IPLP1.NE.1) GOTO 320
+ WRITE( 8,*) X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I), ICON1
+ &( I), I, ICON2( I)
+C***
+ 320 CONTINUE
+ IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32
+ WRITE (6,56)
+ STOP
+ 32 CONTINUE
+ 33 IF( M.EQ.0) GOTO 35
+ WRITE (6,57)
+ J= LD+1
+ DO 34 I=1, M
+ J= J-1
+ XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J)
+ YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J)
+ ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J)
+ WRITE (6,58) I, X( J), Y( J), Z( J), XW1, YW1, ZW1, BI( J), T1X(
+ & J), T1Y( J), T1Z( J), T2X( J), T2Y( J), T2Z( J)
+ 34 CONTINUE
+ 35 RETURN
+ 36 WRITE (6,48)
+ WRITE (6,49) GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
+ STOP
+ 37 WRITE (6,50)
+C
+ STOP
+ 38 FORMAT(1X,I5,2X,'ARC RADIUS =',F9.5,2X,'FROM',F8.3,' TO',F8.3,
+ &' DEGREES',11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
+ 39 FORMAT(6X,3F11.5,1X,3F11.5)
+ 40 FORMAT(////,33X,'- - - STRUCTURE SPECIFICATION - - -',//,37X,
+ &'COORDINATES MUST BE INPUT IN',/,37X,
+ &'METERS OR BE SCALED TO METERS',/,37X,
+ &'BEFORE STRUCTURE INPUT IS ENDED',//)
+ 41 FORMAT(2X,'WIRE',79X,'NO. OF',4X,'FIRST',2X,'LAST',5X,'TAG',/,2X,
+ &'NO.',8X,'X1',9X,'Y1',9X,'Z1',10X,'X2',9X,'Y2',9X,'Z2',6X,
+ &'RADIUS',3X,'SEG.',5X,'SEG.',3X,'SEG.',5X,'NO.')
+ 42 FORMAT(A2, I3, I5, 7F10.5)
+ 43 FORMAT(1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
+ 44 FORMAT(6X,'STRUCTURE REFLECTED ALONG THE AXES',3(1X,A1),'. TA',
+ &'GS INCREMENTED BY',I5)
+ 45 FORMAT(6X,'STRUCTURE ROTATED ABOUT Z-AXIS',I3,' TIMES. LABELS',
+ &' INCREMENTED BY',I5)
+ 46 FORMAT(6X,'STRUCTURE SCALED BY FACTOR',F10.5)
+ 47 FORMAT(6X,'THE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X',
+ &I3,I5,7F10.5)
+ 48 FORMAT(' GEOMETRY DATA CARD ERROR')
+ 49 FORMAT(1X,A2,I3,I5,7F10.5)
+ 50 FORMAT(' NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI',
+ &'MENSION LIMIT.')
+ 51 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
+ 52 FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD')
+ 53 FORMAT(////33X,'- - - - SEGMENTATION DATA - - - -',//,40X,'COO',
+ &'RDINATES IN METERS',//,25X,
+ &'I+ AND I- INDICATE THE SEGMENTS BEFORE AND AFTER I',//)
+ 54 FORMAT(2X,'SEG.',3X,'COORDINATES OF SEG. CENTER',5X,'SEG.',5X,
+ &'ORIENTATION ANGLES',4X,'WIRE',4X,'CONNECTION DATA',3X,'TAG',/,2X
+ &,'NO.',7X,'X',9X,'Y',9X,'Z',7X,'LENGTH',5X,'ALPHA',5X,'BETA',6X,
+ &'RADIUS',4X,'I-',3X,'I',4X,'I+',4X,'NO.')
+ 55 FORMAT(1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
+ 56 FORMAT(' SEGMENT DATA ERROR')
+ 57 FORMAT(////,44X,'- - - SURFACE PATCH DATA - - -',//,49X,'COORD',
+ &'INATES IN METERS',//,1X,'PATCH',5X,'COORD. OF PATCH CENTER',7X,
+ &'UNIT NORMAL VECTOR',6X,'PATCH',12X,
+ &'COMPONENTS OF UNIT TANGENT V''ECTORS',/,2X,'NO.',6X,'X',9X,'Y',9
+ &X,'Z',9X,'X',7X,'Y',7X,'Z',7X,'AREA',7X,'X1',6X,'Y1',6X,'Z1',7X,
+ &'X2',6X,'Y2',6X,'Z2')
+ 58 FORMAT(1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4)
+ 59 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,'SURFACE -',I4,' BY',I3
+ &,' PATCHES')
+ 60 FORMAT(' PATCH DATA ERROR')
+ 61 FORMAT(9X,'ABOVE WIRE IS TAPERED. SEG. LENGTH RATIO =',F9.5,/,33
+ &X,'RADIUS FROM',F9.5,' TO',F9.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ FUNCTION DB10( X)
+C ***
+C
+C FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
+C
+ IMPLICIT REAL (A-H,O-Z)
+ F=10.
+ GOTO 1
+ ENTRY DB20 (x)
+ F=20.
+ 1 IF( X.LT.1.D-20) GOTO 2
+ DB10= F* LOG10( X)
+ RETURN
+ 2 DB10=-999.99
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE EFLD( XI, YI, ZI, AI, IJ)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C
+C COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
+C CONSTANT CURRENTS. GROUND EFFECT INCLUDED.
+C
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX TXK, TYK, TZK, TXS, TYS, TZS, TXC, TYC, TZC, EXK, EYK
+ &, EZK, EXS, EYS, EZS, EXC, EYC, EZC, EPX, EPY, ZRATI, REFS, REFPS
+ &, ZRSIN, ZRATX, T1, ZSCRN, ZRATI2, TEZS, TERS, TEZC, TERC, TEZK,
+ &TERK, EGND, FRATI
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
+ DIMENSION EGND(9)
+ EQUIVALENCE(EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),TXS
+ &),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),(EGND(9
+ &),TZC)
+ DATA ETA/376.73/, PI/3.141592654D+0/, TP/6.283185308D+0/
+ XIJ= XI- XJ
+ YIJ= YI- YJ
+ IJX= IJ
+ RFL=-1.
+ DO 12 IP=1, KSYMP
+ IF( IP.EQ.2) IJX=1
+ RFL=- RFL
+ SALPR= SALPJ* RFL
+ ZIJ= ZI- RFL* ZJ
+ ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
+ RHOX= XIJ- CABJ* ZP
+ RHOY= YIJ- SABJ* ZP
+ RHOZ= ZIJ- SALPR* ZP
+ RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
+ IF( RH.GT.1.D-10) GOTO 1
+ RHOX=0.
+ RHOY=0.
+ RHOZ=0.
+ GOTO 2
+ 1 RHOX= RHOX/ RH
+ RHOY= RHOY/ RH
+ RHOZ= RHOZ/ RH
+ 2 R= SQRT( ZP* ZP+ RH* RH)
+C
+C LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
+C
+ IF( R.LT. RKH) GOTO 3
+ RMAG= TP* R
+ CTH= ZP/ R
+ PX= RH/ R
+ TXK= CMPLX( COS( RMAG),- SIN( RMAG))
+ PY= TP* R* R
+ TYK= ETA* CTH* TXK* CMPLX(1.D+0,-1.D+0/ RMAG)/ PY
+ TZK= ETA* PX* TXK* CMPLX(1.D+0, RMAG-1.D+0/ RMAG)/(2.* PY)
+ TEZK= TYK* CTH- TZK* PX
+ TERK= TYK* PX+ TZK* CTH
+ RMAG= SIN( PI* S)/ PI
+ TEZC= TEZK* RMAG
+ TERC= TERK* RMAG
+ TEZK= TEZK* S
+ TERK= TERK* S
+ TXS=(0.,0.)
+ TYS=(0.,0.)
+ TZS=(0.,0.)
+ GOTO 6
+C
+C EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
+C
+ 3 IF( IEXK.EQ.1) GOTO 4
+ CALL EKSC( S, ZP, RH, TP, IJX, TEZS, TERS, TEZC, TERC, TEZK, TERK
+ &)
+ GOTO 5
+ 4 CALL EKSCX( B, S, ZP, RH, TP, IJX, IND1, IND2, TEZS, TERS, TEZC,
+ &TERC, TEZK, TERK)
+ 5 TXS= TEZS* CABJ+ TERS* RHOX
+ TYS= TEZS* SABJ+ TERS* RHOY
+ TZS= TEZS* SALPR+ TERS* RHOZ
+ 6 TXK= TEZK* CABJ+ TERK* RHOX
+ TYK= TEZK* SABJ+ TERK* RHOY
+ TZK= TEZK* SALPR+ TERK* RHOZ
+ TXC= TEZC* CABJ+ TERC* RHOX
+ TYC= TEZC* SABJ+ TERC* RHOY
+ TZC= TEZC* SALPR+ TERC* RHOZ
+ IF( IP.NE.2) GOTO 11
+ IF( IPERF.GT.0) GOTO 10
+ ZRATX= ZRATI
+ RMAG= R
+C
+C SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
+C
+ XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
+ IF( NRADL.EQ.0) GOTO 7
+ XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
+ YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
+ RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
+ IF( RHOSPC.GT. SCRWL) GOTO 7
+ ZSCRN= T1* RHOSPC* LOG( RHOSPC/ T2)
+ ZRATX=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
+C
+C CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
+C
+ 7 IF( XYMAG.GT.1.D-6) GOTO 8
+ PX=0.
+ PY=0.
+ CTH=1.
+ ZRSIN=(1.,0.)
+ GOTO 9
+ 8 PX=- YIJ/ XYMAG
+ PY= XIJ/ XYMAG
+ CTH= ZIJ/ RMAG
+ ZRSIN= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
+ 9 REFS=( CTH- ZRATX* ZRSIN)/( CTH+ ZRATX* ZRSIN)
+ REFPS=-( ZRATX* CTH- ZRSIN)/( ZRATX* CTH+ ZRSIN)
+ REFPS= REFPS- REFS
+ EPY= PX* TXK+ PY* TYK
+ EPX= PX* EPY
+ EPY= PY* EPY
+ TXK= REFS* TXK+ REFPS* EPX
+ TYK= REFS* TYK+ REFPS* EPY
+ TZK= REFS* TZK
+ EPY= PX* TXS+ PY* TYS
+ EPX= PX* EPY
+ EPY= PY* EPY
+ TXS= REFS* TXS+ REFPS* EPX
+ TYS= REFS* TYS+ REFPS* EPY
+ TZS= REFS* TZS
+ EPY= PX* TXC+ PY* TYC
+ EPX= PX* EPY
+ EPY= PY* EPY
+ TXC= REFS* TXC+ REFPS* EPX
+ TYC= REFS* TYC+ REFPS* EPY
+ TZC= REFS* TZC
+ 10 EXK= EXK- TXK* FRATI
+ EYK= EYK- TYK* FRATI
+ EZK= EZK- TZK* FRATI
+ EXS= EXS- TXS* FRATI
+ EYS= EYS- TYS* FRATI
+ EZS= EZS- TZS* FRATI
+ EXC= EXC- TXC* FRATI
+ EYC= EYC- TYC* FRATI
+ EZC= EZC- TZC* FRATI
+ GOTO 12
+ 11 EXK= TXK
+ EYK= TYK
+ EZK= TZK
+ EXS= TXS
+ EYS= TYS
+ EZS= TZS
+ EXC= TXC
+ EYC= TYC
+ EZC= TZC
+ 12 CONTINUE
+ IF( IPERF.EQ.2) GOTO 13
+C
+C FIELD DUE TO GROUND USING SOMMERFELD/NORTON
+C
+ RETURN
+ 13 SN= SQRT( CABJ* CABJ+ SABJ* SABJ)
+ IF( SN.LT.1.D-5) GOTO 14
+ XSN= CABJ/ SN
+ YSN= SABJ/ SN
+ GOTO 15
+ 14 SN=0.
+ XSN=1.
+C
+C DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
+C
+ YSN=0.
+ 15 ZIJ= ZI+ ZJ
+ SALPR=- SALPJ
+ RHOX= SABJ* ZIJ- SALPR* YIJ
+ RHOY= SALPR* XIJ- CABJ* ZIJ
+ RHOZ= CABJ* YIJ- SABJ* XIJ
+ RH= RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ
+ IF( RH.GT.1.D-10) GOTO 16
+ XO= XI- AI* YSN
+ YO= YI+ AI* XSN
+ ZO= ZI
+ GOTO 17
+ 16 RH= AI/ SQRT( RH)
+ IF( RHOZ.LT.0.) RH=- RH
+ XO= XI+ RH* RHOX
+ YO= YI+ RH* RHOY
+ ZO= ZI+ RH* RHOZ
+ 17 R= XIJ* XIJ+ YIJ* YIJ+ ZIJ* ZIJ
+C
+C FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
+C
+ IF( R.GT..95) GOTO 18
+ ISNOR=1
+ DMIN= EXK* CONJG( EXK)+ EYK* CONJG( EYK)+ EZK* CONJG( EZK)
+ DMIN=.01* SQRT( DMIN)
+ SHAF=.5* S
+ CALL ROM2(- SHAF, SHAF, EGND, DMIN)
+C
+C NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
+C
+ GOTO 19
+ 18 ISNOR=2
+ CALL SFLDS(0., EGND)
+ GOTO 22
+ 19 ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
+ RH= R- ZP* ZP
+ IF( RH.GT.1.D-10) GOTO 20
+ DMIN=0.
+ GOTO 21
+ 20 DMIN= SQRT( RH/( RH+ AI* AI))
+ 21 IF( DMIN.GT..95) GOTO 22
+ PX=1.- DMIN
+ TERK=( TXK* CABJ+ TYK* SABJ+ TZK* SALPR)* PX
+ TXK= DMIN* TXK+ TERK* CABJ
+ TYK= DMIN* TYK+ TERK* SABJ
+ TZK= DMIN* TZK+ TERK* SALPR
+ TERS=( TXS* CABJ+ TYS* SABJ+ TZS* SALPR)* PX
+ TXS= DMIN* TXS+ TERS* CABJ
+ TYS= DMIN* TYS+ TERS* SABJ
+ TZS= DMIN* TZS+ TERS* SALPR
+ TERC=( TXC* CABJ+ TYC* SABJ+ TZC* SALPR)* PX
+ TXC= DMIN* TXC+ TERC* CABJ
+ TYC= DMIN* TYC+ TERC* SABJ
+ TZC= DMIN* TZC+ TERC* SALPR
+ 22 EXK= EXK+ TXK
+ EYK= EYK+ TYK
+ EZK= EZK+ TZK
+ EXS= EXS+ TXS
+ EYS= EYS+ TYS
+ EZS= EZS+ TZS
+ EXC= EXC+ TXC
+ EYC= EYC+ TYC
+ EZC= EZC+ TZC
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE EKSC( S, Z, RH, XK, IJ, EZS, ERS, EZC, ERC, EZK, ERK)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
+C THIN WIRE APPROXIMATION.
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CON, GZ1, GZ2, GP1, GP2, GZP1, GZP2, EZS, ERS, EZC,
+ &ERC, EZK, ERK
+ COMMON /TMI/ ZPK, RKB2, IJX
+ DIMENSION CONX(2)
+ EQUIVALENCE(CONX,CON)
+ DATA CONX/0.,4.771341189D+0/
+ IJX= IJ
+ ZPK= XK* Z
+ RHK= XK* RH
+ RKB2= RHK* RHK
+ SH=.5* S
+ SHK= XK* SH
+ SS= SIN( SHK)
+ CS= COS( SHK)
+ Z2= SH- Z
+ Z1=-( SH+ Z)
+ CALL GX( Z1, RH, XK, GZ1, GP1)
+ CALL GX( Z2, RH, XK, GZ2, GP2)
+ GZP1= GP1* Z1
+ GZP2= GP2* Z2
+ EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
+ EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
+ ERK= CON*( GP2- GP1)* RH
+ CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
+ EZK=- CON*( GZP2- GZP1+ XK* XK* CMPLX( CINT,- SINT))
+ GZP1= GZP1* Z1
+ GZP2= GZP2* Z2
+ IF( RH.LT.1.D-10) GOTO 1
+ ERS=- CON*(( GZP2+ GZP1+ GZ2+ GZ1)* SS-( Z2* GZ2- Z1* GZ1)* CS*
+ &XK)/ RH
+ ERC=- CON*(( GZP2- GZP1+ GZ2- GZ1)* CS+( Z2* GZ2+ Z1* GZ1)* SS*
+ &XK)/ RH
+ RETURN
+ 1 ERS=(0.,0.)
+ ERC=(0.,0.)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE EKSCX( BX, S, Z, RHX, XK, IJ, INX1, INX2, EZS, ERS,
+ &EZC, ERC, EZK, ERK)
+C ***
+C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
+C EXTENDED THIN WIRE APPROXIMATION.
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CON, GZ1, GZ2, GZP1, GZP2, GR1, GR2, GRP1, GRP2, EZS,
+ & EZC, ERS, ERC, GRK1, GRK2, EZK, ERK, GZZ1, GZZ2
+ COMMON /TMI/ ZPK, RKB2, IJX
+ DIMENSION CONX(2)
+ EQUIVALENCE(CONX,CON)
+ DATA CONX/0.,4.771341189D+0/
+ IF( RHX.LT. BX) GOTO 1
+ RH= RHX
+ B= BX
+ IRA=0
+ GOTO 2
+ 1 RH= BX
+ B= RHX
+ IRA=1
+ 2 SH=.5* S
+ IJX= IJ
+ ZPK= XK* Z
+ RHK= XK* RH
+ RKB2= RHK* RHK
+ SHK= XK* SH
+ SS= SIN( SHK)
+ CS= COS( SHK)
+ Z2= SH- Z
+ Z1=-( SH+ Z)
+ A2= B* B
+ IF( INX1.EQ.2) GOTO 3
+ CALL GXX( Z1, RH, B, A2, XK, IRA, GZ1, GZP1, GR1, GRP1, GRK1,
+ &GZZ1)
+ GOTO 4
+ 3 CALL GX( Z1, RHX, XK, GZ1, GRK1)
+ GZP1= GRK1* Z1
+ GR1= GZ1/ RHX
+ GRP1= GZP1/ RHX
+ GRK1= GRK1* RHX
+ GZZ1=(0.,0.)
+ 4 IF( INX2.EQ.2) GOTO 5
+ CALL GXX( Z2, RH, B, A2, XK, IRA, GZ2, GZP2, GR2, GRP2, GRK2,
+ &GZZ2)
+ GOTO 6
+ 5 CALL GX( Z2, RHX, XK, GZ2, GRK2)
+ GZP2= GRK2* Z2
+ GR2= GZ2/ RHX
+ GRP2= GZP2/ RHX
+ GRK2= GRK2* RHX
+ GZZ2=(0.,0.)
+ 6 EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
+ EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
+ ERS=- CON*(( Z2* GRP2+ Z1* GRP1+ GR2+ GR1)* SS-( Z2* GR2- Z1* GR1
+ &)* CS* XK)
+ ERC=- CON*(( Z2* GRP2- Z1* GRP1+ GR2- GR1)* CS+( Z2* GR2+ Z1* GR1
+ &)* SS* XK)
+ ERK= CON*( GRK2- GRK1)
+ CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
+ BK= B* XK
+ BK2= BK* BK*.25
+ EZK=- CON*( GZP2- GZP1+ XK* XK*(1.- BK2)* CMPLX( CINT,- SINT)-
+ &BK2*( GZZ2- GZZ1))
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+C LOGICAL FUNCTION ENF( NUNIT)
+C ***
+C*********** THIS ROUTINE NOT USED ON VAX **************
+C IF (EOF,NUNIT) 1,2
+C IMPLICIT REAL (A-H,O-Z)
+C 1 ENF=.TRUE.
+C RETURN
+C 2 ENF=.FALSE.
+C RETURN
+C END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+C ***
+C
+C ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD
+C INCIDENT ON THE STRUCTURE. E IS THE RIGHT HAND SIDE OF THE MATRIX
+C EQUATION.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX E, CX, CY, CZ, VSANT, ER, ET, EZH, ERH, VQD
+ &, VQDS, ZRATI, ZRATI2, RRV, RRH, T1, TT1, TT2, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ DIMENSION CAB(1), SAB(1), E( N2M)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ EQUIVALENCE(CAB,ALP),(SAB,BET)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ DATA TP/6.283185308D+0/, RETA/2.654420938D-3/
+ NEQ= N+2* M
+ NQDS=0
+C
+C APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE
+C
+ IF( IPR.GT.0.AND. IPR.NE.5) GOTO 5
+ DO 1 I=1, NEQ
+ 1 E( I)=(0.,0.)
+ IF( NSANT.EQ.0) GOTO 3
+ DO 2 I=1, NSANT
+ IS= ISANT( I)
+ 2 E( IS)=- VSANT( I)/( SI( IS)* WLAM)
+ 3 IF( NVQD.EQ.0) RETURN
+ DO 4 I=1, NVQD
+ IS= IVQD( I)
+ 4 CALL QDSRC( IS, VQD( I), E)
+ RETURN
+C
+C INCIDENT PLANE WAVE, LINEARLY POLARIZED.
+C
+ 5 IF( IPR.GT.3) GOTO 19
+ CTH= COS( P1)
+ STH= SIN( P1)
+ CPH= COS( P2)
+ SPH= SIN( P2)
+ CET= COS( P3)
+ SET= SIN( P3)
+ PX= CTH* CPH* CET- SPH* SET
+ PY= CTH* SPH* CET+ CPH* SET
+ PZ=- STH* CET
+ WX=- STH* CPH
+ WY=- STH* SPH
+ WZ=- CTH
+ QX= WY* PZ- WZ* PY
+ QY= WZ* PX- WX* PZ
+ QZ= WX* PY- WY* PX
+ IF( KSYMP.EQ.1) GOTO 7
+ IF( IPERF.EQ.1) GOTO 6
+ RRV= SQRT(1.- ZRATI* ZRATI* STH* STH)
+ RRH= ZRATI* CTH
+ RRH=( RRH- RRV)/( RRH+ RRV)
+ RRV= ZRATI* RRV
+ RRV=-( CTH- RRV)/( CTH+ RRV)
+ GOTO 7
+ 6 RRV=-(1.,0.)
+ RRH=-(1.,0.)
+ 7 IF( IPR.GT.1) GOTO 13
+ IF( N.EQ.0) GOTO 10
+ DO 8 I=1, N
+ ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
+ 8 E( I)=-( PX* CAB( I)+ PY* SAB( I)+ PZ* SALP( I))* CMPLX( COS( ARG
+ &), SIN( ARG))
+ IF( KSYMP.EQ.1) GOTO 10
+ TT1=( PY* CPH- PX* SPH)*( RRH- RRV)
+ CX= RRV* PX- TT1* SPH
+ CY= RRV* PY+ TT1* CPH
+ CZ=- RRV* PZ
+ DO 9 I=1, N
+ ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
+ 9 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX(
+ &COS( ARG), SIN( ARG))
+ 10 IF( M.EQ.0) RETURN
+ I= LD+1
+ I1= N-1
+ DO 11 IS=1, M
+ I= I-1
+ I1= I1+2
+ I2= I1+1
+ ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
+ TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
+ E( I2)=( QX* T1X( I)+ QY* T1Y( I)+ QZ* T1Z( I))* TT1
+ 11 E( I1)=( QX* T2X( I)+ QY* T2Y( I)+ QZ* T2Z( I))* TT1
+ IF( KSYMP.EQ.1) RETURN
+ TT1=( QY* CPH- QX* SPH)*( RRV- RRH)
+ CX=-( RRH* QX- TT1* SPH)
+ CY=-( RRH* QY+ TT1* CPH)
+ CZ= RRH* QZ
+ I= LD+1
+ I1= N-1
+ DO 12 IS=1, M
+ I= I-1
+ I1= I1+2
+ I2= I1+1
+ ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
+ TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
+ E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
+ 12 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
+C
+C INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.
+C
+ RETURN
+ 13 TT1=-(0.,1.)* P6
+ IF( IPR.EQ.3) TT1=- TT1
+ IF( N.EQ.0) GOTO 16
+ CX= PX+ TT1* QX
+ CY= PY+ TT1* QY
+ CZ= PZ+ TT1* QZ
+ DO 14 I=1, N
+ ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
+ 14 E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX( COS( ARG
+ &), SIN( ARG))
+ IF( KSYMP.EQ.1) GOTO 16
+ TT2=( CY* CPH- CX* SPH)*( RRH- RRV)
+ CX= RRV* CX- TT2* SPH
+ CY= RRV* CY+ TT2* CPH
+ CZ=- RRV* CZ
+ DO 15 I=1, N
+ ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
+ 15 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX(
+ &COS( ARG), SIN( ARG))
+ 16 IF( M.EQ.0) RETURN
+ CX= QX- TT1* PX
+ CY= QY- TT1* PY
+ CZ= QZ- TT1* PZ
+ I= LD+1
+ I1= N-1
+ DO 17 IS=1, M
+ I= I-1
+ I1= I1+2
+ I2= I1+1
+ ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
+ TT2= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
+ E( I2)=( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT2
+ 17 E( I1)=( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT2
+ IF( KSYMP.EQ.1) RETURN
+ TT1=( CY* CPH- CX* SPH)*( RRV- RRH)
+ CX=-( RRH* CX- TT1* SPH)
+ CY=-( RRH* CY+ TT1* CPH)
+ CZ= RRH* CZ
+ I= LD+1
+ I1= N-1
+ DO 18 IS=1, M
+ I= I-1
+ I1= I1+2
+ I2= I1+1
+ ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
+ TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
+ E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
+ 18 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
+C
+C INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.
+C
+ RETURN
+ 19 WZ= COS( P4)
+ WX= WZ* COS( P5)
+ WY= WZ* SIN( P5)
+ WZ= SIN( P4)
+ DS= P6*59.958
+ DSH= P6/(2.* TP)
+ NPM= N+ M
+ IS= LD+1
+ I1= N-1
+ DO 24 I=1, NPM
+ II= I
+ IF( I.LE. N) GOTO 20
+ IS= IS-1
+ II= IS
+ I1= I1+2
+ I2= I1+1
+ 20 PX= X( II)- P1
+ PY= Y( II)- P2
+ PZ= Z( II)- P3
+ RS= PX* PX+ PY* PY+ PZ* PZ
+ IF( RS.LT.1.D-30) GOTO 24
+ R= SQRT( RS)
+ PX= PX/ R
+ PY= PY/ R
+ PZ= PZ/ R
+ CTH= PX* WX+ PY* WY+ PZ* WZ
+ STH= SQRT(1.- CTH* CTH)
+ QX= PX- WX* CTH
+ QY= PY- WY* CTH
+ QZ= PZ- WZ* CTH
+ ARG= SQRT( QX* QX+ QY* QY+ QZ* QZ)
+ IF( ARG.LT.1.D-30) GOTO 21
+ QX= QX/ ARG
+ QY= QY/ ARG
+ QZ= QZ/ ARG
+ GOTO 22
+ 21 QX=1.
+ QY=0.
+ QZ=0.
+ 22 ARG=- TP* R
+ TT1= CMPLX( COS( ARG), SIN( ARG))
+ IF( I.GT. N) GOTO 23
+ TT2= CMPLX(1.D+0,-1.D+0/( R* TP))/ RS
+ ER= DS* TT1* TT2* CTH
+ ET=.5* DS* TT1*((0.,1.)* TP/ R+ TT2)* STH
+ EZH= ER* CTH- ET* STH
+ ERH= ER* STH+ ET* CTH
+ CX= EZH* WX+ ERH* QX
+ CY= EZH* WY+ ERH* QY
+ CZ= EZH* WZ+ ERH* QZ
+ E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))
+ GOTO 24
+ 23 PX= WY* QZ- WZ* QY
+ PY= WZ* QX- WX* QZ
+ PZ= WX* QY- WY* QX
+ TT2= DSH* TT1* CMPLX(1./ R, TP)/ R* STH* SALP( II)
+ CX= TT2* PX
+ CY= TT2* PY
+ CZ= TT2* PZ
+ E( I2)= CX* T1X( II)+ CY* T1Y( II)+ CZ* T1Z( II)
+ E( I1)= CX* T2X( II)+ CY* T2Y( II)+ CZ* T2Z( II)
+ 24 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FACGF( A, B, C, D, BX, IP, IX, NP, N1, MP, M1, N1C,
+ &N2C)
+C ***
+C FACGF COMPUTES AND FACTORS D-C(INV(A)B).
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX A, B, C, D, BX, SUM
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A(1), B( N1C,1), C( N1C,1), D( N2C,1), BX( N1C,1), IP(
+ &1), IX(1)
+ IF( N2C.EQ.0) RETURN
+ IBFL=14
+C CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16
+ IF( ICASX.LT.3) GOTO 1
+ CALL REBLK( B, C, N1C, NPBX, N2C)
+ IBFL=16
+ 1 NPB= NPBL
+C COMPUTE INV(A)B AND WRITE ON TAPE14
+ IF( ICASX.EQ.2) REWIND 14
+ DO 2 IB=1, NBBL
+ IF( IB.EQ. NBBL) NPB= NLBL
+ IF( ICASX.GT.1) READ( IBFL) (( BX( I, J), I=1, N1C), J=1, NPB)
+ CALL SOLVES( A, IP, BX, N1C, NPB, NP, N1, MP, M1,13,13)
+ IF( ICASX.EQ.2) REWIND 14
+ IF( ICASX.GT.1) WRITE( 14) (( BX( I, J), I=1, N1C), J=1, NPB)
+ 2 CONTINUE
+ IF( ICASX.EQ.1) GOTO 3
+ REWIND 11
+ REWIND 12
+ REWIND 15
+ REWIND IBFL
+C COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11
+ 3 NPC= NPBL
+ DO 8 IC=1, NBBL
+ IF( IC.EQ. NBBL) NPC= NLBL
+ IF( ICASX.EQ.1) GOTO 4
+ READ( 15) (( C( I, J), I=1, N1C), J=1, NPC)
+ READ( 12) (( D( I, J), I=1, N2C), J=1, NPC)
+ REWIND 14
+ 4 NPB= NPBL
+ NIC=0
+ DO 7 IB=1, NBBL
+ IF( IB.EQ. NBBL) NPB= NLBL
+ IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
+ DO 6 I=1, NPB
+ II= I+ NIC
+ DO 6 J=1, NPC
+ SUM=(0.,0.)
+ DO 5 K=1, N1C
+ 5 SUM= SUM+ B( K, I)* C( K, J)
+ 6 D( II, J)= D( II, J)- SUM
+ 7 NIC= NIC+ NPBL
+ IF( ICASX.GT.1) WRITE( 11) (( D( I, J), I=1, N2C), J=1, NPBL)
+ 8 CONTINUE
+ IF( ICASX.EQ.1) GOTO 9
+ REWIND 11
+ REWIND 12
+ REWIND 14
+ REWIND 15
+C FACTOR D-C(INV(A)B)
+ 9 N1CP= N1C+1
+ IF( ICASX.GT.1) GOTO 10
+ CALL FACTR( N2C, D, IP( N1CP), N2C)
+ GOTO 13
+ 10 IF( ICASX.EQ.4) GOTO 12
+ NPB= NPBL
+ IC=0
+ DO 11 IB=1, NBBL
+ IF( IB.EQ. NBBL) NPB= NLBL
+ II= IC+1
+ IC= IC+ N2C* NPB
+ 11 READ( 11) ( B( I,1), I= II, IC)
+ REWIND 11
+ CALL FACTR( N2C, B, IP( N1CP), N2C)
+ NIC= N2C* N2C
+ WRITE( 11) ( B( I,1), I=1, NIC)
+ REWIND 11
+ GOTO 13
+ 12 NBLSYS= NBLSYM
+ NPSYS= NPSYM
+ NLSYS= NLSYM
+ ICASS= ICASE
+ NBLSYM= NBBL
+ NPSYM= NPBL
+ NLSYM= NLBL
+ ICASE=3
+ CALL FACIO( B, N2C,1, IX( N1CP),11,12,16,11)
+ CALL LUNSCR( B, N2C,1, IP( N1CP), IX( N1CP),12,11,16)
+ NBLSYM= NBLSYS
+ NPSYM= NPSYS
+ NLSYM= NLSYS
+ ICASE= ICASS
+ 13 RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FACIO( A, NROW, NOP, IP, IU1, IU2, IU3, IU4)
+C ***
+C
+C FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX A
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A( NROW,1), IP( NROW)
+ IT=2* NPSYM* NROW
+ NBM= NBLSYM-1
+ I1=1
+ I2= IT
+ I3= I2+1
+ I4=2* IT
+ TIME=0.
+ REWIND IU1
+ REWIND IU2
+ DO 3 KK=1, NOP
+ KA=( KK-1)* NROW+1
+ IFILE3= IU1
+ IFILE4= IU3
+ DO 2 IXBLK1=1, NBM
+ REWIND IU3
+ REWIND IU4
+ CALL BLCKIN( A, IFILE3, I1, I2,1,17)
+ IXBP= IXBLK1+1
+ DO 1 IXBLK2= IXBP, NBLSYM
+ CALL BLCKIN( A, IFILE3, I3, I4,1,18)
+ CALL SECNDS( T1)
+ CALL LFACTR( A, NROW, IXBLK1, IXBLK2, IP( KA))
+ CALL SECNDS( T2)
+ TIME= TIME+ T2- T1
+ IF( IXBLK2.EQ. IXBP) CALL BLCKOT( A, IU2, I1, I2,1,19)
+ IF( IXBLK1.EQ. NBM.AND. IXBLK2.EQ. NBLSYM) IFILE4= IU2
+ CALL BLCKOT( A, IFILE4, I3, I4,1,20)
+ 1 CONTINUE
+ IFILE3= IU3
+ IFILE4= IU4
+ IF(( IXBLK1/2)*2.NE. IXBLK1) GOTO 2
+ IFILE3= IU4
+ IFILE4= IU3
+ 2 CONTINUE
+ 3 CONTINUE
+ REWIND IU1
+ REWIND IU2
+ REWIND IU3
+ REWIND IU4
+ WRITE (6,4) TIME
+C
+ RETURN
+ 4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FACTR( N, A, IP, NDIM)
+C ***
+C
+C SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX
+C AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
+C PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN
+C NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN RALSTONS
+C TEXT. (MATRIX TRANSPOSED.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, D, ARJ
+ DIMENSION A( NDIM, NDIM), IP( NDIM)
+ COMMON /SCRATM/ D( N2M)
+ INTEGER R, RM1, RP1, PJ, PR
+ IFLG=0
+C
+C STEP 1
+C
+ DO 9 R=1, N
+ DO 1 K=1, N
+ D( K)= A( R, K)
+C
+C STEPS 2 AND 3
+C
+ 1 CONTINUE
+ RM1= R-1
+ IF( RM1.LT.1) GOTO 4
+ DO 3 J=1, RM1
+ PJ= IP( J)
+ ARJ= D( PJ)
+ A( R, J)= ARJ
+ D( PJ)= D( J)
+ JP1= J+1
+ DO 2 I= JP1, N
+ D( I)= D( I)- A( J, I)* ARJ
+ 2 CONTINUE
+ 3 CONTINUE
+C
+C STEP 4
+C
+ 4 CONTINUE
+ DMAX= REAL( D( R)* CONJG( D( R)))
+ IP( R)= R
+ RP1= R+1
+ IF( RP1.GT. N) GOTO 6
+ DO 5 I= RP1, N
+ ELMAG= REAL( D( I)* CONJG( D( I)))
+ IF( ELMAG.LT. DMAX) GOTO 5
+ DMAX= ELMAG
+ IP( R)= I
+ 5 CONTINUE
+ 6 CONTINUE
+ IF( DMAX.LT.1.D-10) IFLG=1
+ PR= IP( R)
+ A( R, R)= D( PR)
+C
+C STEP 5
+C
+ D( PR)= D( R)
+ IF( RP1.GT. N) GOTO 8
+ ARJ=1./ A( R, R)
+ DO 7 I= RP1, N
+ A( R, I)= D( I)* ARJ
+ 7 CONTINUE
+ 8 CONTINUE
+ IF( IFLG.EQ.0) GOTO 9
+ WRITE (6,10) R, DMAX
+ IFLG=0
+ 9 CONTINUE
+C
+ RETURN
+ 10 FORMAT(1H ,'PIVOT(',I3,')=',1P,E16.8)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FACTRS( NP, NROW, A, IP, IX, IU1, IU2, IU3, IU4)
+C ***
+C
+C FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM
+C MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR
+C MATRICIES. IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE
+C COMPLETE MATRIX.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX A
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A(1), IP( NROW), IX( NROW)
+ NOP= NROW/ NP
+ IF( ICASE.GT.2) GOTO 2
+ DO 1 KK=1, NOP
+ KA=( KK-1)* NP+1
+ 1 CALL FACTR( NP, A( KA), IP( KA), NROW)
+ RETURN
+C
+C FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY
+C EXISTS.
+C
+ 2 IF( ICASE.GT.3) GOTO 3
+ CALL FACIO( A, NROW, NOP, IX, IU1, IU2, IU3, IU4)
+ CALL LUNSCR( A, NROW, NOP, IP, IX, IU2, IU3, IU4)
+C
+C REWRITE THE MATRICES BY COLUMNS ON TAPE 13
+C
+ RETURN
+ 3 I2=2* NPBLK* NROW
+ REWIND IU2
+ DO 5 K=1, NOP
+ REWIND IU1
+ ICOLS= NPBLK
+ IR2= K* NP
+ IR1= IR2- NP+1
+ DO 5 L=1, NBLOKS
+ IF( NBLOKS.EQ.1.AND. K.GT.1) GOTO 4
+ CALL BLCKIN( A, IU1,1, I2,1,602)
+ IF( L.EQ. NBLOKS) ICOLS= NLAST
+ 4 IRR1= IR1
+ IRR2= IR2
+ DO 5 ICOLDX=1, ICOLS
+ WRITE( IU2) ( A( I), I= IRR1, IRR2)
+ IRR1= IRR1+ NROW
+ IRR2= IRR2+ NROW
+ 5 CONTINUE
+ REWIND IU1
+ REWIND IU2
+ IF( ICASE.EQ.5) GOTO 8
+ REWIND IU3
+ IRR1= NP* NP
+ DO 7 KK=1, NOP
+ IR1=1- NP
+ IR2=0
+ DO 6 I=1, NP
+ IR1= IR1+ NP
+ IR2= IR2+ NP
+ 6 READ( IU2) ( A( J), J= IR1, IR2)
+ KA=( KK-1)* NP+1
+ CALL FACTR( NP, A, IP( KA), NP)
+ WRITE( IU3) ( A( I), I=1, IRR1)
+ 7 CONTINUE
+ REWIND IU2
+ REWIND IU3
+ RETURN
+ 8 I2=2* NPSYM* NP
+ DO 10 KK=1, NOP
+ J2= NPSYM
+ DO 10 L=1, NBLSYM
+ IF( L.EQ. NBLSYM) J2= NLSYM
+ IR1=1- NP
+ IR2=0
+ DO 9 J=1, J2
+ IR1= IR1+ NP
+ IR2= IR2+ NP
+ 9 READ( IU2) ( A( I), I= IR1, IR2)
+ 10 CALL BLCKOT( A, IU1,1, I2,1,193)
+ REWIND IU1
+ CALL FACIO( A, NP, NOP, IX, IU1, IU2, IU3, IU4)
+ CALL LUNSCR( A, NP, NOP, IP, IX, IU2, IU3, IU4)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+C COMPLEX FUNCTION FBAR( P)
+ FUNCTION FBAR( P)
+C ***
+C
+C FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P
+C
+C IMPLICIT REAL (A-H,O-Z)
+ COMPLEX Z, ZS, SUM, POW, TERM, P, FJ, FBAR
+ DIMENSION FJX(2)
+ EQUIVALENCE(FJ,FJX)
+ DATA TOSP/1.128379167D+0/, ACCS/1.D-12/, SP/1.772453851D+0/,
+ &FJX/0.,1./
+ Z= FJ* SQRT( P)
+C
+C SERIES EXPANSION
+C
+ IF( ABS( Z).GT.3.) GOTO 3
+ ZS= Z* Z
+ SUM= Z
+ POW= Z
+ DO 1 I=1,100
+ POW=- POW* ZS/ DFLOAT( I)
+ TERM= POW/(2.* I+1.)
+ SUM= SUM+ TERM
+ TMS= REAL( TERM* CONJG( TERM))
+ SMS= REAL( SUM* CONJG( SUM))
+ IF( TMS/ SMS.LT. ACCS) GOTO 2
+ 1 CONTINUE
+ 2 FBAR=1.-(1.- SUM* TOSP)* Z* EXP( ZS)* SP
+C
+C ASYMPTOTIC EXPANSION
+C
+ RETURN
+ 3 IF( REAL( Z).GE.0.) GOTO 4
+ MINUS=1
+ Z=- Z
+ GOTO 5
+ 4 MINUS=0
+ 5 ZS=.5/( Z* Z)
+ SUM=(0.,0.)
+ TERM=(1.,0.)
+ DO 6 I=1,6
+ TERM=- TERM*(2.* I-1.)* ZS
+ 6 SUM= SUM+ TERM
+ IF( MINUS.EQ.1) SUM= SUM-2.* SP* Z* EXP( Z* Z)
+ FBAR=- SUM
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FBLOCK( NROW, NCOL, IMAX, IRNGF, IPSYM)
+C ***
+C FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY
+C MATRIX (A)
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX SSX, DETER
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SMAT/ SSX(16,16)
+ IMX1= IMAX- IRNGF
+ IF( NROW* NCOL.GT. IMX1) GOTO 2
+ NBLOKS=1
+ NPBLK= NROW
+ NLAST= NROW
+ IMAT= NROW* NCOL
+ IF( NROW.NE. NCOL) GOTO 1
+ ICASE=1
+ RETURN
+ 1 ICASE=2
+ GOTO 5
+ 2 IF( NROW.NE. NCOL) GOTO 3
+ ICASE=3
+ NPBLK= IMAX/(2* NCOL)
+ NPSYM= IMX1/ NCOL
+ IF( NPSYM.LT. NPBLK) NPBLK= NPSYM
+ IF( NPBLK.LT.1) GOTO 12
+ NBLOKS=( NROW-1)/ NPBLK
+ NLAST= NROW- NBLOKS* NPBLK
+ NBLOKS= NBLOKS+1
+ NBLSYM= NBLOKS
+ NPSYM= NPBLK
+ NLSYM= NLAST
+ IMAT= NPBLK* NCOL
+ WRITE (6,14) NBLOKS, NPBLK, NLAST
+ GOTO 11
+ 3 NPBLK= IMAX/ NCOL
+ IF( NPBLK.LT.1) GOTO 12
+ IF( NPBLK.GT. NROW) NPBLK= NROW
+ NBLOKS=( NROW-1)/ NPBLK
+ NLAST= NROW- NBLOKS* NPBLK
+ NBLOKS= NBLOKS+1
+ WRITE (6,14) NBLOKS, NPBLK, NLAST
+ IF( NROW* NROW.GT. IMX1) GOTO 4
+ ICASE=4
+ NBLSYM=1
+ NPSYM= NROW
+ NLSYM= NROW
+ IMAT= NROW* NROW
+ WRITE (6,15)
+ GOTO 5
+ 4 ICASE=5
+ NPSYM= IMAX/(2* NROW)
+ NBLSYM= IMX1/ NROW
+ IF( NBLSYM.LT. NPSYM) NPSYM= NBLSYM
+ IF( NPSYM.LT.1) GOTO 12
+ NBLSYM=( NROW-1)/ NPSYM
+ NLSYM= NROW- NBLSYM* NPSYM
+ NBLSYM= NBLSYM+1
+ WRITE (6,16) NBLSYM, NPSYM, NLSYM
+ IMAT= NPSYM* NROW
+ 5 NOP= NCOL/ NROW
+ IF( NOP* NROW.NE. NCOL) GOTO 13
+C
+C SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY.
+C
+ IF( IPSYM.GT.0) GOTO 7
+ PHAZ=6.2831853072D+0/ NOP
+ DO 6 I=2, NOP
+ DO 6 J= I, NOP
+ ARG= PHAZ* DFLOAT( I-1)* DFLOAT( J-1)
+ SSX( I, J)= CMPLX( COS( ARG), SIN( ARG))
+ 6 SSX( J, I)= SSX( I, J)
+C
+C SET UP SSX MATRIX FOR PLANE SYMMETRY
+C
+ GOTO 11
+ 7 KK=1
+ SSX(1,1)=(1.,0.)
+ IF(( NOP.EQ.2).OR.( NOP.EQ.4).OR.( NOP.EQ.8)) GOTO 8
+ STOP
+ 8 KA= NOP/2
+ IF( NOP.EQ.8) KA=3
+ DO 10 K=1, KA
+ DO 9 I=1, KK
+ DO 9 J=1, KK
+ DETER= SSX( I, J)
+ SSX( I, J+ KK)= DETER
+ SSX( I+ KK, J+ KK)=- DETER
+ 9 SSX( I+ KK, J)= DETER
+ 10 KK= KK*2
+ 11 RETURN
+ 12 WRITE (6,17) NROW, NCOL
+ STOP
+ 13 WRITE (6,18) NROW, NCOL
+C
+ STOP
+ 14 FORMAT(//' MATRIX FILE STORAGE - NO. BLOCKS=',I5,' COLUMNS PE',
+ &'R BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
+ 15 FORMAT(' SUBMATRICIES FIT IN CORE')
+ 16 FORMAT(' SUBMATRIX PARTITIONING - NO. BLOCKS=',I5,' COLUMNS P',
+ &'ER BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
+ 17 FORMAT(' ERROR - INSUFFICIENT STORAGE FOR MATRIX',2I5)
+ 18 FORMAT(' SYMMETRY ERROR - NROW,NCOL=',2I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
+C ***
+C FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
+C OUT-OF-CORE STORAGE.
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ IRESX= IRESRV- IMAT
+ NBLN= NEQ* NEQ2
+ NDLN= NEQ2* NEQ2
+ NBCD=2* NBLN+ NDLN
+ IF( NBCD.GT. IRESX) GOTO 1
+ ICASX=1
+ IB11= IMAT+1
+ GOTO 2
+ 1 IF( ICASE.LT.3) GOTO 3
+ IF( NBCD.GT. IRESRV.OR. NBLN.GT. IRESX) GOTO 3
+ ICASX=2
+ IB11=1
+ 2 NBBX=1
+ NPBX= NEQ
+ NLBX= NEQ
+ NBBL=1
+ NPBL= NEQ2
+ NLBL= NEQ2
+ GOTO 5
+ 3 IR= IRESRV
+ IF( ICASE.LT.3) IR= IRESX
+ ICASX=3
+ IF( NDLN.GT. IR) ICASX=4
+ NBCD=2* NEQ+ NEQ2
+ NPBL= IR/ NBCD
+ NLBL= IR/(2* NEQ2)
+ IF( NLBL.LT. NPBL) NPBL= NLBL
+ IF( ICASE.LT.3) GOTO 4
+ NLBL= IRESX/ NEQ
+ IF( NLBL.LT. NPBL) NPBL= NLBL
+ 4 IF( NPBL.LT.1) GOTO 6
+ NBBL=( NEQ2-1)/ NPBL
+ NLBL= NEQ2- NBBL* NPBL
+ NBBL= NBBL+1
+ NBLN= NEQ* NPBL
+ IR= IR- NBLN
+ NPBX= IR/ NEQ2
+ IF( NPBX.GT. NEQ) NPBX= NEQ
+ NBBX=( NEQ-1)/ NPBX
+ NLBX= NEQ- NBBX* NPBX
+ NBBX= NBBX+1
+ IB11=1
+ IF( ICASE.LT.3) IB11= IMAT+1
+ 5 IC11= IB11+ NBLN
+ ID11= IC11+ NBLN
+ IX11= IMAT+1
+ WRITE (6,11) NEQ2
+ IF( ICASX.EQ.1) RETURN
+ WRITE (6,8) ICASX
+ WRITE (6,9) NBBX, NPBX, NLBX
+ WRITE (6,10) NBBL, NPBL, NLBL
+ RETURN
+ 6 WRITE (6,7) IRESRV, IMAT, NEQ, NEQ2
+C
+ STOP
+ 7 FORMAT(55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
+ &,' IRESRV,IMAT,NEQ,NEQ2 =',4I5)
+ 8 FORMAT(' FILE STORAGE FOR NEW MATRIX SECTIONS - ICASX =', I2)
+ 9 FORMAT(' B FILLED BY ROWS -',15X,'NO. BLOCKS =',I3,3X,
+ & 'ROWS PER BLOCK =', I3, ' ROWS IN LAST BLOCK =', I3)
+ 10 FORMAT(' B BY COLUMNS, C AND D BY ROWS - NO. BLOCKS =',I3,
+ & ' R/C PER BLOCK =', I3, ' R/C IN LAST BLOCK =', I3)
+ 11 FORMAT(//,' N.G.F. - NUMBER OF NEW UNKNOWNS IS', I4)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FFLD( THET, PHI, ETH, EPH)
+C ***
+C
+C FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
+C THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CIX, CIY, CIZ, EXA, ETH, EPH, CONST, CCX, CCY, CCZ,
+ &CDP, CUR
+ COMPLEX ZRATI, ZRSIN, RRV, RRH, RRV1, RRH1, RRV2, RRH2,
+ &ZRATI2, TIX, TIY, TIZ, T1, ZSCRN, EX, EY, EZ, GX, GY, GZ, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ DIMENSION CAB(1), SAB(1), CONSX(2)
+ EQUIVALENCE(CAB,ALP),(SAB,BET),(CONST,CONSX)
+ DATA PI, TP, ETA/3.141592654D+0,6.283185308D+0,376.73/
+ DATA CONSX/0.,-29.97922085D+0/
+ PHX=- SIN( PHI)
+ PHY= COS( PHI)
+ ROZ= COS( THET)
+ ROZS= ROZ
+ THX= ROZ* PHY
+ THY=- ROZ* PHX
+ THZ=- SIN( THET)
+ ROX=- THZ* PHY
+ ROY= THZ* PHX
+C
+C LOOP FOR STRUCTURE IMAGE IF ANY
+C
+ IF( N.EQ.0) GOTO 20
+C
+C CALCULATION OF REFLECTION COEFFECIENTS
+C
+ DO 19 K=1, KSYMP
+ IF( K.EQ.1) GOTO 4
+C
+C FOR PERFECT GROUND
+C
+ IF( IPERF.NE.1) GOTO 1
+ RRV=-(1.,0.)
+ RRH=-(1.,0.)
+C
+C FOR INFINITE PLANAR GROUND
+C
+ GOTO 2
+ 1 ZRSIN= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
+ RRV=-( ROZ- ZRATI* ZRSIN)/( ROZ+ ZRATI* ZRSIN)
+ RRH=( ZRATI* ROZ- ZRSIN)/( ZRATI* ROZ+ ZRSIN)
+C
+C FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
+C
+ 2 IF( IFAR.LE.1) GOTO 3
+ RRV1= RRV
+ RRH1= RRH
+ TTHET= TAN( THET)
+ IF( IFAR.EQ.4) GOTO 3
+ ZRSIN= SQRT(1.- ZRATI2* ZRATI2* THZ* THZ)
+ RRV2=-( ROZ- ZRATI2* ZRSIN)/( ROZ+ ZRATI2* ZRSIN)
+ RRH2=( ZRATI2* ROZ- ZRSIN)/( ZRATI2* ROZ+ ZRSIN)
+ DARG=- TP*2.* CH* ROZ
+ 3 ROZ=- ROZ
+ CCX= CIX
+ CCY= CIY
+ CCZ= CIZ
+ 4 CIX=(0.,0.)
+ CIY=(0.,0.)
+C
+C LOOP OVER STRUCTURE SEGMENTS
+C
+ CIZ=(0.,0.)
+ DO 17 I=1, N
+ OMEGA=-( ROX* CAB( I)+ ROY* SAB( I)+ ROZ* SALP( I))
+ EL= PI* SI( I)
+ SILL= OMEGA* EL
+ TOP= EL+ SILL
+ BOT= EL- SILL
+ IF( ABS( OMEGA).LT.1.D-7) GOTO 5
+ A=2.* SIN( SILL)/ OMEGA
+ GOTO 6
+ 5 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
+ 6 IF( ABS( TOP).LT.1.D-7) GOTO 7
+ TOO= SIN( TOP)/ TOP
+ GOTO 8
+ 7 TOO=1.- TOP* TOP/6.
+ 8 IF( ABS( BOT).LT.1.D-7) GOTO 9
+ BOO= SIN( BOT)/ BOT
+ GOTO 10
+ 9 BOO=1.- BOT* BOT/6.
+ 10 B= EL*( BOO- TOO)
+ C= EL*( BOO+ TOO)
+ RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
+ RI= A* AII( I)- B* BIR( I)+ C* CII( I)
+ ARG= TP*( X( I)* ROX+ Y( I)* ROY+ Z( I)* ROZ)
+ IF( K.EQ.2.AND. IFAR.GE.2) GOTO 11
+C
+C SUMMATION FOR FAR FIELD INTEGRAL
+C
+ EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
+ CIX= CIX+ EXA* CAB( I)
+ CIY= CIY+ EXA* SAB( I)
+ CIZ= CIZ+ EXA* SALP( I)
+C
+C CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
+C PROBLEMS.
+C
+ GOTO 17
+C
+C SPECULAR POINT DISTANCE
+C
+ 11 DR= Z( I)* TTHET
+ D= DR* PHY+ X( I)
+ IF( IFAR.EQ.2) GOTO 13
+ D= SQRT( D* D+( Y( I)- DR* PHX)**2)
+ IF( IFAR.EQ.3) GOTO 13
+C
+C RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
+C
+ IF(( SCRWL- D).LT.0.) GOTO 12
+ D= D+ T2
+ ZSCRN= T1* D* LOG( D/ T2)
+ ZSCRN=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
+ ZRSIN= SQRT(1.- ZSCRN* ZSCRN* THZ* THZ)
+ RRV=( ROZ+ ZSCRN* ZRSIN)/(- ROZ+ ZSCRN* ZRSIN)
+ RRH=( ZSCRN* ROZ+ ZRSIN)/( ZSCRN* ROZ- ZRSIN)
+ GOTO 16
+ 12 IF( IFAR.EQ.4) GOTO 14
+ IF( IFAR.EQ.5) D= DR* PHY+ X( I)
+ 13 IF(( CL- D).LE.0.) GOTO 15
+ 14 RRV= RRV1
+ RRH= RRH1
+ GOTO 16
+ 15 RRV= RRV2
+ RRH= RRH2
+ ARG= ARG+ DARG
+C
+C CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
+C FOR CLIFF AND GROUND SCREEN PROBLEMS
+C
+ 16 EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
+ TIX= EXA* CAB( I)
+ TIY= EXA* SAB( I)
+ TIZ= EXA* SALP( I)
+ CDP=( TIX* PHX+ TIY* PHY)*( RRH- RRV)
+ CIX= CIX+ TIX* RRV+ CDP* PHX
+ CIY= CIY+ TIY* RRV+ CDP* PHY
+ CIZ= CIZ- TIZ* RRV
+ 17 CONTINUE
+ IF( K.EQ.1) GOTO 19
+C
+C CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
+C
+ IF( IFAR.GE.2) GOTO 18
+ CDP=( CIX* PHX+ CIY* PHY)*( RRH- RRV)
+ CIX= CCX+ CIX* RRV+ CDP* PHX
+ CIY= CCY+ CIY* RRV+ CDP* PHY
+ CIZ= CCZ- CIZ* RRV
+ GOTO 19
+ 18 CIX= CIX+ CCX
+ CIY= CIY+ CCY
+ CIZ= CIZ+ CCZ
+ 19 CONTINUE
+ IF( M.GT.0) GOTO 21
+ ETH=( CIX* THX+ CIY* THY+ CIZ* THZ)* CONST
+ EPH=( CIX* PHX+ CIY* PHY)* CONST
+ RETURN
+ 20 CIX=(0.,0.)
+ CIY=(0.,0.)
+ CIZ=(0.,0.)
+C
+C ELECTRIC FIELD COMPONENTS
+C
+ 21 ROZ= ROZS
+ RFL=-1.
+ DO 25 IP=1, KSYMP
+ RFL=- RFL
+ RRZ= ROZ* RFL
+ CALL FFLDS( ROX, ROY, RRZ, CUR( N+1), GX, GY, GZ)
+ IF( IP.EQ.2) GOTO 22
+ EX= GX
+ EY= GY
+ EZ= GZ
+ GOTO 25
+ 22 IF( IPERF.NE.1) GOTO 23
+ GX=- GX
+ GY=- GY
+ GZ=- GZ
+ GOTO 24
+ 23 RRV= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
+ RRH= ZRATI* ROZ
+ RRH=( RRH- RRV)/( RRH+ RRV)
+ RRV= ZRATI* RRV
+ RRV=-( ROZ- RRV)/( ROZ+ RRV)
+ ETH=( GX* PHX+ GY* PHY)*( RRH- RRV)
+ GX= GX* RRV+ ETH* PHX
+ GY= GY* RRV+ ETH* PHY
+ GZ= GZ* RRV
+ 24 EX= EX+ GX
+ EY= EY+ GY
+ EZ= EZ- GZ
+ 25 CONTINUE
+ EX= EX+ CIX* CONST
+ EY= EY+ CIY* CONST
+ EZ= EZ+ CIZ* CONST
+ ETH= EX* THX+ EY* THY+ EZ* THZ
+ EPH= EX* PHX+ EY* PHY
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE FFLDS( ROX, ROY, ROZ, SCUR, EX, EY, EZ)
+C ***
+C CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
+C SURFACE CURRENTS
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CT, CONS, SCUR, EX, EY, EZ
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ DIMENSION XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2)
+ EQUIVALENCE(XS,X),(YS,Y),(ZS,Z),(S,BI),(CONS,CONSX)
+ DATA TPI/6.283185308D+0/, CONSX/0.,188.365/
+ EX=(0.,0.)
+ EY=(0.,0.)
+ EZ=(0.,0.)
+ I= LD+1
+ DO 1 J=1, M
+ I= I-1
+ ARG= TPI*( ROX* XS( I)+ ROY* YS( I)+ ROZ* ZS( I))
+ CT= CMPLX( COS( ARG)* S( I), SIN( ARG)* S( I))
+ K=3* J
+ EX= EX+ SCUR( K-2)* CT
+ EY= EY+ SCUR( K-1)* CT
+ EZ= EZ+ SCUR( K)* CT
+ 1 CONTINUE
+ CT= ROX* EX+ ROY* EY+ ROZ* EZ
+ EX= CONS*( CT* ROX- EX)
+ EY= CONS*( CT* ROY- EY)
+ EZ= CONS*( CT* ROZ- EZ)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GF( ZK, CO, SI)
+C ***
+C
+C GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /TMI/ ZPK, RKB2, IJ
+ ZDK= ZK- ZPK
+ RK= SQRT( RKB2+ ZDK* ZDK)
+ SI= SIN( RK)/ RK
+ IF( IJ) 1,2,1
+ 1 CO= COS( RK)/ RK
+ RETURN
+ 2 IF( RK.LT..2) GOTO 3
+ CO=( COS( RK)-1.)/ RK
+ RETURN
+ 3 RKS= RK* RK
+ CO=((-1.38888889D-3* RKS+4.16666667D-2)* RKS-.5)* RK
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GFIL( IPRT)
+C ***
+C
+C GFIL READS THE N.G.F. FILE
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ integer*4 COM
+ COMPLEX CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
+ &EPSCF, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /CMB/ CM(1000000)
+ COMMON /ANGL/ SALP( NM)
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
+ &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SMAT/ SSX(16,16)
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ COMMON /SAVE/ IP( N2M), KCOM, COM(20,5), EPSR, SIG, SCRWLT,
+ &SCRWRT, FMHZ
+ DATA IGFL/20/
+ REWIND IGFL
+ READ( IGFL) N1, NP, M1, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF,
+ &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLODF, KCOM
+ N= N1
+ M= M1
+ N2= N1+1
+ M2= M1+1
+C READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS
+ IF( N1.EQ.0) GOTO 2
+ READ( IGFL) ( X( I), I=1, N1),( Y( I), I=1, N1),( Z( I), I=1, N1)
+ &
+ READ( IGFL) ( SI( I), I=1, N1),( BI( I), I=1, N1),( ALP( I), I=1,
+ & N1)
+ READ( IGFL) ( BET( I), I=1, N1),( SALP( I), I=1, N1)
+ READ( IGFL) ( ICON1( I), I=1, N1),( ICON2( I), I=1, N1)
+ READ( IGFL) ( ITAG( I), I=1, N1)
+ IF( NLODF.NE.0) READ( IGFL) ( ZARRAY( I), I=1, N1)
+ DO 1 I=1, N1
+ XI= X( I)* WLAM
+ YI= Y( I)* WLAM
+ ZI= Z( I)* WLAM
+ DX= SI( I)*.5* WLAM
+ X( I)= XI- ALP( I)* DX
+ Y( I)= YI- BET( I)* DX
+ Z( I)= ZI- SALP( I)* DX
+ SI( I)= XI+ ALP( I)* DX
+ ALP( I)= YI+ BET( I)* DX
+ BET( I)= ZI+ SALP( I)* DX
+ BI( I)= BI( I)* WLAM
+ 1 CONTINUE
+ 2 IF( M1.EQ.0) GOTO 4
+C READ PATCH DATA AND CONVERT TO METERS
+ J= LD- M1+1
+ READ( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J,
+ &LD)
+ READ( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I=
+ & J, LD)
+ READ( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
+ READ( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
+ READ( IGFL) ( ITAG( I), I= J, LD)
+ DX= WLAM* WLAM
+ DO 3 I= J, LD
+ X( I)= X( I)* WLAM
+ Y( I)= Y( I)* WLAM
+ Z( I)= Z( I)* WLAM
+ 3 BI( I)= BI( I)* DX
+ 4 READ( IGFL) ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM,
+ &IMAT
+ IF( IPERF.EQ.2) READ( IGFL) AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
+ & YSA, NXA, NYA
+ NEQ= N1+2* M1
+ NPEQ= NP+2* MP
+ NOP= NEQ/ NPEQ
+ IF( NOP.GT.1) READ( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
+C READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE
+ READ( IGFL) ( IP( I), I=1, NEQ), COM
+ IF( ICASE.GT.2) GOTO 5
+ IOUT= NEQ* NPEQ
+ READ( IGFL) ( CM( I), I=1, IOUT)
+ GOTO 10
+ 5 REWIND 13
+ IF( ICASE.NE.4) GOTO 7
+ IOUT= NPEQ* NPEQ
+ DO 6 K=1, NOP
+ READ( IGFL) ( CM( J), J=1, IOUT)
+ 6 WRITE( 13) ( CM( J), J=1, IOUT)
+ GOTO 9
+ 7 IOUT= NPSYM* NPEQ*2
+ NBL2=2* NBLSYM
+ DO 8 IOP=1, NOP
+ DO 8 I=1, NBL2
+ CALL BLCKIN( CM, IGFL,1, IOUT,1,206)
+ 8 CALL BLCKOT( CM,13,1, IOUT,1,205)
+ 9 REWIND 13
+C WRITE(6,N) G.F. HEADING
+ 10 REWIND IGFL
+ WRITE (6,16)
+ WRITE (6,14)
+ WRITE (6,14)
+ WRITE (6,17)
+ WRITE (6,18) N1, M1
+ IF( NOP.GT.1) WRITE (6,19) NOP
+ WRITE (6,20) IMAT, ICASE
+ IF( ICASE.LT.3) GOTO 11
+ NBL2= NEQ* NPEQ
+ WRITE (6,21) NBL2
+ 11 WRITE (6,22) FMHZ
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE (6,23)
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE (6,27)
+ IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE (6,28)
+ IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE (6,24) EPSR, SIG
+ WRITE (6,17)
+ DO 12 J=1, KCOM
+ 12 WRITE (6,15) ( COM( I, J), I=1,19)
+ WRITE (6,17)
+ WRITE (6,14)
+ WRITE (6,14)
+ WRITE (6,16)
+ IF( IPRT.EQ.0) RETURN
+ WRITE (6,25)
+ DO 13 I=1, N1
+ 13 WRITE (6,26) I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I)
+C
+ RETURN
+ 14 FORMAT(5X,'**************************************************',
+ &'**********************************')
+ 15 FORMAT(5X,3H** ,19A4,3H **)
+ 16 FORMAT(////)
+ 17 FORMAT(5X,2H**,80X,2H**)
+ 18 FORMAT(5X,'** NUMERICAL GREEN S FUNCTION',53X,2H**,/,5X,'** NO',
+ &'. SEGMENTS =',I4,10X,'NO. PATCHES =',I4,34X,2H**)
+ 19 FORMAT(5X,'** NO. SYMMETRIC SECTIONS =',I4,51X,2H**)
+ 20 FORMAT(5X,'** N.G.F. MATRIX - CORE STORAGE =',I7,' COMPLEX NU',
+ &'MBERS, CASE',I2,16X,2H**)
+ 21 FORMAT(5X,2H**,19X,'MATRIX SIZE =',I7,' COMPLEX NUMBERS',25X,'**')
+ 22 FORMAT(5X,'** FREQUENCY =',1P,E12.5,' MHZ.',51X,2H**)
+ 23 FORMAT(5X,'** PERFECT GROUND',65X,2H**)
+ 24 FORMAT(5X,'** GROUND PARAMETERS - DIELECTRIC CONSTANT =',1P,E12.5,
+ &26X,'**',/,5X,'**',21X,'CONDUCTIVITY =',E12.5,' MHOS/M.',25X,'**')
+ 25 FORMAT(39X,'NUMERICAL GREEN S FUNCTION DATA',/,41X,'COORDINATES',
+ &' OF SEGMENT ENDS',/,51X,'(METERS)',/,5X,'SEG.',11X,
+ &'- - - END ON''E - - -',26X,'- - - END TWO - - -',/,6X,3HNO.,6X,1
+ &HX,14X,1HY,14X,1HZ,14X,1HX,14X,1HY,14X,1HZ)
+ 26 FORMAT(1X,I7,1P,6E15.6)
+ 27 FORMAT(5X,'** FINITE GROUND. REFLECTION COEFFICIENT APPROXIMAT',
+ &'ION',27X,2H**)
+ 28 FORMAT(5X,'** FINITE GROUND. SOMMERFELD SOLUTION',44X,'**')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GFLD( RHO, PHI, RZ, ETH, EPI, ERD, UX, KSYMP)
+C ***
+C
+C GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CUR, EPI, CIX, CIY, CIZ, EXA, XX1, XX2, U, U2, ERV,
+ &EZV, ERH, EPH
+ COMPLEX EZH, EX, EY, ETH, UX, ERD
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
+ DIMENSION CAB(1), SAB(1)
+ EQUIVALENCE(CAB(1),ALP(1)),(SAB(1),BET(1))
+ DATA PI, TP/3.141592654D+0,6.283185308D+0/
+ R= SQRT( RHO* RHO+ RZ* RZ)
+ IF( KSYMP.EQ.1) GOTO 1
+ IF( ABS( UX).GT..5) GOTO 1
+ IF( R.GT.1.E5) GOTO 1
+C
+C COMPUTATION OF SPACE WAVE ONLY
+C
+ GOTO 4
+ 1 IF( RZ.LT.1.D-20) GOTO 2
+ THET= ATAN( RHO/ RZ)
+ GOTO 3
+ 2 THET= PI*.5
+ 3 CALL FFLD( THET, PHI, ETH, EPI)
+ ARG=- TP* R
+ EXA= CMPLX( COS( ARG), SIN( ARG))/ R
+ ETH= ETH* EXA
+ EPI= EPI* EXA
+ ERD=(0.,0.)
+C
+C COMPUTATION OF SPACE AND GROUND WAVES.
+C
+ RETURN
+ 4 U= UX
+ U2= U* U
+ PHX=- SIN( PHI)
+ PHY= COS( PHI)
+ RX= RHO* PHY
+ RY=- RHO* PHX
+ CIX=(0.,0.)
+ CIY=(0.,0.)
+C
+C SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS
+C
+ CIZ=(0.,0.)
+ DO 17 I=1, N
+ DX= CAB( I)
+ DY= SAB( I)
+ DZ= SALP( I)
+ RIX= RX- X( I)
+ RIY= RY- Y( I)
+ RHS= RIX* RIX+ RIY* RIY
+ RHP= SQRT( RHS)
+ IF( RHP.LT.1.D-6) GOTO 5
+ RHX= RIX/ RHP
+ RHY= RIY/ RHP
+ GOTO 6
+ 5 RHX=1.
+ RHY=0.
+ 6 CALP=1.- DZ* DZ
+ IF( CALP.LT.1.D-6) GOTO 7
+ CALP= SQRT( CALP)
+ CBET= DX/ CALP
+ SBET= DY/ CALP
+ CPH= RHX* CBET+ RHY* SBET
+ SPH= RHY* CBET- RHX* SBET
+ GOTO 8
+ 7 CPH= RHX
+ SPH= RHY
+ 8 EL= PI* SI( I)
+C
+C INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
+C CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS
+C
+ RFL=-1.
+ DO 16 K=1,2
+ RFL=- RFL
+ RIZ= RZ- Z( I)* RFL
+ RXYZ= SQRT( RIX* RIX+ RIY* RIY+ RIZ* RIZ)
+ RNX= RIX/ RXYZ
+ RNY= RIY/ RXYZ
+ RNZ= RIZ/ RXYZ
+ OMEGA=-( RNX* DX+ RNY* DY+ RNZ* DZ* RFL)
+ SILL= OMEGA* EL
+ TOP= EL+ SILL
+ BOT= EL- SILL
+ IF( ABS( OMEGA).LT.1.D-7) GOTO 9
+ A=2.* SIN( SILL)/ OMEGA
+ GOTO 10
+ 9 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
+ 10 IF( ABS( TOP).LT.1.D-7) GOTO 11
+ TOO= SIN( TOP)/ TOP
+ GOTO 12
+ 11 TOO=1.- TOP* TOP/6.
+ 12 IF( ABS( BOT).LT.1.D-7) GOTO 13
+ BOO= SIN( BOT)/ BOT
+ GOTO 14
+ 13 BOO=1.- BOT* BOT/6.
+ 14 B= EL*( BOO- TOO)
+ C= EL*( BOO+ TOO)
+ RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
+ RI= A* AII( I)- B* BIR( I)+ C* CII( I)
+ ARG= TP*( X( I)* RNX+ Y( I)* RNY+ Z( I)* RNZ* RFL)
+ EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)/ TP
+ IF( K.EQ.2) GOTO 15
+ XX1= EXA
+ R1= RXYZ
+ ZMH= RIZ
+ GOTO 16
+ 15 XX2= EXA
+ R2= RXYZ
+ ZPH= RIZ
+C
+C CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND
+C WAVE.
+C
+ 16 CONTINUE
+ CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
+ ERH= ERH* CPH* CALP+ ERV* DZ
+ EPH= EPH* SPH* CALP
+ EZH= EZH* CPH* CALP+ EZV* DZ
+ EX= ERH* RHX- EPH* RHY
+ EY= ERH* RHY+ EPH* RHX
+ CIX= CIX+ EX
+ CIY= CIY+ EY
+ 17 CIZ= CIZ+ EZH
+ ARG=- TP* R
+ EXA= CMPLX( COS( ARG), SIN( ARG))
+ CIX= CIX* EXA
+ CIY= CIY* EXA
+ CIZ= CIZ* EXA
+ RNX= RX/ R
+ RNY= RY/ R
+ RNZ= RZ/ R
+ THX= RNZ* PHY
+ THY=- RNZ* PHX
+ THZ=- RHO/ R
+ ETH= CIX* THX+ CIY* THY+ CIZ* THZ
+ EPI= CIX* PHX+ CIY* PHY
+ ERD= CIX* RNX+ CIY* RNY+ CIZ* RNZ
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GFOUT
+C ***
+C
+C WRITE N.G.F. FILE
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ integer*4 COM
+ COMPLEX CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
+ &EPSCF, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /CMB/ CM(1000000)
+ COMMON /ANGL/ SALP( NM)
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
+ &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SMAT/ SSX(16,16)
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ COMMON /SAVE/ IP( N2M), KCOM, COM(20,5), EPSR, SIG, SCRWLT,
+ &SCRWRT, FMHZ
+ DATA IGFL/20/
+ NEQ= N+2* M
+ NPEQ= NP+2* MP
+ NOP= NEQ/ NPEQ
+ WRITE( IGFL) N, NP, M, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF,
+ &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLOAD, KCOM
+ IF( N.EQ.0) GOTO 1
+ WRITE( IGFL) ( X( I), I=1, N),( Y( I), I=1, N),( Z( I), I=1, N)
+ WRITE( IGFL) ( SI( I), I=1, N),( BI( I), I=1, N),( ALP( I), I=1,
+ &N)
+ WRITE( IGFL) ( BET( I), I=1, N),( SALP( I), I=1, N)
+ WRITE( IGFL) ( ICON1( I), I=1, N),( ICON2( I), I=1, N)
+ WRITE( IGFL) ( ITAG( I), I=1, N)
+ IF( NLOAD.GT.0) WRITE( IGFL) ( ZARRAY( I), I=1, N)
+ 1 IF( M.EQ.0) GOTO 2
+ J= LD- M+1
+ WRITE( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J,
+ & LD)
+ WRITE( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I
+ &= J, LD)
+ WRITE( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
+ WRITE( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
+ WRITE( IGFL) ( ITAG( I), I= J, LD)
+ 2 WRITE( IGFL) ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM,
+ &IMAT
+ IF( IPERF.EQ.2) WRITE( IGFL) AR1, AR2, AR3, EPSCF, DXA, DYA, XSA
+ &, YSA, NXA, NYA
+ IF( NOP.GT.1) WRITE( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
+ WRITE( IGFL) ( IP( I), I=1, NEQ), COM
+ IF( ICASE.GT.2) GOTO 3
+ IOUT= NEQ* NPEQ
+ WRITE( IGFL) ( CM( I), I=1, IOUT)
+ GOTO 12
+ 3 IF( ICASE.NE.4) GOTO 5
+ REWIND 13
+ I= NPEQ* NPEQ
+ DO 4 K=1, NOP
+ READ( 13) ( CM( J), J=1, I)
+ 4 WRITE( IGFL) ( CM( J), J=1, I)
+ REWIND 13
+ GOTO 12
+ 5 REWIND 13
+ REWIND 14
+ IF( ICASE.EQ.5) GOTO 8
+ IOUT= NPBLK* NEQ*2
+ DO 6 I=1, NBLOKS
+ CALL BLCKIN( CM,13,1, IOUT,1,201)
+ 6 CALL BLCKOT( CM, IGFL,1, IOUT,1,202)
+ DO 7 I=1, NBLOKS
+ CALL BLCKIN( CM,14,1, IOUT,1,203)
+ 7 CALL BLCKOT( CM, IGFL,1, IOUT,1,204)
+ GOTO 12
+ 8 IOUT= NPSYM* NPEQ*2
+ DO 11 IOP=1, NOP
+ DO 9 I=1, NBLSYM
+ CALL BLCKIN( CM,13,1, IOUT,1,205)
+ 9 CALL BLCKOT( CM, IGFL,1, IOUT,1,206)
+ DO 10 I=1, NBLSYM
+ CALL BLCKIN( CM,14,1, IOUT,1,207)
+ 10 CALL BLCKOT( CM, IGFL,1, IOUT,1,208)
+ 11 CONTINUE
+ REWIND 13
+ REWIND 14
+ 12 REWIND IGFL
+ WRITE (6,13) IGFL, IMAT
+C
+ RETURN
+ 13 FORMAT(///,' ****NUMERICAL GREEN S FUNCTION FILE ON TAPE',I3,
+ &'****',/,5X,'MATRIX STORAGE -',I7,' COMPLEX NUMBERS',///)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GH( ZK, HR, HI)
+C ***
+C INTEGRAND FOR H FIELD OF A WIRE
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /TMH/ ZPK, RHKS
+ RS= ZK- ZPK
+ RS= RHKS+ RS* RS
+ R= SQRT( RS)
+ CKR= COS( R)
+ SKR= SIN( R)
+ RR2=1./ RS
+ RR3= RR2/ R
+ HR= SKR* RR2+ CKR* RR3
+ HI= CKR* RR2- SKR* RR3
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GWAVE( ERV, EZV, ERH, EZH, EPH)
+C ***
+C
+C GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A
+C CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON
+C (PROC. IRE, SEPT., 1937, PP.1203,1236.)
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX FJ, TPJ, U2, U, RK1, RK2, T1, T2, T3, T4, P1, RV, OMR
+ &, W, F, Q1, RH, V, G, XR1, XR2, X1, X2, X3, X4, X5, X6, X7, EZV,
+ &ERV, EZH, ERH, EPH, XX1, XX2, ECON, FBAR
+ COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
+ DIMENSION FJX(2), TPJX(2), ECONX(2)
+ EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX)
+ DATA FJX/0.,1./, TPJX/0.,6.283185308D+0/
+ DATA ECONX/0.,-188.367/
+ SPPP= ZMH/ R1
+ SPPP2= SPPP* SPPP
+ CPPP2=1.- SPPP2
+ IF( CPPP2.LT.1.D-20) CPPP2=1.D-20
+ CPPP= SQRT( CPPP2)
+ SPP= ZPH/ R2
+ SPP2= SPP* SPP
+ CPP2=1.- SPP2
+ IF( CPP2.LT.1.D-20) CPP2=1.D-20
+ CPP= SQRT( CPP2)
+ RK1=- TPJ* R1
+ RK2=- TPJ* R2
+ T1=1.- U2* CPP2
+ T2= SQRT( T1)
+ T3=(1.-1./ RK1)/ RK1
+ T4=(1.-1./ RK2)/ RK2
+ P1= RK2* U2* T1/(2.* CPP2)
+ RV=( SPP- U* T2)/( SPP+ U* T2)
+ OMR=1.- RV
+ W=1./ OMR
+ W=(4.,0.)* P1* W* W
+ F= FBAR( W)
+ Q1= RK2* T1/(2.* U2* CPP2)
+ RH=( T2- U* SPP)/( T2+ U* SPP)
+ V=1./(1.+ RH)
+ V=(4.,0.)* Q1* V* V
+ G= FBAR( V)
+ XR1= XX1/ R1
+ XR2= XX2/ R2
+ X1= CPPP2* XR1
+ X2= RV* CPP2* XR2
+ X3= OMR* CPP2* F* XR2
+ X4= U* T2* SPP*2.* XR2/ RK2
+ X5= XR1* T3*(1.-3.* SPPP2)
+ X6= XR2* T4*(1.-3.* SPP2)
+ EZV=( X1+ X2+ X3- X4- X5- X6)* ECON
+ X1= SPPP* CPPP* XR1
+ X2= RV* SPP* CPP* XR2
+ X3= CPP* OMR* U* T2* F* XR2
+ X4= SPP* CPP* OMR* XR2/ RK2
+ X5=3.* SPPP* CPPP* T3* XR1
+ X6= CPP* U* T2* OMR* XR2/ RK2*.5
+ X7=3.* SPP* CPP* T4* XR2
+ ERV=-( X1+ X2- X3+ X4- X5+ X6- X7)* ECON
+ EZH=-( X1- X2+ X3- X4- X5- X6+ X7)* ECON
+ X1= SPPP2* XR1
+ X2= RV* SPP2* XR2
+ X4= U2* T1* OMR* F* XR2
+ X5= T3*(1.-3.* CPPP2)* XR1
+ X6= T4*(1.-3.* CPP2)*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
+ X7= U2* CPP2* OMR*(1.-1./ RK2)*( F*( U2* T1- SPP2-1./ RK2)+1./
+ &RK2)* XR2
+ ERH=( X1- X2- X4- X5+ X6+ X7)* ECON
+ X1= XR1
+ X2= RH* XR2
+ X3=( RH+1.)* G* XR2
+ X4= T3* XR1
+ X5= T4*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
+ X6=.5* U2* OMR*( F*( U2* T1- SPP2-1./ RK2)+1./ RK2)* XR2/ RK2
+ EPH=-( X1- X2+ X3- X4+ X5+ X6)* ECON
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GX( ZZ, RH, XK, GZ, GZP)
+C ***
+C SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX GZ, GZP
+ R2= ZZ* ZZ+ RH* RH
+ R= SQRT( R2)
+ RKZ= XK* R
+ GZ= CMPLX( COS( RKZ),- SIN( RKZ))/ R
+ GZP=- CMPLX(1.0, RKZ)* GZ/ R2
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE GXX( ZZ, RH, A, A2, XK, IRA, G1, G1P, G2, G2P, G3, GZP
+ &)
+C ***
+C SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP
+ R2= ZZ* ZZ+ RH* RH
+ R= SQRT( R2)
+ R4= R2* R2
+ RK= XK* R
+ RK2= RK* RK
+ RH2= RH* RH
+ T1=.25* A2* RH2/ R4
+ T2=.5* A2/ R2
+ C1= CMPLX(1.0, RK)
+ C2=3.* C1- RK2
+ C3= CMPLX(6.0, RK)* RK2-15.* C1
+ GZ= CMPLX( COS( RK),- SIN( RK))/ R
+ G2= GZ*(1.+ T1* C2)
+ G1= G2- T2* C1* GZ
+ GZ= GZ/ R2
+ G2P= GZ*( T1* C3- C1)
+ GZP= T2* C2* GZ
+ G3= G2P+ GZP
+ G1P= G3* ZZ
+ IF( IRA.EQ.1) GOTO 2
+ G3=( G3+ GZP)* RH
+ GZP=- ZZ* C1* GZ
+ IF( RH.GT.1.D-10) GOTO 1
+ G2=0.
+ G2P=0.
+ RETURN
+ 1 G2= G2/ RH
+ G2P= G2P* ZZ/ RH
+ RETURN
+ 2 T2=.5* A
+ G2=- T2* C1* GZ
+ G2P= T2* GZ* C2/ R2
+ G3= RH2* G2P- A* GZ* C1
+ G2P= G2P* ZZ
+ GZP=- ZZ* C1* GZ
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE HELIX( S, HL, A1, B1, A2, B2, RAD, NS, ITG)
+C ***
+C SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
+C SEGMENTS
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ DIMENSION X2(1), Y2(1), Z2(1)
+ EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
+ DATA PI/3.1415926D+0/
+ IST= N+1
+ N= N+ NS
+ NP= N
+ MP= M
+ IPSYM=0
+ IF( NS.LT.1) RETURN
+ TURNS= ABS( HL/ S)
+ ZINC= ABS( HL/ NS)
+ Z( IST)=0.
+ DO 25 I= IST, N
+ BI( I)= RAD
+ ITAG( I)= ITG
+ IF( I.NE. IST) Z( I)= Z( I-1)+ ZINC
+ Z2( I)= Z( I)+ ZINC
+ IF( A2.NE. A1) GOTO 10
+ IF( B1.EQ.0) B1= A1
+ X( I)= A1* COS(2.* PI* Z( I)/ S)
+ Y( I)= B1* SIN(2.* PI* Z( I)/ S)
+ X2( I)= A1* COS(2.* PI* Z2( I)/ S)
+ Y2( I)= B1* SIN(2.* PI* Z2( I)/ S)
+ GOTO 20
+ 10 IF( B2.EQ.0) B2= A2
+ X( I)=( A1+( A2- A1)* Z( I)/ ABS( HL))* COS(2.* PI* Z( I)/ S)
+ Y( I)=( B1+( B2- B1)* Z( I)/ ABS( HL))* SIN(2.* PI* Z( I)/ S)
+ X2( I)=( A1+( A2- A1)* Z2( I)/ ABS( HL))* COS(2.* PI* Z2( I)/ S)
+ Y2( I)=( B1+( B2- B1)* Z2( I)/ ABS( HL))* SIN(2.* PI* Z2( I)/ S)
+ 20 IF( HL.GT.0) GOTO 25
+ COPY= X( I)
+ X( I)= Y( I)
+ Y( I)= COPY
+ COPY= X2( I)
+ X2( I)= Y2( I)
+ Y2( I)= COPY
+ 25 CONTINUE
+ IF( A2.EQ. A1) GOTO 21
+ SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1)))
+ WRITE (6,104) SANGLE
+ 104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
+ RETURN
+ 21 IF( A1.NE. B1) GOTO 30
+ HDIA=2.* A1
+ TURN= HDIA* PI
+ PITCH= ATAN( S/( PI* HDIA))
+ TURN= TURN/ COS( PITCH)
+ PITCH=180.* PITCH/ PI
+ GOTO 40
+ 30 IF( A1.LT. B1) GOTO 34
+ HMAJ=2.* A1
+ HMIN=2.* B1
+ GOTO 35
+ 34 HMAJ=2.* B1
+ HMIN=2.* A1
+ 35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ)
+ TURN=2.* PI* HDIA
+ PITCH=(180./ PI)* ATAN( S/( PI* HDIA))
+ 40 WRITE (6,105) PITCH, TURN
+ 105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,
+ &'THE LENGTH OF WIRE/TURN ''IS',F10.4)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE HFK( EL1, EL2, RHK, ZPKX, SGR, SGI)
+C ***
+C HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY
+C NUMERICAL INTEGRATION
+ IMPLICIT REAL (A-H,O-Z)
+ COMMON /TMH/ ZPK, RHKS
+ DATA NX, NM, NTS, RX/1,65536,4,1.D-4/
+ ZPK= ZPKX
+ RHKS= RHK* RHK
+ Z= EL1
+ ZE= EL2
+ S= ZE- Z
+ EP= S/(10.* NM)
+ ZEND= ZE- EP
+ SGR=0.0
+ SGI=0.0
+ NS= NX
+ NT=0
+ CALL GH( Z, G1R, G1I)
+ 1 DZ= S/ NS
+ ZP= Z+ DZ
+ IF( ZP- ZE) 3,3,2
+ 2 DZ= ZE- Z
+ IF( ABS( DZ)- EP) 17,17,3
+ 3 DZOT= DZ*.5
+ ZP= Z+ DZOT
+ CALL GH( ZP, G3R, G3I)
+ ZP= Z+ DZ
+ CALL GH( ZP, G5R, G5I)
+ 4 T00R=( G1R+ G5R)* DZOT
+ T00I=( G1I+ G5I)* DZOT
+ T01R=( T00R+ DZ* G3R)*0.5
+ T01I=( T00I+ DZ* G3I)*0.5
+ T10R=(4.0* T01R- T00R)/3.0
+ T10I=(4.0* T01I- T00I)/3.0
+ CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
+ IF( TE1I- RX) 5,5,6
+ 5 IF( TE1R- RX) 8,8,6
+ 6 ZP= Z+ DZ*0.25
+ CALL GH( ZP, G2R, G2I)
+ ZP= Z+ DZ*0.75
+ CALL GH( ZP, G4R, G4I)
+ T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
+ T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
+ T11R=(4.0* T02R- T01R)/3.0
+ T11I=(4.0* T02I- T01I)/3.0
+ T20R=(16.0* T11R- T10R)/15.0
+ T20I=(16.0* T11I- T10I)/15.0
+ CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
+ IF( TE2I- RX) 7,7,14
+ 7 IF( TE2R- RX) 9,9,14
+ 8 SGR= SGR+ T10R
+ SGI= SGI+ T10I
+ NT= NT+2
+ GOTO 10
+ 9 SGR= SGR+ T20R
+ SGI= SGI+ T20I
+ NT= NT+1
+ 10 Z= Z+ DZ
+ IF( Z- ZEND) 11,17,17
+ 11 G1R= G5R
+ G1I= G5I
+ IF( NT- NTS) 1,12,12
+ 12 IF( NS- NX) 1,1,13
+ 13 NS= NS/2
+ NT=1
+ GOTO 1
+ 14 NT=0
+ IF( NS- NM) 16,15,15
+ 15 WRITE (6,18) Z
+ GOTO 9
+ 16 NS= NS*2
+ DZ= S/ NS
+ DZOT= DZ*0.5
+ G5R= G3R
+ G5I= G3I
+ G3R= G2R
+ G3I= G2I
+ GOTO 4
+ 17 CONTINUE
+ SGR= SGR* RHK*.5
+ SGI= SGI* RHK*.5
+C
+ RETURN
+ 18 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE HINTG( XI, YI, ZI)
+C ***
+C HINTG COMPUTES THE H FIELD OF A PATCH CURRENT
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
+ &ZRATI2, GAM, F1X, F1Y, F1Z, F2X, F2Y, F2Z, RRV, RRH, T1, FRATI
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ DATA FPI/12.56637062D+0/, TP/6.283185308D+0/
+ RX= XI- XJ
+ RY= YI- YJ
+ RFL=-1.
+ EXK=(0.,0.)
+ EYK=(0.,0.)
+ EZK=(0.,0.)
+ EXS=(0.,0.)
+ EYS=(0.,0.)
+ EZS=(0.,0.)
+ DO 5 IP=1, KSYMP
+ RFL=- RFL
+ RZ= ZI- ZJ* RFL
+ RSQ= RX* RX+ RY* RY+ RZ* RZ
+ IF( RSQ.LT.1.D-20) GOTO 5
+ R= SQRT( RSQ)
+ RK= TP* R
+ CR= COS( RK)
+ SR= SIN( RK)
+ GAM=-( CMPLX( CR,- SR)+ RK* CMPLX( SR, CR))/( FPI* RSQ* R)* S
+ EXC= GAM* RX
+ EYC= GAM* RY
+ EZC= GAM* RZ
+ T1ZR= T1ZJ* RFL
+ T2ZR= T2ZJ* RFL
+ F1X= EYC* T1ZR- EZC* T1YJ
+ F1Y= EZC* T1XJ- EXC* T1ZR
+ F1Z= EXC* T1YJ- EYC* T1XJ
+ F2X= EYC* T2ZR- EZC* T2YJ
+ F2Y= EZC* T2XJ- EXC* T2ZR
+ F2Z= EXC* T2YJ- EYC* T2XJ
+ IF( IP.EQ.1) GOTO 4
+ IF( IPERF.NE.1) GOTO 1
+ F1X=- F1X
+ F1Y=- F1Y
+ F1Z=- F1Z
+ F2X=- F2X
+ F2Y=- F2Y
+ F2Z=- F2Z
+ GOTO 4
+ 1 XYMAG= SQRT( RX* RX+ RY* RY)
+ IF( XYMAG.GT.1.D-6) GOTO 2
+ PX=0.
+ PY=0.
+ CTH=1.
+ RRV=(1.,0.)
+ GOTO 3
+ 2 PX=- RY/ XYMAG
+ PY= RX/ XYMAG
+ CTH= RZ/ R
+ RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
+ 3 RRH= ZRATI* CTH
+ RRH=( RRH- RRV)/( RRH+ RRV)
+ RRV= ZRATI* RRV
+ RRV=-( CTH- RRV)/( CTH+ RRV)
+ GAM=( F1X* PX+ F1Y* PY)*( RRV- RRH)
+ F1X= F1X* RRH+ GAM* PX
+ F1Y= F1Y* RRH+ GAM* PY
+ F1Z= F1Z* RRH
+ GAM=( F2X* PX+ F2Y* PY)*( RRV- RRH)
+ F2X= F2X* RRH+ GAM* PX
+ F2Y= F2Y* RRH+ GAM* PY
+ F2Z= F2Z* RRH
+ 4 EXK= EXK+ F1X
+ EYK= EYK+ F1Y
+ EZK= EZK+ F1Z
+ EXS= EXS+ F2X
+ EYS= EYS+ F2Y
+ EZS= EZS+ F2Z
+ 5 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE HSFLD( XI, YI, ZI, AI)
+C ***
+C HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT
+C ON A SEGMENT INCLUDING GROUND EFFECTS.
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
+ &ZRATI2, T1, HPK, HPS, HPC, QX, QY, QZ, RRV, RRH, ZRATX, FRATI
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ DATA ETA/376.73/
+ XIJ= XI- XJ
+ YIJ= YI- YJ
+ RFL=-1.
+ DO 7 IP=1, KSYMP
+ RFL=- RFL
+ SALPR= SALPJ* RFL
+ ZIJ= ZI- RFL* ZJ
+ ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
+ RHOX= XIJ- CABJ* ZP
+ RHOY= YIJ- SABJ* ZP
+ RHOZ= ZIJ- SALPR* ZP
+ RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
+ IF( RH.GT.1.D-10) GOTO 1
+ EXK=0.
+ EYK=0.
+ EZK=0.
+ EXS=0.
+ EYS=0.
+ EZS=0.
+ EXC=0.
+ EYC=0.
+ EZC=0.
+ GOTO 7
+ 1 RHOX= RHOX/ RH
+ RHOY= RHOY/ RH
+ RHOZ= RHOZ/ RH
+ PHX= SABJ* RHOZ- SALPR* RHOY
+ PHY= SALPR* RHOX- CABJ* RHOZ
+ PHZ= CABJ* RHOY- SABJ* RHOX
+ CALL HSFLX( S, RH, ZP, HPK, HPS, HPC)
+ IF( IP.NE.2) GOTO 6
+ IF( IPERF.EQ.1) GOTO 5
+ ZRATX= ZRATI
+ RMAG= SQRT( ZP* ZP+ RH* RH)
+C
+C SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
+C
+ XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
+ IF( NRADL.EQ.0) GOTO 2
+ XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
+ YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
+ RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
+ IF( RHOSPC.GT. SCRWL) GOTO 2
+ RRV= T1* RHOSPC* LOG( RHOSPC/ T2)
+ ZRATX=( RRV* ZRATI)/( ETA* ZRATI+ RRV)
+C
+C CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
+C
+ 2 IF( XYMAG.GT.1.D-6) GOTO 3
+ PX=0.
+ PY=0.
+ CTH=1.
+ RRV=(1.,0.)
+ GOTO 4
+ 3 PX=- YIJ/ XYMAG
+ PY= XIJ/ XYMAG
+ CTH= ZIJ/ RMAG
+ RRV= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
+ 4 RRH= ZRATX* CTH
+ RRH=-( RRH- RRV)/( RRH+ RRV)
+ RRV= ZRATX* RRV
+ RRV=( CTH- RRV)/( CTH+ RRV)
+ QY=( PHX* PX+ PHY* PY)*( RRV- RRH)
+ QX= QY* PX+ PHX* RRH
+ QY= QY* PY+ PHY* RRH
+ QZ= PHZ* RRH
+ EXK= EXK- HPK* QX
+ EYK= EYK- HPK* QY
+ EZK= EZK- HPK* QZ
+ EXS= EXS- HPS* QX
+ EYS= EYS- HPS* QY
+ EZS= EZS- HPS* QZ
+ EXC= EXC- HPC* QX
+ EYC= EYC- HPC* QY
+ EZC= EZC- HPC* QZ
+ GOTO 7
+ 5 EXK= EXK- HPK* PHX
+ EYK= EYK- HPK* PHY
+ EZK= EZK- HPK* PHZ
+ EXS= EXS- HPS* PHX
+ EYS= EYS- HPS* PHY
+ EZS= EZS- HPS* PHZ
+ EXC= EXC- HPC* PHX
+ EYC= EYC- HPC* PHY
+ EZC= EZC- HPC* PHZ
+ GOTO 7
+ 6 EXK= HPK* PHX
+ EYK= HPK* PHY
+ EZK= HPK* PHZ
+ EXS= HPS* PHX
+ EYS= HPS* PHY
+ EZS= HPS* PHZ
+ EXC= HPC* PHX
+ EYC= HPC* PHY
+ EZC= HPC* PHZ
+ 7 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE HSFLX( S, RH, ZPX, HPK, HPS, HPC)
+C ***
+C CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK
+ DIMENSION FJX(2), FJKX(2)
+ EQUIVALENCE(FJ,FJX),(FJK,FJKX)
+ DATA TP/6.283185308D+0/, FJX/0.,1./, FJKX/0.,-6.283185308D+0/
+ DATA PI8/25.13274123D+0/
+ IF( RH.LT.1.D-10) GOTO 6
+ IF( ZPX.LT.0.) GOTO 1
+ ZP= ZPX
+ HSS=1.
+ GOTO 2
+ 1 ZP=- ZPX
+ HSS=-1.
+ 2 DH=.5* S
+ Z1= ZP+ DH
+ Z2= ZP- DH
+ IF( Z2.LT.1.D-7) GOTO 3
+ RHZ= RH/ Z2
+ GOTO 4
+ 3 RHZ=1.
+ 4 DK= TP* DH
+ CDK= COS( DK)
+ SDK= SIN( DK)
+ CALL HFK(- DK, DK, RH* TP, ZP* TP, HKR, HKI)
+ HPK= CMPLX( HKR, HKI)
+ IF( RHZ.LT.1.D-3) GOTO 5
+ RH2= RH* RH
+ R1= SQRT( RH2+ Z1* Z1)
+ R2= SQRT( RH2+ Z2* Z2)
+ EKR1= EXP( FJK* R1)
+ EKR2= EXP( FJK* R2)
+ T1= Z1* EKR1/ R1
+ T2= Z2* EKR2/ R2
+ HPS=( CDK*( EKR2- EKR1)- FJ* SDK*( T2+ T1))* HSS
+ HPC=- SDK*( EKR2+ EKR1)- FJ* CDK*( T2- T1)
+ CONS=- FJ/(2.* TP* RH)
+ HPS= CONS* HPS
+ HPC= CONS* HPC
+ RETURN
+ 5 EKR1= CMPLX( CDK, SDK)/( Z2* Z2)
+ EKR2= CMPLX( CDK,- SDK)/( Z1* Z1)
+ T1= TP*(1./ Z1-1./ Z2)
+ T2= EXP( FJK* ZP)* RH/ PI8
+ HPS= T2*( T1+( EKR1+ EKR2)* SDK)* HSS
+ HPC= T2*(- FJ* T1+( EKR1- EKR2)* CDK)
+ RETURN
+ 6 HPS=(0.,0.)
+ HPC=(0.,0.)
+ HPK=(0.,0.)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE INTRP( X, Y, F1, F2, F3, F4)
+C ***
+C
+C INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF
+C 4 FUNCTIONS AT THE POINT (X,Y).
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX F1, F2, F3, F4, A, B, C, D, FX1, FX2, FX3, FX4, P1,
+ &P2, P3, P4, A11, A12, A13, A14, A21, A22, A23, A24, A31, A32, A33
+ &, A34, A41, A42, A43, A44, B11, B12, B13, B14, B21, B22, B23, B24
+ &, B31, B32, B33, B34, B41, B42, B43, B44, C11, C12, C13, C14, C21
+ &, C22, C23, C24, C31, C32, C33, C34, C41, C42, C43, C44, D11, D12
+ &, D13, D14, D21, D22, D23, D24, D31, D32, D33, D34, D41, D42, D43
+ &, D44
+ COMPLEX AR1, AR2, AR3, ARL1, ARL2, ARL3, EPSCF
+ COMMON /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
+ &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
+ DIMENSION NDA(3), NDPA(3)
+ DIMENSION A(4,4), B(4,4), C(4,4), D(4,4), ARL1(1), ARL2(1), ARL3
+ &(1)
+ EQUIVALENCE(A(1,1),A11),(A(1,2),A12),(A(1,3),A13),(A(1,4),A14)
+ EQUIVALENCE(A(2,1),A21),(A(2,2),A22),(A(2,3),A23),(A(2,4),A24)
+ EQUIVALENCE(A(3,1),A31),(A(3,2),A32),(A(3,3),A33),(A(3,4),A34)
+ EQUIVALENCE(A(4,1),A41),(A(4,2),A42),(A(4,3),A43),(A(4,4),A44)
+ EQUIVALENCE(B(1,1),B11),(B(1,2),B12),(B(1,3),B13),(B(1,4),B14)
+ EQUIVALENCE(B(2,1),B21),(B(2,2),B22),(B(2,3),B23),(B(2,4),B24)
+ EQUIVALENCE(B(3,1),B31),(B(3,2),B32),(B(3,3),B33),(B(3,4),B34)
+ EQUIVALENCE(B(4,1),B41),(B(4,2),B42),(B(4,3),B43),(B(4,4),B44)
+ EQUIVALENCE(C(1,1),C11),(C(1,2),C12),(C(1,3),C13),(C(1,4),C14)
+ EQUIVALENCE(C(2,1),C21),(C(2,2),C22),(C(2,3),C23),(C(2,4),C24)
+ EQUIVALENCE(C(3,1),C31),(C(3,2),C32),(C(3,3),C33),(C(3,4),C34)
+ EQUIVALENCE(C(4,1),C41),(C(4,2),C42),(C(4,3),C43),(C(4,4),C44)
+ EQUIVALENCE(D(1,1),D11),(D(1,2),D12),(D(1,3),D13),(D(1,4),D14)
+ EQUIVALENCE(D(2,1),D21),(D(2,2),D22),(D(2,3),D23),(D(2,4),D24)
+ EQUIVALENCE(D(3,1),D31),(D(3,2),D32),(D(3,3),D33),(D(3,4),D34)
+ EQUIVALENCE(D(4,1),D41),(D(4,2),D42),(D(4,3),D43),(D(4,4),D44)
+ EQUIVALENCE(ARL1,AR1),(ARL2,AR2),(ARL3,AR3),(XS2,XSA(2)),(YS3,YSA
+ &(3))
+ DATA IXS, IYS, IGRS/-10,-10,-10/, DX, DY, XS, YS/1.,1.,0.,0./
+ DATA NDA/11,17,9/, NDPA/110,85,72/, IXEG, IYEG/0,0/
+ IF( X.LT. XS.OR. Y.LT. YS) GOTO 1
+ IX= INT(( X- XS)/ DX)+1
+C
+C IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD
+C VALUES ARE REUSED
+C
+ IY= INT(( Y- YS)/ DY)+1
+ IF( IX.LT. IXEG.OR. IY.LT. IYEG) GOTO 1
+C
+C DETERMINE CORRECT GRID AND GRID REGION
+C
+ IF( IABS( IX- IXS).LT.2.AND. IABS( IY- IYS).LT.2) GOTO 12
+ 1 IF( X.GT. XS2) GOTO 2
+ IGR=1
+ GOTO 3
+ 2 IGR=2
+ IF( Y.GT. YS3) IGR=3
+ 3 IF( IGR.EQ. IGRS) GOTO 4
+ IGRS= IGR
+ DX= DXA( IGRS)
+ DY= DYA( IGRS)
+ XS= XSA( IGRS)
+ YS= YSA( IGRS)
+ NXM2= NXA( IGRS)-2
+ NYM2= NYA( IGRS)-2
+ NXMS=(( NXM2+1)/3)*3+1
+ NYMS=(( NYM2+1)/3)*3+1
+ ND= NDA( IGRS)
+ NDP= NDPA( IGRS)
+ IX= INT(( X- XS)/ DX)+1
+ IY= INT(( Y- YS)/ DY)+1
+ 4 IXS=(( IX-1)/3)*3+2
+ IF( IXS.LT.2) IXS=2
+ IXEG=-10000
+ IF( IXS.LE. NXM2) GOTO 5
+ IXS= NXM2
+ IXEG= NXMS
+ 5 IYS=(( IY-1)/3)*3+2
+ IF( IYS.LT.2) IYS=2
+ IYEG=-10000
+ IF( IYS.LE. NYM2) GOTO 6
+ IYS= NYM2
+C
+C COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID
+C VALUES OF Y FOR EACH OF THE 4 FUNCTIONS
+C
+ IYEG= NYMS
+ 6 IADZ= IXS+( IYS-3)* ND- NDP
+ DO 11 K=1,4
+ IADZ= IADZ+ NDP
+ IADD= IADZ
+ DO 11 I=1,4
+ IADD= IADD+ ND
+C P1=AR1(IXS-1,IYS-2+I,K)
+ GOTO (7,8,9), IGRS
+ 7 P1= ARL1( IADD-1)
+ P2= ARL1( IADD)
+ P3= ARL1( IADD+1)
+ P4= ARL1( IADD+2)
+ GOTO 10
+ 8 P1= ARL2( IADD-1)
+ P2= ARL2( IADD)
+ P3= ARL2( IADD+1)
+ P4= ARL2( IADD+2)
+ GOTO 10
+ 9 P1= ARL3( IADD-1)
+ P2= ARL3( IADD)
+ P3= ARL3( IADD+1)
+ P4= ARL3( IADD+2)
+ 10 A( I, K)=( P4- P1+3.*( P2- P3))*.1666666667D+0
+ B( I, K)=( P1-2.* P2+ P3)*.5
+ C( I, K)= P3-(2.* P1+3.* P2+ P4)*.1666666667D+0
+ 11 D( I, K)= P2
+ XZ=( IXS-1)* DX+ XS
+C
+C EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y
+C FOR EACH OF THE 4 FUNCTIONS.
+C
+ YZ=( IYS-1)* DY+ YS
+ 12 XX=( X- XZ)/ DX
+ YY=( Y- YZ)/ DY
+ FX1=(( A11* XX+ B11)* XX+ C11)* XX+ D11
+ FX2=(( A21* XX+ B21)* XX+ C21)* XX+ D21
+ FX3=(( A31* XX+ B31)* XX+ C31)* XX+ D31
+ FX4=(( A41* XX+ B41)* XX+ C41)* XX+ D41
+ P1= FX4- FX1+3.*( FX2- FX3)
+ P2=3.*( FX1-2.* FX2+ FX3)
+ P3=6.* FX3-2.* FX1-3.* FX2- FX4
+ F1=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
+ FX1=(( A12* XX+ B12)* XX+ C12)* XX+ D12
+ FX2=(( A22* XX+ B22)* XX+ C22)* XX+ D22
+ FX3=(( A32* XX+ B32)* XX+ C32)* XX+ D32
+ FX4=(( A42* XX+ B42)* XX+ C42)* XX+ D42
+ P1= FX4- FX1+3.*( FX2- FX3)
+ P2=3.*( FX1-2.* FX2+ FX3)
+ P3=6.* FX3-2.* FX1-3.* FX2- FX4
+ F2=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
+ FX1=(( A13* XX+ B13)* XX+ C13)* XX+ D13
+ FX2=(( A23* XX+ B23)* XX+ C23)* XX+ D23
+ FX3=(( A33* XX+ B33)* XX+ C33)* XX+ D33
+ FX4=(( A43* XX+ B43)* XX+ C43)* XX+ D43
+ P1= FX4- FX1+3.*( FX2- FX3)
+ P2=3.*( FX1-2.* FX2+ FX3)
+ P3=6.* FX3-2.* FX1-3.* FX2- FX4
+ F3=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
+ FX1=(( A14* XX+ B14)* XX+ C14)* XX+ D14
+ FX2=(( A24* XX+ B24)* XX+ C24)* XX+ D24
+ FX3=(( A34* XX+ B34)* XX+ C34)* XX+ D34
+ FX4=(( A44* XX+ B44)* XX+ C44)* XX+ D44
+ P1= FX4- FX1+3.*( FX2- FX3)
+ P2=3.*( FX1-2.* FX2+ FX3)
+ P3=6.* FX3-2.* FX1-3.* FX2- FX4
+ F4=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE INTX( EL1, EL2, B, IJ, SGR, SGI)
+C ***
+C
+C INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
+C VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION. THE INTEGRAND VALUE
+C IS SUPPLIED BY SUBROUTINE GF.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ DATA NX, NM, NTS, RX/1,65536,4,1.D-4/
+ Z= EL1
+ ZE= EL2
+ IF( IJ.EQ.0) ZE=0.
+ S= ZE- Z
+ FNM= NM
+ EP= S/(10.* FNM)
+ ZEND= ZE- EP
+ SGR=0.
+ SGI=0.
+ NS= NX
+ NT=0
+ CALL GF( Z, G1R, G1I)
+ 1 FNS= NS
+ DZ= S/ FNS
+ ZP= Z+ DZ
+ IF( ZP- ZE) 3,3,2
+ 2 DZ= ZE- Z
+ IF( ABS( DZ)- EP) 17,17,3
+ 3 DZOT= DZ*.5
+ ZP= Z+ DZOT
+ CALL GF( ZP, G3R, G3I)
+ ZP= Z+ DZ
+ CALL GF( ZP, G5R, G5I)
+ 4 T00R=( G1R+ G5R)* DZOT
+ T00I=( G1I+ G5I)* DZOT
+ T01R=( T00R+ DZ* G3R)*0.5
+ T01I=( T00I+ DZ* G3I)*0.5
+ T10R=(4.0* T01R- T00R)/3.0
+C
+C TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.
+C
+ T10I=(4.0* T01I- T00I)/3.0
+ CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
+ IF( TE1I- RX) 5,5,6
+ 5 IF( TE1R- RX) 8,8,6
+ 6 ZP= Z+ DZ*0.25
+ CALL GF( ZP, G2R, G2I)
+ ZP= Z+ DZ*0.75
+ CALL GF( ZP, G4R, G4I)
+ T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
+ T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
+ T11R=(4.0* T02R- T01R)/3.0
+ T11I=(4.0* T02I- T01I)/3.0
+ T20R=(16.0* T11R- T10R)/15.0
+C
+C TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.
+C
+ T20I=(16.0* T11I- T10I)/15.0
+ CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
+ IF( TE2I- RX) 7,7,14
+ 7 IF( TE2R- RX) 9,9,14
+ 8 SGR= SGR+ T10R
+ SGI= SGI+ T10I
+ NT= NT+2
+ GOTO 10
+ 9 SGR= SGR+ T20R
+ SGI= SGI+ T20I
+ NT= NT+1
+ 10 Z= Z+ DZ
+ IF( Z- ZEND) 11,17,17
+ 11 G1R= G5R
+ G1I= G5I
+ IF( NT- NTS) 1,12,12
+C
+C DOUBLE STEP SIZE
+C
+ 12 IF( NS- NX) 1,1,13
+ 13 NS= NS/2
+ NT=1
+ GOTO 1
+ 14 NT=0
+ IF( NS- NM) 16,15,15
+ 15 WRITE (6,20) Z
+C
+C HALVE STEP SIZE
+C
+ GOTO 9
+ 16 NS= NS*2
+ FNS= NS
+ DZ= S/ FNS
+ DZOT= DZ*0.5
+ G5R= G3R
+ G5I= G3I
+ G3R= G2R
+ G3I= G2I
+ GOTO 4
+ 17 CONTINUE
+C
+C ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM
+C
+ IF( IJ) 19,18,19
+ 18 SGR=2.*( SGR+ LOG(( SQRT( B* B+ S* S)+ S)/ B))
+ SGI=2.* SGI
+ 19 CONTINUE
+C
+ RETURN
+ 20 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ FUNCTION ISEGNO( ITAGI, MX)
+C ***
+C
+C ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE
+C TAG NUMBER ITAGI. IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ IF( MX.GT.0) GOTO 1
+ WRITE (6,6)
+ STOP
+ 1 ICNT=0
+ IF( ITAGI.NE.0) GOTO 2
+ ISEGNO= MX
+ RETURN
+ 2 IF( N.LT.1) GOTO 4
+ DO 3 I=1, N
+ IF( ITAG( I).NE. ITAGI) GOTO 3
+ ICNT= ICNT+1
+ IF( ICNT.EQ. MX) GOTO 5
+ 3 CONTINUE
+ 4 WRITE (6,7) ITAGI
+ STOP
+ 5 ISEGNO= I
+C
+ RETURN
+ 6 FORMAT(4X,'CHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN',
+ &' A GROUP OF EQUAL TAGS MUST NOT BE ZERO')
+ 7 FORMAT(///,10X,'NO SEGMENT HAS AN ITAG OF ',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE LFACTR( A, NROW, IX1, IX2, IP)
+C ***
+C
+C LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
+C THE TRANSPOSED MATRIX IN CORE STORAGE. THE GAUSS-DOOLITTLE
+C ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST
+C COURSE IN NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN
+C RALSTONS TEXT.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, D, AJR
+ INTEGER R, R1, R2, PJ, PR
+ LOGICAL L1, L2, L3
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SCRATM/ D( N2M)
+ DIMENSION A( NROW,1), IP( NROW)
+C
+C INITIALIZE R1,R2,J1,J2
+C
+ IFLG=0
+ L1= IX1.EQ.1.AND. IX2.EQ.2
+ L2=( IX2-1).EQ. IX1
+ L3= IX2.EQ. NBLSYM
+ IF( L1) GOTO 1
+ GOTO 2
+ 1 R1=1
+ R2=2* NPSYM
+ J1=1
+ J2=-1
+ GOTO 5
+ 2 R1= NPSYM+1
+ R2=2* NPSYM
+ J1=( IX1-1)* NPSYM+1
+ IF( L2) GOTO 3
+ GOTO 4
+ 3 J2= J1+ NPSYM-2
+ GOTO 5
+ 4 J2= J1+ NPSYM-1
+ 5 IF( L3) R2= NPSYM+ NLSYM
+C
+C STEP 1
+C
+ DO 16 R= R1, R2
+ DO 6 K= J1, NROW
+ D( K)= A( K, R)
+C
+C STEPS 2 AND 3
+C
+ 6 CONTINUE
+ IF( L1.OR. L2) J2= J2+1
+ IF( J1.GT. J2) GOTO 9
+ IXJ=0
+ DO 8 J= J1, J2
+ IXJ= IXJ+1
+ PJ= IP( J)
+ AJR= D( PJ)
+ A( J, R)= AJR
+ D( PJ)= D( J)
+ JP1= J+1
+ DO 7 I= JP1, NROW
+ D( I)= D( I)- A( I, IXJ)* AJR
+ 7 CONTINUE
+ 8 CONTINUE
+C
+C STEP 4
+C
+ 9 CONTINUE
+ J2P1= J2+1
+ IF( L1.OR. L2) GOTO 11
+ IF( NROW.LT. J2P1) GOTO 16
+ DO 10 I= J2P1, NROW
+ A( I, R)= D( I)
+ 10 CONTINUE
+ GOTO 16
+ 11 DMAX= REAL( D( J2P1)* CONJG( D( J2P1)))
+ IP( J2P1)= J2P1
+ J2P2= J2+2
+ IF( J2P2.GT. NROW) GOTO 13
+ DO 12 I= J2P2, NROW
+ ELMAG= REAL( D( I)* CONJG( D( I)))
+ IF( ELMAG.LT. DMAX) GOTO 12
+ DMAX= ELMAG
+ IP( J2P1)= I
+ 12 CONTINUE
+ 13 CONTINUE
+ IF( DMAX.LT.1.D-10) IFLG=1
+ PR= IP( J2P1)
+ A( J2P1, R)= D( PR)
+C
+C STEP 5
+C
+ D( PR)= D( J2P1)
+ IF( J2P2.GT. NROW) GOTO 15
+ AJR=1./ A( J2P1, R)
+ DO 14 I= J2P2, NROW
+ A( I, R)= D( I)* AJR
+ 14 CONTINUE
+ 15 CONTINUE
+ IF( IFLG.EQ.0) GOTO 16
+ WRITE (6,17) J2, DMAX
+ IFLG=0
+ 16 CONTINUE
+C
+ RETURN
+ 17 FORMAT(' ','PIVOT(,I3,2H)=',1P,E16.8)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI, ZLC)
+C ***
+C
+C LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS
+C TYPES OF LOADING
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX ZARRAY, ZT, TPCJ, ZINT
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ DIMENSION LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(
+ &1), ZLC(1), TPCJX(2)
+ EQUIVALENCE(TPCJ,TPCJX)
+C
+C WRITE(6,HEADING)
+C
+ DATA TPCJX/0.,1.883698955D+9/
+C
+C INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING
+C INFORMATION.
+C
+ WRITE (6,25)
+ DO 1 I= N2, N
+ 1 ZARRAY( I)=(0.,0.)
+C
+C CYCLE OVER LOADING CARDS
+C
+ IWARN=0
+ ISTEP=0
+ 2 ISTEP= ISTEP+1
+ IF( ISTEP.LE. NLOAD) GOTO 5
+ IF( IWARN.EQ.1) WRITE (6,26)
+ IF( N1+2* M1.GT.0) GOTO 4
+ NOP= N/ NP
+ IF( NOP.EQ.1) GOTO 4
+ DO 3 I=1, NP
+ ZT= ZARRAY( I)
+ L1= I
+ DO 3 L2=2, NOP
+ L1= L1+ NP
+ 3 ZARRAY( L1)= ZT
+ 4 RETURN
+ 5 IF( LDTYP( ISTEP).LE.5) GOTO 6
+ WRITE (6,27) LDTYP( ISTEP)
+ STOP
+ 6 LDTAGS= LDTAG( ISTEP)
+ JUMP= LDTYP( ISTEP)+1
+C
+C SEARCH SEGMENTS FOR PROPER ITAGS
+C
+ ICHK=0
+ L1= N2
+ L2= N
+ IF( LDTAGS.NE.0) GOTO 7
+ IF( LDTAGF( ISTEP).EQ.0.AND. LDTAGT( ISTEP).EQ.0) GOTO 7
+ L1= LDTAGF( ISTEP)
+ L2= LDTAGT( ISTEP)
+ IF( L1.GT. N1) GOTO 7
+ WRITE (6,29)
+ STOP
+ 7 DO 17 I= L1, L2
+ IF( LDTAGS.EQ.0) GOTO 8
+ IF( LDTAGS.NE. ITAG( I)) GOTO 17
+ IF( LDTAGF( ISTEP).EQ.0) GOTO 8
+ ICHK= ICHK+1
+ IF( ICHK.GE. LDTAGF( ISTEP).AND. ICHK.LE. LDTAGT( ISTEP)) GOTO 9
+ GOTO 17
+C
+C CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATE
+C SECTION FOR LOADING TYPE
+C
+ 8 ICHK=1
+ 9 GOTO (10,11,12,13,14,15), JUMP
+ 10 ZT= ZLR( ISTEP)/ SI( I)+ TPCJ* ZLI( ISTEP)/( SI( I)* WLAM)
+ IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+ WLAM/( TPCJ* SI( I)* ZLC
+ &( ISTEP))
+ GOTO 16
+ 11 ZT= TPCJ* SI( I)* ZLC( ISTEP)/ WLAM
+ IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)* WLAM/( TPCJ* ZLI
+ &( ISTEP))
+ IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)/ ZLR( ISTEP)
+ ZT=1./ ZT
+ GOTO 16
+ 12 ZT= ZLR( ISTEP)* WLAM+ TPCJ* ZLI( ISTEP)
+ IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* SI( I)* SI( I)
+ &* ZLC( ISTEP))
+ GOTO 16
+ 13 ZT= TPCJ* SI( I)* SI( I)* ZLC( ISTEP)
+ IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* ZLI( ISTEP))
+ IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+1./( ZLR( ISTEP)* WLAM)
+ ZT=1./ ZT
+ GOTO 16
+ 14 ZT= CMPLX( ZLR( ISTEP), ZLI( ISTEP))/ SI( I)
+ GOTO 16
+ 15 ZT= ZINT( ZLR( ISTEP)* WLAM, BI( I))
+ 16 IF(( ABS( REAL( ZARRAY( I)))+ ABS( AIMAG( ZARRAY( I)))).GT.1.D-20
+ &) IWARN=1
+ ZARRAY( I)= ZARRAY( I)+ ZT
+ 17 CONTINUE
+ IF( ICHK.NE.0) GOTO 18
+ WRITE (6,28) LDTAGS
+C
+C PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT
+C
+ STOP
+ 18 GOTO (19,20,21,22,23,24), JUMP
+ 19 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
+ &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,' SERIES ',2)
+ GOTO 2
+ 20 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
+ &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,'PARALLEL',2)
+ GOTO 2
+ 21 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
+ &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,'SERIES (PER METER)',5)
+ GOTO 2
+ 22 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
+ &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,'PARALLEL (PER METER)',5)
+ GOTO 2
+ 23 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0., ZLR(
+ &ISTEP), ZLI( ISTEP),0.,'FIXED IMPEDANCE ',4)
+ GOTO 2
+ 24 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0.,0.,0.,
+ & ZLR( ISTEP),' WIRE ',2)
+C
+ GOTO 2
+ 25 FORMAT(//,7X,'LOCATION',10X,'RESISTANCE',3X,'INDUCTANCE',2X,
+ &'CAPACITANCE',7X,'IMPEDANCE (OHMS)',5X,'CONDUCTIVITY',4X,'TYPE',/
+ &,4X,'ITAG',' FROM THRU',10X,'OHMS',8X,'HENRYS',7X,'FARADS',8X,
+ &'REAL',6X,'IMAGINARY',4X,'MHOS/METER')
+ 26 FORMAT(/,10X,'NOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED',
+ &' TWICE - IMPEDANCES ADDED')
+ 27 FORMAT(/,10X,'IMPROPER LOAD TYPE CHOSEN, REQUESTED TYPE IS ',I3)
+ &
+ 28 FORMAT(/,10X,'LOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =',
+ &I5)
+ 29 FORMAT(' ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F.',
+ &' SECTION')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE LTSOLV( A, NROW, IX, B, NEQ, NRH, IFL1, IFL2)
+C ***
+C
+C LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW
+C VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF
+C THE ORIGINAL COEFFICIENT MATRIX. THE LU(T) DECOMPOSITION IS
+C STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN
+C BLOCKS OF DESCENDING ORDER.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, B, Y, SUM
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ COMMON /SCRATM/ Y( N2M)
+C
+C FORWARD SUBSTITUTION
+C
+ DIMENSION A( NROW, NROW), B( NEQ, NRH), IX( NEQ)
+ I2=2* NPSYM* NROW
+ DO 4 IXBLK1=1, NBLSYM
+ CALL BLCKIN( A, IFL1,1, I2,1,121)
+ K2= NPSYM
+ IF( IXBLK1.EQ. NBLSYM) K2= NLSYM
+ JST=( IXBLK1-1)* NPSYM
+ DO 4 IC=1, NRH
+ J= JST
+ DO 3 K=1, K2
+ JM1= J
+ J= J+1
+ SUM=(0.,0.)
+ IF( JM1.LT.1) GOTO 2
+ DO 1 I=1, JM1
+ 1 SUM= SUM+ A( I, K)* B( I, IC)
+ 2 B( J, IC)=( B( J, IC)- SUM)/ A( J, K)
+ 3 CONTINUE
+C
+C BACKWARD SUBSTITUTION
+C
+ 4 CONTINUE
+ JST= NROW+1
+ DO 8 IXBLK1=1, NBLSYM
+ CALL BLCKIN( A, IFL2,1, I2,1,122)
+ K2= NPSYM
+ IF( IXBLK1.EQ.1) K2= NLSYM
+ DO 7 IC=1, NRH
+ KP= K2+1
+ J= JST
+ DO 6 K=1, K2
+ KP= KP-1
+ JP1= J
+ J= J-1
+ SUM=(0.,0.)
+ IF( NROW.LT. JP1) GOTO 6
+ DO 5 I= JP1, NROW
+ 5 SUM= SUM+ A( I, KP)* B( I, IC)
+ B( J, IC)= B( J, IC)- SUM
+ 6 CONTINUE
+ 7 CONTINUE
+C
+C UNSCRAMBLE SOLUTION
+C
+ 8 JST= JST- K2
+ DO 10 IC=1, NRH
+ DO 9 I=1, NROW
+ IXI= IX( I)
+ 9 Y( IXI)= B( I, IC)
+ DO 10 I=1, NROW
+ 10 B( I, IC)= Y( I)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE LUNSCR( A, NROW, NOP, IX, IP, IU2, IU3, IU4)
+C ***
+C
+C S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, TEMP
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A( NROW,1), IP( NROW), IX( NROW)
+ I1=1
+ I2=2* NPSYM* NROW
+ NM1= NROW-1
+ REWIND IU2
+ REWIND IU3
+ REWIND IU4
+ DO 9 KK=1, NOP
+ KA=( KK-1)* NROW
+ DO 4 IXBLK1=1, NBLSYM
+ CALL BLCKIN( A, IU2, I1, I2,1,121)
+ K1=( IXBLK1-1)* NPSYM+2
+ IF( NM1.LT. K1) GOTO 3
+ J2=0
+ DO 2 K= K1, NM1
+ IF( J2.LT. NPSYM) J2= J2+1
+ IPK= IP( K+ KA)
+ DO 1 J=1, J2
+ TEMP= A( K, J)
+ A( K, J)= A( IPK, J)
+ A( IPK, J)= TEMP
+ 1 CONTINUE
+ 2 CONTINUE
+ 3 CONTINUE
+ CALL BLCKOT( A, IU3, I1, I2,1,122)
+ 4 CONTINUE
+ DO 5 IXBLK1=1, NBLSYM
+ BACKSPACE IU3
+ IF( IXBLK1.NE.1) BACKSPACE IU3
+ CALL BLCKIN( A, IU3, I1, I2,1,123)
+ CALL BLCKOT( A, IU4, I1, I2,1,124)
+ 5 CONTINUE
+ DO 6 I=1, NROW
+ IX( I+ KA)= I
+ 6 CONTINUE
+ DO 7 I=1, NROW
+ IPI= IP( I+ KA)
+ IXT= IX( I+ KA)
+ IX( I+ KA)= IX( IPI+ KA)
+ IX( IPI+ KA)= IXT
+ 7 CONTINUE
+ IF( NOP.EQ.1) GOTO 9
+C SKIP NB1 LOGICAL RECORDS FORWARD
+ NB1= NBLSYM-1
+ DO 8 IXBLK1=1, NB1
+ CALL BLCKIN( A, IU3, I1, I2,1,125)
+ 8 CONTINUE
+ 9 CONTINUE
+ REWIND IU2
+ REWIND IU3
+ REWIND IU4
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE MOVE( ROX, ROY, ROZ, XS, YS, ZS, ITS, NRPT, ITGI)
+C ***
+C
+C SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS
+C COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.
+C STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ
+C RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
+ & Y2(1), Z2(1)
+ EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ IF( ABS( ROX)+ ABS( ROY).GT.1.D-10) IPSYM= IPSYM*3
+ SPS= SIN( ROX)
+ CPS= COS( ROX)
+ STH= SIN( ROY)
+ CTH= COS( ROY)
+ SPH= SIN( ROZ)
+ CPH= COS( ROZ)
+ XX= CPH* CTH
+ XY= CPH* STH* SPS- SPH* CPS
+ XZ= CPH* STH* CPS+ SPH* SPS
+ YX= SPH* CTH
+ YY= SPH* STH* SPS+ CPH* CPS
+ YZ= SPH* STH* CPS- CPH* SPS
+ ZX=- STH
+ ZY= CTH* SPS
+ ZZ= CTH* CPS
+ NRP= NRPT
+ IF( NRPT.EQ.0) NRP=1
+ IX=1
+ IF( N.LT. N2) GOTO 3
+ I1= ISEGNO( ITS,1)
+ IF( I1.LT. N2) I1= N2
+ IX= I1
+ K= N
+ IF( NRPT.EQ.0) K= I1-1
+ DO 2 IR=1, NRP
+ DO 1 I= I1, N
+ K= K+1
+ XI= X( I)
+ YI= Y( I)
+ ZI= Z( I)
+ X( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
+ Y( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
+ Z( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
+ XI= X2( I)
+ YI= Y2( I)
+ ZI= Z2( I)
+ X2( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
+ Y2( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
+ Z2( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
+ BI( K)= BI( I)
+ ITAG( K)= ITAG( I)
+ IF( ITAG( I).NE.0) ITAG( K)= ITAG( I)+ ITGI
+ 1 CONTINUE
+ I1= N+1
+ N= K
+ 2 CONTINUE
+ 3 IF( M.LT. M2) GOTO 6
+ I1= M2
+ K= M
+ LDI= LD+1
+ IF( NRPT.EQ.0) K= M1
+ DO 5 II=1, NRP
+ DO 4 I= I1, M
+ K= K+1
+ IR= LDI- I
+ KR= LDI- K
+ XI= X( IR)
+ YI= Y( IR)
+ ZI= Z( IR)
+ X( KR)= XI* XX+ YI* XY+ ZI* XZ+ XS
+ Y( KR)= XI* YX+ YI* YY+ ZI* YZ+ YS
+ Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
+ XI= T1X( IR)
+ YI= T1Y( IR)
+ ZI= T1Z( IR)
+ T1X( KR)= XI* XX+ YI* XY+ ZI* XZ
+ T1Y( KR)= XI* YX+ YI* YY+ ZI* YZ
+ T1Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
+ XI= T2X( IR)
+ YI= T2Y( IR)
+ ZI= T2Z( IR)
+ T2X( KR)= XI* XX+ YI* XY+ ZI* XZ
+ T2Y( KR)= XI* YX+ YI* YY+ ZI* YZ
+ T2Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
+ SALP( KR)= SALP( IR)
+ 4 BI( KR)= BI( IR)
+ I1= M+1
+ 5 M= K
+ 6 IF(( NRPT.EQ.0).AND.( IX.EQ.1)) RETURN
+ NP= N
+ MP= M
+ IPSYM=0
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE NEFLD( XOB, YOB, ZOB, EX, EY, EZ)
+C ***
+C
+C NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
+C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EX, EY, EZ, CUR, ACX, BCX, CCX, EXK, EYK, EZK, EXS,
+ &EYS, EZS, EXC, EYC, EZC, ZRATI, ZRATI2, T1, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ DIMENSION CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1)
+ &, T2Z(1)
+ EQUIVALENCE(CAB,ALP),(SAB,BET)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ EX=(0.,0.)
+ EY=(0.,0.)
+ EZ=(0.,0.)
+ AX=0.
+ IF( N.EQ.0) GOTO 20
+ DO 1 I=1, N
+ XJ= XOB- X( I)
+ YJ= YOB- Y( I)
+ ZJ= ZOB- Z( I)
+ ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
+ IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
+ ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
+ XJ= BI( I)
+ IF( ZP.GT.0.9* XJ* XJ) GOTO 1
+ AX= XJ
+ GOTO 2
+ 1 CONTINUE
+ 2 DO 19 I=1, N
+ S= SI( I)
+ B= BI( I)
+ XJ= X( I)
+ YJ= Y( I)
+ ZJ= Z( I)
+ CABJ= CAB( I)
+ SABJ= SAB( I)
+ SALPJ= SALP( I)
+ IF( IEXK.EQ.0) GOTO 18
+ IPR= ICON1( I)
+ IF( IPR) 3,8,4
+ 3 IPR=- IPR
+ IF(- ICON1( IPR).NE. I) GOTO 9
+ GOTO 6
+ 4 IF( IPR.NE. I) GOTO 5
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 9
+ GOTO 7
+ 5 IF( ICON2( IPR).NE. I) GOTO 9
+ 6 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 9
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 9
+ 7 IND1=0
+ GOTO 10
+ 8 IND1=1
+ GOTO 10
+ 9 IND1=2
+ 10 IPR= ICON2( I)
+ IF( IPR) 11,16,12
+ 11 IPR=- IPR
+ IF(- ICON2( IPR).NE. I) GOTO 17
+ GOTO 14
+ 12 IF( IPR.NE. I) GOTO 13
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 17
+ GOTO 15
+ 13 IF( ICON1( IPR).NE. I) GOTO 17
+ 14 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 17
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 17
+ 15 IND2=0
+ GOTO 18
+ 16 IND2=1
+ GOTO 18
+ 17 IND2=2
+ 18 CONTINUE
+ CALL EFLD( XOB, YOB, ZOB, AX,1)
+ ACX= CMPLX( AIR( I), AII( I))
+ BCX= CMPLX( BIR( I), BII( I))
+ CCX= CMPLX( CIR( I), CII( I))
+ EX= EX+ EXK* ACX+ EXS* BCX+ EXC* CCX
+ EY= EY+ EYK* ACX+ EYS* BCX+ EYC* CCX
+ 19 EZ= EZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
+ IF( M.EQ.0) RETURN
+ 20 JC= N
+ JL= LD+1
+ DO 21 I=1, M
+ JL= JL-1
+ S= BI( JL)
+ XJ= X( JL)
+ YJ= Y( JL)
+ ZJ= Z( JL)
+ T1XJ= T1X( JL)
+ T1YJ= T1Y( JL)
+ T1ZJ= T1Z( JL)
+ T2XJ= T2X( JL)
+ T2YJ= T2Y( JL)
+ T2ZJ= T2Z( JL)
+ JC= JC+3
+ ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
+ BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
+ DO 21 IP=1, KSYMP
+ IPGND= IP
+ CALL UNERE( XOB, YOB, ZOB)
+ EX= EX+ ACX* EXK+ BCX* EXS
+ EY= EY+ ACX* EYK+ BCX* EYS
+ 21 EZ= EZ+ ACX* EZK+ BCX* EZS
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE NETWK( CM, CMB, CMC, CMD, IP, EINC)
+C ***
+C
+C SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
+C EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
+C PRESENT.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX CMN, RHNT, YMIT, RHS, ZPED, EINC, VSANT, VLT, CUR,
+ &VSRC, RHNX, VQD, VQDS, CUX, CM, CMB, CMC, CMD
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ COMMON /NETCX/ ZPED, PIN, PNLS, NEQ, NPEQ, NEQ2, NONET, NTSOL,
+ &NPRINT, MASYM, ISEG1(150), ISEG2(150), X11R(150), X11I(150),
+ &X12R(150), X12I(150), X22R(150), X22I(150), NTYP(150)
+ DIMENSION EINC(1), IP(1), CM(1), CMB(1), CMC(1), CMD(1)
+ DIMENSION CMN(150,150), RHNT(150), IPNT(150), NTEQA(150),
+ &NTSCA(150), RHS( N3M), VSRC(10), RHNX(150)
+ DATA NDIMN, NDIMNP/150,151/, TP/6.283185308D+0/
+ NEQZ2= NEQ2
+ IF( NEQZ2.EQ.0) NEQZ2=1
+ PIN=0.
+ PNLS=0.
+ NEQT= NEQ+ NEQ2
+ IF( NTSOL.NE.0) GOTO 42
+ NOP= NEQ/ NPEQ
+C
+C COMPUTE RELATIVE MATRIX ASYMMETRY
+C
+ IF( MASYM.EQ.0) GOTO 14
+ IROW1=0
+ IF( NONET.EQ.0) GOTO 5
+ DO 4 I=1, NONET
+ NSEG1= ISEG1( I)
+ DO 3 ISC1=1,2
+ IF( IROW1.EQ.0) GOTO 2
+ DO 1 J=1, IROW1
+ IF( NSEG1.EQ. IPNT( J)) GOTO 3
+ 1 CONTINUE
+ 2 IROW1= IROW1+1
+ IPNT( IROW1)= NSEG1
+ 3 NSEG1= ISEG2( I)
+ 4 CONTINUE
+ 5 IF( NSANT.EQ.0) GOTO 9
+ DO 8 I=1, NSANT
+ NSEG1= ISANT( I)
+ IF( IROW1.EQ.0) GOTO 7
+ DO 6 J=1, IROW1
+ IF( NSEG1.EQ. IPNT( J)) GOTO 8
+ 6 CONTINUE
+ 7 IROW1= IROW1+1
+ IPNT( IROW1)= NSEG1
+ 8 CONTINUE
+ 9 IF( IROW1.LT. NDIMNP) GOTO 10
+ WRITE (6,59)
+ STOP
+ 10 IF( IROW1.LT.2) GOTO 14
+ DO 12 I=1, IROW1
+ ISC1= IPNT( I)
+ ASM= SI( ISC1)
+ DO 11 J=1, NEQT
+ 11 RHS( J)=(0.,0.)
+ RHS( ISC1)=(1.,0.)
+ CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
+ &, NEQ2, NEQZ2)
+ CALL CABC( RHS)
+ DO 12 J=1, IROW1
+ ISC1= IPNT( J)
+ 12 CMN( J, I)= RHS( ISC1)/ ASM
+ ASM=0.
+ ASA=0.
+ DO 13 I=2, IROW1
+ ISC1= I-1
+ DO 13 J=1, ISC1
+ CUX= CMN( I, J)
+ PWR= ABS(( CUX- CMN( J, I))/ CUX)
+ ASA= ASA+ PWR* PWR
+ IF( PWR.LT. ASM) GOTO 13
+ ASM= PWR
+ NTEQ= IPNT( I)
+ NTSC= IPNT( J)
+ 13 CONTINUE
+ ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1)))
+ WRITE (6,58) ASM, NTEQ, NTSC, ASA
+C
+C SOLUTION OF NETWORK EQUATIONS
+C
+ 14 IF( NONET.EQ.0) GOTO 48
+ DO 15 I=1, NDIMN
+ RHNX( I)=(0.,0.)
+ DO 15 J=1, NDIMN
+ 15 CMN( I, J)=(0.,0.)
+ NTEQ=0
+C
+C SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
+C SEGMENTS.
+C
+ NTSC=0
+ DO 38 J=1, NONET
+ NSEG1= ISEG1( J)
+ NSEG2= ISEG2( J)
+ IF( NTYP( J).GT.1) GOTO 16
+ Y11R= X11R( J)
+ Y11I= X11I( J)
+ Y12R= X12R( J)
+ Y12I= X12I( J)
+ Y22R= X22R( J)
+ Y22I= X22I( J)
+ GOTO 17
+ 16 Y22R= TP* X11I( J)/ WLAM
+ Y12R=0.
+ Y12I=1./( X11R( J)* SIN( Y22R))
+ Y11R= X12R( J)
+ Y11I=- Y12I* COS( Y22R)
+ Y22R= X22R( J)
+ Y22I= Y11I+ X22I( J)
+ Y11I= Y11I+ X12I( J)
+ IF( NTYP( J).EQ.2) GOTO 17
+ Y12R=- Y12R
+ Y12I=- Y12I
+ 17 IF( NSANT.EQ.0) GOTO 19
+ DO 18 I=1, NSANT
+ IF( NSEG1.NE. ISANT( I)) GOTO 18
+ ISC1= I
+ GOTO 22
+ 18 CONTINUE
+ 19 ISC1=0
+ IF( NTEQ.EQ.0) GOTO 21
+ DO 20 I=1, NTEQ
+ IF( NSEG1.NE. NTEQA( I)) GOTO 20
+ IROW1= I
+ GOTO 25
+ 20 CONTINUE
+ 21 NTEQ= NTEQ+1
+ IROW1= NTEQ
+ NTEQA( NTEQ)= NSEG1
+ GOTO 25
+ 22 IF( NTSC.EQ.0) GOTO 24
+ DO 23 I=1, NTSC
+ IF( NSEG1.NE. NTSCA( I)) GOTO 23
+ IROW1= NDIMNP- I
+ GOTO 25
+ 23 CONTINUE
+ 24 NTSC= NTSC+1
+ IROW1= NDIMNP- NTSC
+ NTSCA( NTSC)= NSEG1
+ VSRC( NTSC)= VSANT( ISC1)
+ 25 IF( NSANT.EQ.0) GOTO 27
+ DO 26 I=1, NSANT
+ IF( NSEG2.NE. ISANT( I)) GOTO 26
+ ISC2= I
+ GOTO 30
+ 26 CONTINUE
+ 27 ISC2=0
+ IF( NTEQ.EQ.0) GOTO 29
+ DO 28 I=1, NTEQ
+ IF( NSEG2.NE. NTEQA( I)) GOTO 28
+ IROW2= I
+ GOTO 33
+ 28 CONTINUE
+ 29 NTEQ= NTEQ+1
+ IROW2= NTEQ
+ NTEQA( NTEQ)= NSEG2
+ GOTO 33
+ 30 IF( NTSC.EQ.0) GOTO 32
+ DO 31 I=1, NTSC
+ IF( NSEG2.NE. NTSCA( I)) GOTO 31
+ IROW2= NDIMNP- I
+ GOTO 33
+ 31 CONTINUE
+ 32 NTSC= NTSC+1
+ IROW2= NDIMNP- NTSC
+ NTSCA( NTSC)= NSEG2
+ VSRC( NTSC)= VSANT( ISC2)
+ 33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34
+ WRITE (6,59)
+C
+C FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
+C NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
+C
+ STOP
+ 34 IF( ISC1.NE.0) GOTO 35
+ CMN( IROW1, IROW1)= CMN( IROW1, IROW1)- CMPLX( Y11R, Y11I)* SI(
+ &NSEG1)
+ CMN( IROW1, IROW2)= CMN( IROW1, IROW2)- CMPLX( Y12R, Y12I)* SI(
+ &NSEG1)
+ GOTO 36
+ 35 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y11R, Y11I)* VSANT( ISC1)/
+ &WLAM
+ RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y12R, Y12I)* VSANT( ISC1)/
+ &WLAM
+ 36 IF( ISC2.NE.0) GOTO 37
+ CMN( IROW2, IROW2)= CMN( IROW2, IROW2)- CMPLX( Y22R, Y22I)* SI(
+ &NSEG2)
+ CMN( IROW2, IROW1)= CMN( IROW2, IROW1)- CMPLX( Y12R, Y12I)* SI(
+ &NSEG2)
+ GOTO 38
+ 37 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y12R, Y12I)* VSANT( ISC2)/
+ &WLAM
+ RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y22R, Y22I)* VSANT( ISC2)/
+ &WLAM
+C
+C ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
+C MATRIX
+C
+ 38 CONTINUE
+ DO 41 I=1, NTEQ
+ DO 39 J=1, NEQT
+ 39 RHS( J)=(0.,0.)
+ IROW1= NTEQA( I)
+ RHS( IROW1)=(1.,0.)
+ CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
+ &, NEQ2, NEQZ2)
+ CALL CABC( RHS)
+ DO 40 J=1, NTEQ
+ IROW1= NTEQA( J)
+ 40 CMN( I, J)= CMN( I, J)+ RHS( IROW1)
+C
+C FACTOR NETWORK EQUATION MATRIX
+C
+ 41 CONTINUE
+C
+C ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
+C INTERACTIONS
+C
+ CALL FACTR( NTEQ, CMN, IPNT, NDIMN)
+ 42 IF( NONET.EQ.0) GOTO 48
+ DO 43 I=1, NEQT
+ 43 RHS( I)= EINC( I)
+ CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
+ &, NEQ2, NEQZ2)
+ CALL CABC( RHS)
+ DO 44 I=1, NTEQ
+ IROW1= NTEQA( I)
+C
+C SOLVE NETWORK EQUATIONS
+C
+ 44 RHNT( I)= RHNX( I)+ RHS( IROW1)
+C
+C ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
+C STRUCTURE AND SOLVE FOR INDUCED CURRENT
+C
+ CALL SOLVE( NTEQ, CMN, IPNT, RHNT, NDIMN)
+ DO 45 I=1, NTEQ
+ IROW1= NTEQA( I)
+ 45 EINC( IROW1)= EINC( IROW1)- RHNT( I)
+ CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M,
+ &NEQ, NEQ2, NEQZ2)
+ CALL CABC( EINC)
+ IF( NPRINT.EQ.0) WRITE (6,61)
+ IF( NPRINT.EQ.0) WRITE (6,60)
+ DO 46 I=1, NTEQ
+ IROW1= NTEQA( I)
+ VLT= RHNT( I)* SI( IROW1)* WLAM
+ CUX= EINC( IROW1)* WLAM
+ YMIT= CUX/ VLT
+ ZPED= VLT/ CUX
+ IROW2= ITAG( IROW1)
+ PWR=.5* REAL( VLT* CONJG( CUX))
+ PNLS= PNLS- PWR
+ 46 IF( NPRINT.EQ.0) WRITE (6,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
+ &, PWR
+ IF( NTSC.EQ.0) GOTO 49
+ DO 47 I=1, NTSC
+ IROW1= NTSCA( I)
+ VLT= VSRC( I)
+ CUX= EINC( IROW1)* WLAM
+ YMIT= CUX/ VLT
+ ZPED= VLT/ CUX
+ IROW2= ITAG( IROW1)
+ PWR=.5* REAL( VLT* CONJG( CUX))
+ PNLS= PNLS- PWR
+ 47 IF( NPRINT.EQ.0) WRITE (6,62) IROW2, IROW1, VLT, CUX, ZPED, YMIT
+ &, PWR
+C
+C SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
+C
+ GOTO 49
+ 48 CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M,
+ &NEQ, NEQ2, NEQZ2)
+ CALL CABC( EINC)
+ NTSC=0
+ 49 IF( NSANT+ NVQD.EQ.0) RETURN
+ WRITE (6,63)
+ WRITE (6,60)
+ IF( NSANT.EQ.0) GOTO 56
+ DO 55 I=1, NSANT
+ ISC1= ISANT( I)
+ VLT= VSANT( I)
+ IF( NTSC.EQ.0) GOTO 51
+ DO 50 J=1, NTSC
+ IF( NTSCA( J).EQ. ISC1) GOTO 52
+ 50 CONTINUE
+ 51 CUX= EINC( ISC1)* WLAM
+ IROW1=0
+ GOTO 54
+ 52 IROW1= NDIMNP- J
+ CUX= RHNX( IROW1)
+ DO 53 J=1, NTEQ
+ 53 CUX= CUX- CMN( J, IROW1)* RHNT( J)
+ CUX=( EINC( ISC1)+ CUX)* WLAM
+ 54 YMIT= CUX/ VLT
+ ZPED= VLT/ CUX
+ PWR=.5* REAL( VLT* CONJG( CUX))
+ PIN= PIN+ PWR
+ IF( IROW1.NE.0) PNLS= PNLS+ PWR
+ IROW2= ITAG( ISC1)
+ 55 WRITE (6,62) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
+ 56 IF( NVQD.EQ.0) RETURN
+ DO 57 I=1, NVQD
+ ISC1= IVQD( I)
+ VLT= VQD( I)
+ CUX= CMPLX( AIR( ISC1), AII( ISC1))
+ YMIT= CMPLX( BIR( ISC1), BII( ISC1))
+ ZPED= CMPLX( CIR( ISC1), CII( ISC1))
+ PWR= SI( ISC1)* TP*.5
+ CUX=( CUX- YMIT* SIN( PWR)+ ZPED* COS( PWR))* WLAM
+ YMIT= CUX/ VLT
+ ZPED= VLT/ CUX
+ PWR=.5* REAL( VLT* CONJG( CUX))
+ PIN= PIN+ PWR
+ IROW2= ITAG( ISC1)
+ 57 WRITE (6,64) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
+C
+ RETURN
+ 58 FORMAT(///,3X,'MAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT',
+ &' ADMITTANCE MATRIX IS',1P,E10.3,' FOR SEGMENTS',I5,4H AND,I5,/,3
+ &X,'RMS RELATIVE ASYMMETRY IS',E10.3)
+ 59 FORMAT(1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
+ 60 FORMAT(/,3X,'TAG',3X,'SEG.',4X,'VOLTAGE (VOLTS)',9X,'CURRENT (',
+ &'AMPS)',9X,'IMPEDANCE (OHMS)',8X,'ADMITTANCE (MHOS)',6X,'POWER',/
+ &,3X,'NO.',3X,'NO.',4X,'REAL',8X,'IMAG.',3(7X,'REAL',8X,'IMAG.'),5
+ &X,'(WATTS)')
+ 61 FORMAT(///,27X,'- - - STRUCTURE EXCITATION DATA AT NETWORK CONN',
+ &'ECTION POINTS - - -')
+ 62 FORMAT(2(1X,I5),1P,9E12.5)
+ 63 FORMAT(///,42X,'- - - ANTENNA INPUT PARAMETERS - - -')
+ 64 FORMAT(1X,I5,' *',I4,1P,9E12.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE NFPAT
+C ***
+C COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EX, EY, EZ
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+C***
+ COMMON /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
+ &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
+ &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
+ &
+C***
+ COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
+ DATA TA/1.745329252D-02/
+ IF( NFEH.EQ.1) GOTO 1
+ WRITE (6,10)
+ GOTO 2
+ 1 WRITE (6,12)
+ 2 ZNRT= ZNR- DZNR
+ DO 9 I=1, NRZ
+ ZNRT= ZNRT+ DZNR
+ IF( NEAR.EQ.0) GOTO 3
+ CTH= COS( TA* ZNRT)
+ STH= SIN( TA* ZNRT)
+ 3 YNRT= YNR- DYNR
+ DO 9 J=1, NRY
+ YNRT= YNRT+ DYNR
+ IF( NEAR.EQ.0) GOTO 4
+ CPH= COS( TA* YNRT)
+ SPH= SIN( TA* YNRT)
+ 4 XNRT= XNR- DXNR
+ DO 9 KK=1, NRX
+ XNRT= XNRT+ DXNR
+ IF( NEAR.EQ.0) GOTO 5
+ XOB= XNRT* STH* CPH
+ YOB= XNRT* STH* SPH
+ ZOB= XNRT* CTH
+ GOTO 6
+ 5 XOB= XNRT
+ YOB= YNRT
+ ZOB= ZNRT
+ 6 TMP1= XOB/ WLAM
+ TMP2= YOB/ WLAM
+ TMP3= ZOB/ WLAM
+ IF( NFEH.EQ.1) GOTO 7
+ CALL NEFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
+ GOTO 8
+ 7 CALL NHFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
+ 8 TMP1= ABS( EX)
+ TMP2= CANG( EX)
+ TMP3= ABS( EY)
+ TMP4= CANG( EY)
+ TMP5= ABS( EZ)
+ TMP6= CANG( EZ)
+C***
+ WRITE (6,11) XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6
+ IF( IPLP1.NE.2) GOTO 9
+ GOTO (14,15,16), IPLP4
+ 14 XXX= XOB
+ GOTO 17
+ 15 XXX= YOB
+ GOTO 17
+ 16 XXX= ZOB
+ 17 CONTINUE
+ IF( IPLP2.NE.2) GOTO 13
+ IF( IPLP3.EQ.1) WRITE( 8,*) XXX, TMP1, TMP2
+ IF( IPLP3.EQ.2) WRITE( 8,*) XXX, TMP3, TMP4
+ IF( IPLP3.EQ.3) WRITE( 8,*) XXX, TMP5, TMP6
+ IF( IPLP3.EQ.4) WRITE( 8,*) XXX, TMP1, TMP2, TMP3, TMP4, TMP5,
+ &TMP6
+ GOTO 9
+ 13 IF( IPLP2.NE.1) GOTO 9
+ IF( IPLP3.EQ.1) WRITE( 8,*) XXX, EX
+ IF( IPLP3.EQ.2) WRITE( 8,*) XXX, EY
+ IF( IPLP3.EQ.3) WRITE( 8,*) XXX, EZ
+C***
+ IF( IPLP3.EQ.4) WRITE( 8,*) XXX, EX, EY, EZ
+ 9 CONTINUE
+C
+ RETURN
+ 10 FORMAT(///,35X,'- - - NEAR ELECTRIC FIELDS - - -',//,12X,'- L',
+ &'OCATION -',21X,'- EX -',15X,'- EY -',15X,'- EZ -',/,8X,
+ &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
+ &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
+ &'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',6X
+ &,'VOLTS/M',3X,'DEGREES')
+ 11 FORMAT(2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2))
+ 12 FORMAT(///,35X,'- - - NEAR MAGNETIC FIELDS - - -',//,12X,'- L',
+ &'OCATION -',21X,'- HX -',15X,'- HY -',15X,'- HZ -',/,8X,
+ &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
+ &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
+ &'METERS',9X,'AMPS/M',3X,'DEGREES',7X,'AMPS/M',3X,'DEGREES',7X,
+ &'AMPS/M',3X,'DEGREES')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE NHFLD( XOB, YOB, ZOB, HX, HY, HZ)
+C ***
+C
+C NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
+C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEXHX,HY,HZ,CUR,ACX, BCX, CCX, EXK, EYK, EZK, EXS, EYS,
+ &EZS, EXC, EYC, EZC
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ COMMON /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
+ &CII( NM), CUR( N3M)
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ DIMENSION CAB(1), SAB(1)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1),
+ & YS(1), ZS(1)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG),(XS,X),(YS,Y),(ZS,Z)
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ EQUIVALENCE(CAB,ALP),(SAB,BET)
+ HX=(0.,0.)
+ HY=(0.,0.)
+ HZ=(0.,0.)
+ AX=0.
+ IF( N.EQ.0) GOTO 4
+ DO 1 I=1, N
+ XJ= XOB- X( I)
+ YJ= YOB- Y( I)
+ ZJ= ZOB- Z( I)
+ ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
+ IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
+ ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
+ XJ= BI( I)
+ IF( ZP.GT.0.9* XJ* XJ) GOTO 1
+ AX= XJ
+ GOTO 2
+ 1 CONTINUE
+ 2 DO 3 I=1, N
+ S= SI( I)
+ B= BI( I)
+ XJ= X( I)
+ YJ= Y( I)
+ ZJ= Z( I)
+ CABJ= CAB( I)
+ SABJ= SAB( I)
+ SALPJ= SALP( I)
+ CALL HSFLD( XOB, YOB, ZOB, AX)
+ ACX= CMPLX( AIR( I), AII( I))
+ BCX= CMPLX( BIR( I), BII( I))
+ CCX= CMPLX( CIR( I), CII( I))
+ HX= HX+ EXK* ACX+ EXS* BCX+ EXC* CCX
+ HY= HY+ EYK* ACX+ EYS* BCX+ EYC* CCX
+ 3 HZ= HZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
+ IF( M.EQ.0) RETURN
+ 4 JC= N
+ JL= LD+1
+ DO 5 I=1, M
+ JL= JL-1
+ S= BI( JL)
+ XJ= X( JL)
+ YJ= Y( JL)
+ ZJ= Z( JL)
+ T1XJ= T1X( JL)
+ T1YJ= T1Y( JL)
+ T1ZJ= T1Z( JL)
+ T2XJ= T2X( JL)
+ T2YJ= T2Y( JL)
+ T2ZJ= T2Z( JL)
+ CALL HINTG( XOB, YOB, ZOB)
+ JC= JC+3
+ ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
+ BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
+ HX= HX+ ACX* EXK+ BCX* EXS
+ HY= HY+ ACX* EYK+ BCX* EYS
+ 5 HZ= HZ+ ACX* EZK+ BCX* EZS
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE PATCH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4,
+ & Y4, Z4)
+C ***
+C PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+C NEW PATCHES. FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY)
+C ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL.
+C FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH
+C NX BY NY RECTANGULAR PATCHES.
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ M= M+1
+ MI= LD+1- M
+ NTP= NY
+ IF( NX.GT.0) NTP=2
+ IF( NTP.GT.1) GOTO 2
+ X( MI)= X1
+ Y( MI)= Y1
+ Z( MI)= Z1
+ BI( MI)= Z2
+ ZNV= COS( X2)
+ XNV= ZNV* COS( Y2)
+ YNV= ZNV* SIN( Y2)
+ ZNV= SIN( X2)
+ XA= SQRT( XNV* XNV+ YNV* YNV)
+ IF( XA.LT.1.D-6) GOTO 1
+ T1X( MI)=- YNV/ XA
+ T1Y( MI)= XNV/ XA
+ T1Z( MI)=0.
+ GOTO 6
+ 1 T1X( MI)=1.
+ T1Y( MI)=0.
+ T1Z( MI)=0.
+ GOTO 6
+ 2 S1X= X2- X1
+ S1Y= Y2- Y1
+ S1Z= Z2- Z1
+ S2X= X3- X2
+ S2Y= Y3- Y2
+ S2Z= Z3- Z2
+ IF( NX.EQ.0) GOTO 3
+ S1X= S1X/ NX
+ S1Y= S1Y/ NX
+ S1Z= S1Z/ NX
+ S2X= S2X/ NY
+ S2Y= S2Y/ NY
+ S2Z= S2Z/ NY
+ 3 XNV= S1Y* S2Z- S1Z* S2Y
+ YNV= S1Z* S2X- S1X* S2Z
+ ZNV= S1X* S2Y- S1Y* S2X
+ XA= SQRT( XNV* XNV+ YNV* YNV+ ZNV* ZNV)
+ XNV= XNV/ XA
+ YNV= YNV/ XA
+ ZNV= ZNV/ XA
+ XST= SQRT( S1X* S1X+ S1Y* S1Y+ S1Z* S1Z)
+ T1X( MI)= S1X/ XST
+ T1Y( MI)= S1Y/ XST
+ T1Z( MI)= S1Z/ XST
+ IF( NTP.GT.2) GOTO 4
+ X( MI)= X1+.5*( S1X+ S2X)
+ Y( MI)= Y1+.5*( S1Y+ S2Y)
+ Z( MI)= Z1+.5*( S1Z+ S2Z)
+ BI( MI)= XA
+ GOTO 6
+ 4 IF( NTP.EQ.4) GOTO 5
+ X( MI)=( X1+ X2+ X3)/3.
+ Y( MI)=( Y1+ Y2+ Y3)/3.
+ Z( MI)=( Z1+ Z2+ Z3)/3.
+ BI( MI)=.5* XA
+ GOTO 6
+ 5 S1X= X3- X1
+ S1Y= Y3- Y1
+ S1Z= Z3- Z1
+ S2X= X4- X1
+ S2Y= Y4- Y1
+ S2Z= Z4- Z1
+ XN2= S1Y* S2Z- S1Z* S2Y
+ YN2= S1Z* S2X- S1X* S2Z
+ ZN2= S1X* S2Y- S1Y* S2X
+ XST= SQRT( XN2* XN2+ YN2* YN2+ ZN2* ZN2)
+ SALPN=1./(3.*( XA+ XST))
+ X( MI)=( XA*( X1+ X2+ X3)+ XST*( X1+ X3+ X4))* SALPN
+ Y( MI)=( XA*( Y1+ Y2+ Y3)+ XST*( Y1+ Y3+ Y4))* SALPN
+ Z( MI)=( XA*( Z1+ Z2+ Z3)+ XST*( Z1+ Z3+ Z4))* SALPN
+ BI( MI)=.5*( XA+ XST)
+ S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST
+ IF( S1X.GT.0.9998) GOTO 6
+ WRITE (6,14)
+ STOP
+ 6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI)
+ T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI)
+ T2Z( MI)= XNV* T1Y( MI)- YNV* T1X( MI)
+ SALP( MI)=1.
+ IF( NX.EQ.0) GOTO 8
+ M= M+ NX* NY-1
+ XN2= X( MI)- S1X- S2X
+ YN2= Y( MI)- S1Y- S2Y
+ ZN2= Z( MI)- S1Z- S2Z
+ XS= T1X( MI)
+ YS= T1Y( MI)
+ ZS= T1Z( MI)
+ XT= T2X( MI)
+ YT= T2Y( MI)
+ ZT= T2Z( MI)
+ MI= MI+1
+ DO 7 IY=1, NY
+ XN2= XN2+ S2X
+ YN2= YN2+ S2Y
+ ZN2= ZN2+ S2Z
+ DO 7 IX=1, NX
+ XST= IX
+ MI= MI-1
+ X( MI)= XN2+ XST* S1X
+ Y( MI)= YN2+ XST* S1Y
+ Z( MI)= ZN2+ XST* S1Z
+ BI( MI)= XA
+ SALP( MI)=1.
+ T1X( MI)= XS
+ T1Y( MI)= YS
+ T1Z( MI)= ZS
+ T2X( MI)= XT
+ T2Y( MI)= YT
+ 7 T2Z( MI)= ZT
+ 8 IPSYM=0
+ NP= N
+ MP= M
+C DIVIDE PATCH FOR WIRE CONNECTION
+ RETURN
+ ENTRY SUBPH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4,
+ &Z4)
+ IF( NY.GT.0) GOTO 10
+ IF( NX.EQ. M) GOTO 10
+ NXP= NX+1
+ IX= LD- M
+ DO 9 IY= NXP, M
+ IX= IX+1
+ NYP= IX-3
+ X( NYP)= X( IX)
+ Y( NYP)= Y( IX)
+ Z( NYP)= Z( IX)
+ BI( NYP)= BI( IX)
+ SALP( NYP)= SALP( IX)
+ T1X( NYP)= T1X( IX)
+ T1Y( NYP)= T1Y( IX)
+ T1Z( NYP)= T1Z( IX)
+ T2X( NYP)= T2X( IX)
+ T2Y( NYP)= T2Y( IX)
+ 9 T2Z( NYP)= T2Z( IX)
+ 10 MI= LD+1- NX
+ XS= X( MI)
+ YS= Y( MI)
+ ZS= Z( MI)
+ XA= BI( MI)*.25
+ XST= SQRT( XA)*.5
+ S1X= T1X( MI)
+ S1Y= T1Y( MI)
+ S1Z= T1Z( MI)
+ S2X= T2X( MI)
+ S2Y= T2Y( MI)
+ S2Z= T2Z( MI)
+ SALN= SALP( MI)
+ XT= XST
+ YT= XST
+ IF( NY.GT.0) GOTO 11
+ MIA= MI
+ GOTO 12
+ 11 M= M+1
+ MP= MP+1
+ MIA= LD+1- M
+ 12 DO 13 IX=1,4
+ X( MIA)= XS+ XT* S1X+ YT* S2X
+ Y( MIA)= YS+ XT* S1Y+ YT* S2Y
+ Z( MIA)= ZS+ XT* S1Z+ YT* S2Z
+ BI( MIA)= XA
+ T1X( MIA)= S1X
+ T1Y( MIA)= S1Y
+ T1Z( MIA)= S1Z
+ T2X( MIA)= S2X
+ T2Y( MIA)= S2Y
+ T2Z( MIA)= S2Z
+ SALP( MIA)= SALN
+ IF( IX.EQ.2) YT=- YT
+ IF( IX.EQ.1.OR. IX.EQ.3) XT=- XT
+ MIA= MIA-1
+ 13 CONTINUE
+ M= M+3
+ IF( NX.LE. MP) MP= MP+3
+ IF( NY.GT.0) Z( MI)=10000.
+C
+ RETURN
+ 14 FORMAT(' ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN ',
+ &'A PLANE')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE PCINT( XI, YI, ZI, CABI, SABI, SALPI, E)
+C ***
+C INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, E, E1,
+ &E2, E3, E4, E5, E6, E7, E8, E9
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, PGND
+ DIMENSION E(9)
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+ DATA TPI/6.283185308D+0/, NINT/10/
+ D= SQRT( S)*.5
+ DS=4.* D/ DFLOAT( NINT)
+ DA= DS* DS
+ GCON=1./ S
+ FCON=1./(2.* TPI* D)
+ XXJ= XJ
+ XYJ= YJ
+ XZJ= ZJ
+ XS= S
+ S= DA
+ S1= D+ DS*.5
+ XSS= XJ+ S1*( T1XJ+ T2XJ)
+ YSS= YJ+ S1*( T1YJ+ T2YJ)
+ ZSS= ZJ+ S1*( T1ZJ+ T2ZJ)
+ S1= S1+ D
+ S2X= S1
+ E1=(0.,0.)
+ E2=(0.,0.)
+ E3=(0.,0.)
+ E4=(0.,0.)
+ E5=(0.,0.)
+ E6=(0.,0.)
+ E7=(0.,0.)
+ E8=(0.,0.)
+ E9=(0.,0.)
+ DO 1 I1=1, NINT
+ S1= S1- DS
+ S2= S2X
+ XSS= XSS- DS* T1XJ
+ YSS= YSS- DS* T1YJ
+ ZSS= ZSS- DS* T1ZJ
+ XJ= XSS
+ YJ= YSS
+ ZJ= ZSS
+ DO 1 I2=1, NINT
+ S2= S2- DS
+ XJ= XJ- DS* T2XJ
+ YJ= YJ- DS* T2YJ
+ ZJ= ZJ- DS* T2ZJ
+ CALL UNERE( XI, YI, ZI)
+ EXK= EXK* CABI+ EYK* SABI+ EZK* SALPI
+ EXS= EXS* CABI+ EYS* SABI+ EZS* SALPI
+ G1=( D+ S1)*( D+ S2)* GCON
+ G2=( D- S1)*( D+ S2)* GCON
+ G3=( D- S1)*( D- S2)* GCON
+ G4=( D+ S1)*( D- S2)* GCON
+ F2=( S1* S1+ S2* S2)* TPI
+ F1= S1/ F2-( G1- G2- G3+ G4)* FCON
+ F2= S2/ F2-( G1+ G2- G3- G4)* FCON
+ E1= E1+ EXK* G1
+ E2= E2+ EXK* G2
+ E3= E3+ EXK* G3
+ E4= E4+ EXK* G4
+ E5= E5+ EXS* G1
+ E6= E6+ EXS* G2
+ E7= E7+ EXS* G3
+ E8= E8+ EXS* G4
+ 1 E9= E9+ EXK* F1+ EXS* F2
+ E(1)= E1
+ E(2)= E2
+ E(3)= E3
+ E(4)= E4
+ E(5)= E5
+ E(6)= E6
+ E(7)= E7
+ E(8)= E8
+ E(9)= E9
+ XJ= XXJ
+ YJ= XYJ
+ ZJ= XZJ
+ S= XS
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE PRNT( IN1, IN2, IN3, FL1, FL2, FL3, FL4, FL5, FL6, IA,
+ & ICHAR)
+C ***
+C
+C PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ CHARACTER*6 IFORM, IVAR
+ CHARACTER *(*) IA
+ DIMENSION IVAR(13), IA(1), IFORM(8), IN(3), INT(3), FL(6), FLT(6
+ &)
+ INTEGER HALL
+C
+C NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW
+C
+ DATA IFORM/5H(/3X,,3HI5,,3H5X,,3HA5,,6HE13.4,,4H13X,,3H3X,,
+ &4H5A4)/
+ DATA HALL/4H ALL/
+ IN(1)= IN1
+ IN(2)= IN2
+ IN(3)= IN3
+ FL(1)= FL1
+ FL(2)= FL2
+ FL(3)= FL3
+ FL(4)= FL4
+ FL(5)= FL5
+C
+C INTEGER FORMAT
+C
+ FL(6)= FL6
+ NINT=0
+ IVAR(1)= IFORM(1)
+ K=1
+ I1=1
+ IF(.NOT.( IN1.EQ.0.AND. IN2.EQ.0.AND. IN3.EQ.0)) GOTO 1
+ INT(1)= HALL
+ NINT=1
+ I1=2
+ K= K+1
+ IVAR( K)= IFORM(4)
+ 1 DO 3 I= I1,3
+ K= K+1
+ IF( IN( I).EQ.0) GOTO 2
+ NINT= NINT+1
+ INT( NINT)= IN( I)
+ IVAR( K)= IFORM(2)
+ GOTO 3
+ 2 IVAR( K)= IFORM(3)
+ 3 CONTINUE
+ K= K+1
+C
+C DFLOATING POINT FORMAT
+C
+ IVAR( K)= IFORM(7)
+ NFLT=0
+ DO 5 I=1,6
+ K= K+1
+ IF( ABS( FL( I)).LT.1.D-20) GOTO 4
+ NFLT= NFLT+1
+ FLT( NFLT)= FL( I)
+ IVAR( K)= IFORM(5)
+ GOTO 5
+ 4 IVAR( K)= IFORM(6)
+ 5 CONTINUE
+ K= K+1
+ IVAR( K)= IFORM(7)
+ K= K+1
+ IVAR( K)= IFORM(8)
+ WRITE (6,IVAR) ( INT( I), I=1, NINT),( FLT( J), J=1, NFLT),
+ * ( IA( L), L=1, ICHAR)
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE QDSRC( IS, V, E)
+C ***
+C FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX VQDS, CURD, CCJ, V, EXK, EYK, EZK, EXS, EYS, EZS, EXC
+ &, EYC, EZC, ETK, ETS, ETC, VSANT, VQD, E, ZARRAY
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
+ &, IQDS(30), NVQD, NSANT, NQDS
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /ANGL/ SALP( NM)
+ COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
+ DIMENSION CCJX(2), E(1), CAB(1), SAB(1)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
+ EQUIVALENCE(CCJ,CCJX),(CAB,ALP),(SAB,BET)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG)
+ DATA TP/6.283185308D+0/, CCJX/0.,-.01666666667D+0/
+ I= ICON1( IS)
+ ICON1( IS)=0
+ CALL TBF( IS,0)
+ ICON1( IS)= I
+ S= SI( IS)*.5
+ CURD= CCJ* V/(( LOG(2.* S/ BI( IS))-1.)*( BX( JSNO)* COS( TP* S)+
+ & CX( JSNO)* SIN( TP* S))* WLAM)
+ NQDS= NQDS+1
+ VQDS( NQDS)= V
+ IQDS( NQDS)= IS
+ DO 20 JX=1, JSNO
+ J= JCO( JX)
+ S= SI( J)
+ B= BI( J)
+ XJ= X( J)
+ YJ= Y( J)
+ ZJ= Z( J)
+ CABJ= CAB( J)
+ SABJ= SAB( J)
+ SALPJ= SALP( J)
+ IF( IEXK.EQ.0) GOTO 16
+ IPR= ICON1( J)
+ IF( IPR) 1,6,2
+ 1 IPR=- IPR
+ IF(- ICON1( IPR).NE. J) GOTO 7
+ GOTO 4
+ 2 IF( IPR.NE. J) GOTO 3
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
+ GOTO 5
+ 3 IF( ICON2( IPR).NE. J) GOTO 7
+ 4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 7
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
+ 5 IND1=0
+ GOTO 8
+ 6 IND1=1
+ GOTO 8
+ 7 IND1=2
+ 8 IPR= ICON2( J)
+ IF( IPR) 9,14,10
+ 9 IPR=- IPR
+ IF(- ICON2( IPR).NE. J) GOTO 15
+ GOTO 12
+ 10 IF( IPR.NE. J) GOTO 11
+ IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
+ GOTO 13
+ 11 IF( ICON1( IPR).NE. J) GOTO 15
+ 12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
+ IF( XI.LT.0.999999D+0) GOTO 15
+ IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
+ 13 IND2=0
+ GOTO 16
+ 14 IND2=1
+ GOTO 16
+ 15 IND2=2
+ 16 CONTINUE
+ DO 17 I=1, N
+ IJ= I- J
+ XI= X( I)
+ YI= Y( I)
+ ZI= Z( I)
+ AI= BI( I)
+ CALL EFLD( XI, YI, ZI, AI, IJ)
+ CABI= CAB( I)
+ SABI= SAB( I)
+ SALPI= SALP( I)
+ ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
+ ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
+ ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
+ 17 E( I)= E( I)-( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD
+ IF( M.EQ.0) GOTO 19
+ IJ= LD+1
+ I1= N
+ DO 18 I=1, M
+ IJ= IJ-1
+ XI= X( IJ)
+ YI= Y( IJ)
+ ZI= Z( IJ)
+ CALL HSFLD( XI, YI, ZI,0.)
+ I1= I1+1
+ TX= T2X( IJ)
+ TY= T2Y( IJ)
+ TZ= T2Z( IJ)
+ ETK= EXK* TX+ EYK* TY+ EZK* TZ
+ ETS= EXS* TX+ EYS* TY+ EZS* TZ
+ ETC= EXC* TX+ EYC* TY+ EZC* TZ
+ E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
+ & SALP( IJ)
+ I1= I1+1
+ TX= T1X( IJ)
+ TY= T1Y( IJ)
+ TZ= T1Z( IJ)
+ ETK= EXK* TX+ EYK* TY+ EZK* TZ
+ ETS= EXS* TX+ EYS* TY+ EZS* TZ
+ ETC= EXC* TX+ EYC* TY+ EZC* TZ
+ 18 E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
+ & SALP( IJ)
+ 19 IF( NLOAD.GT.0.OR. NLODF.GT.0) E( J)= E( J)+ ZARRAY( J)* CURD*(
+ &AX( JX)+ CX( JX))
+ 20 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE RDPAT
+C ***
+C COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+C INTEGER HBLK,HCIR,HCLIF
+ CHARACTER*6 IGNTP, IGAX, IGTP, HPOL, HCIR, HCLIF, HBLK
+ CHARACTER*6 ISENS
+ integer*4 COM
+ COMPLEX ETH, EPH, ERD, ZRATI, ZRATI2, T1, FRATI
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /SAVE/ IP( N2M), KCOM, COM(20,5), EPSR, SIG, SCRWLT,
+ &SCRWRT, FMHZ
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ COMMON /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
+ &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
+ &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
+ &
+C***
+ COMMON /SCRATM/ GAIN(2*N2M)
+C***
+ COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
+ DIMENSION IGTP(4), IGAX(4), IGNTP(10), HPOL(3)
+ DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/, HBLK, HCIR/1H ,6HCIRCLE/
+ DATA IGTP/6H - ,6HPOWER ,6H- DIRE,6HCTIVE /
+ DATA IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. /
+ DATA IGNTP/6H MAJOR,6H AXIS ,6H MINOR,6H AXIS ,6H VER,
+ &6HTICAL ,6H HORIZ,6HONTAL ,6H ,6HTOTAL /
+ DATA PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/
+ DATA NORMAX/1200/
+ IF( IFAR.LT.2) GOTO 2
+ WRITE (6,35)
+ IF( IFAR.LE.3) GOTO 1
+ WRITE (6,36) NRADL, SCRWLT, SCRWRT
+ IF( IFAR.EQ.4) GOTO 2
+ 1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1)
+ IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR
+ CL= CLT/ WLAM
+ CH= CHT/ WLAM
+ ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96))
+ WRITE (6,37) HCLIF, CLT, CHT, EPSR2, SIG2
+ 2 IF( IFAR.NE.1) GOTO 3
+ WRITE (6,41)
+ GOTO 5
+ 3 I=2* IPD+1
+ J= I+1
+ ITMP1=2* IAX+1
+ ITMP2= ITMP1+1
+ WRITE (6,38)
+ IF( RFLD.LT.1.D-20) GOTO 4
+ EXRM=1./ RFLD
+ EXRA= RFLD/ WLAM
+ EXRA=-360.*( EXRA- AINT( EXRA))
+ WRITE (6,39) RFLD, EXRM, EXRA
+ 4 WRITE (6,40) IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2)
+ 5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7
+ IF( IXTYP.EQ.4) GOTO 6
+ PRAD=0.
+ GCON=4.* PI/(1.+ XPR6* XPR6)
+ GCOP= GCON
+ GOTO 8
+ 6 PINR=394.51* XPR6* XPR6* WLAM* WLAM
+ 7 GCOP= WLAM* WLAM*2.* PI/(376.73* PINR)
+ PRAD= PINR- PLOSS- PNLR
+ GCON= GCOP
+ IF( IPD.NE.0) GCON= GCON* PINR/ PRAD
+ 8 I=0
+ GMAX=-1.E10
+ PINT=0.
+ TMP1= DPH* TA
+ TMP2=.5* DTH* TA
+ PHI= PHIS- DPH
+ DO 29 KPH=1, NPH
+ PHI= PHI+ DPH
+ PHA= PHI* TA
+ THET= THETS- DTH
+ DO 29 KTH=1, NTH
+ THET= THET+ DTH
+ IF( KSYMP.EQ.2.AND. THET.GT.90.01.AND. IFAR.NE.1) GOTO 29
+ THA= THET* TA
+ IF( IFAR.EQ.1) GOTO 9
+ CALL FFLD( THA, PHA, ETH, EPH)
+ GOTO 10
+ 9 CALL GFLD( RFLD/ WLAM, PHA, THET/ WLAM, ETH, EPH, ERD, ZRATI,
+ &KSYMP)
+ ERDM= ABS( ERD)
+ ERDA= CANG( ERD)
+ 10 ETHM2= REAL( ETH* CONJG( ETH))
+ ETHM= SQRT( ETHM2)
+ ETHA= CANG( ETH)
+ EPHM2= REAL( EPH* CONJG( EPH))
+ EPHM= SQRT( EPHM2)
+ EPHA= CANG( EPH)
+C ELLIPTICAL POLARIZATION CALC.
+ IF( IFAR.EQ.1) GOTO 28
+ IF( ETHM2.GT.1.D-20.OR. EPHM2.GT.1.D-20) GOTO 11
+ TILTA=0.
+ EMAJR2=0.
+ EMINR2=0.
+ AXRAT=0.
+ ISENS= HBLK
+ GOTO 16
+ 11 DFAZ= EPHA- ETHA
+ IF( EPHA.LT.0.) GOTO 12
+ DFAZ2= DFAZ-360.
+ GOTO 13
+ 12 DFAZ2= DFAZ+360.
+ 13 IF( ABS( DFAZ).GT. ABS( DFAZ2)) DFAZ= DFAZ2
+ CDFAZ= COS( DFAZ* TA)
+ TSTOR1= ETHM2- EPHM2
+ TSTOR2=2.* EPHM* ETHM* CDFAZ
+ TILTA=.5* ATGN2( TSTOR2, TSTOR1)
+ STILTA= SIN( TILTA)
+ TSTOR1= TSTOR1* STILTA* STILTA
+ TSTOR2= TSTOR2* STILTA* COS( TILTA)
+ EMAJR2=- TSTOR1+ TSTOR2+ ETHM2
+ EMINR2= TSTOR1- TSTOR2+ EPHM2
+ IF( EMINR2.LT.0.) EMINR2=0.
+ AXRAT= SQRT( EMINR2/ EMAJR2)
+ TILTA= TILTA* TD
+ IF( AXRAT.GT.1.D-5) GOTO 14
+ ISENS= HPOL(1)
+ GOTO 16
+ 14 IF( DFAZ.GT.0.) GOTO 15
+ ISENS= HPOL(2)
+ GOTO 16
+ 15 ISENS= HPOL(3)
+ 16 GNMJ= DB10( GCON* EMAJR2)
+ GNMN= DB10( GCON* EMINR2)
+ GNV= DB10( GCON* ETHM2)
+ GNH= DB10( GCON* EPHM2)
+ GTOT= DB10( GCON*( ETHM2+ EPHM2))
+ IF( INOR.LT.1) GOTO 23
+ I= I+1
+ IF( I.GT. NORMAX) GOTO 23
+ GOTO (17,18,19,20,21), INOR
+ 17 TSTOR1= GNMJ
+ GOTO 22
+ 18 TSTOR1= GNMN
+ GOTO 22
+ 19 TSTOR1= GNV
+ GOTO 22
+ 20 TSTOR1= GNH
+ GOTO 22
+ 21 TSTOR1= GTOT
+ 22 GAIN( I)= TSTOR1
+ IF( TSTOR1.GT. GMAX) GMAX= TSTOR1
+ 23 IF( IAVP.EQ.0) GOTO 24
+ TSTOR1= GCOP*( ETHM2+ EPHM2)
+ TMP3= THA- TMP2
+ TMP4= THA+ TMP2
+ IF( KTH.EQ.1) TMP3= THA
+ IF( KTH.EQ. NTH) TMP4= THA
+ DA= ABS( TMP1*( COS( TMP3)- COS( TMP4)))
+ IF( KPH.EQ.1.OR. KPH.EQ. NPH) DA=.5* DA
+ PINT= PINT+ TSTOR1* DA
+ IF( IAVP.EQ.2) GOTO 29
+ 24 IF( IAX.EQ.1) GOTO 25
+ TMP5= GNMJ
+ TMP6= GNMN
+ GOTO 26
+ 25 TMP5= GNV
+ TMP6= GNH
+ 26 ETHM= ETHM* WLAM
+ EPHM= EPHM* WLAM
+ IF( RFLD.LT.1.D-20) GOTO 27
+ ETHM= ETHM* EXRM
+ ETHA= ETHA+ EXRA
+ EPHM= EPHM* EXRM
+ EPHA= EPHA+ EXRA
+C GO TO 29
+C***
+C28 WRITE(6,43) RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
+ 27 WRITE (6,42) THET, PHI, TMP5, TMP6, GTOT, AXRAT, TILTA, ISENS,
+ ÐM, ETHA, EPHM, EPHA
+ IF( IPLP1.NE.3) GOTO 299
+ IF( IPLP3.EQ.0) GOTO 290
+ IF( IPLP2.EQ.1.AND. IPLP3.EQ.1) WRITE( 8,*) THET, ETHM, ETHA
+ IF( IPLP2.EQ.1.AND. IPLP3.EQ.2) WRITE( 8,*) THET, EPHM, EPHA
+ IF( IPLP2.EQ.2.AND. IPLP3.EQ.1) WRITE( 8,*) PHI, ETHM, ETHA
+ IF( IPLP2.EQ.2.AND. IPLP3.EQ.2) WRITE( 8,*) PHI, EPHM, EPHA
+ IF( IPLP4.EQ.0) GOTO 299
+ 290 IF( IPLP2.EQ.1.AND. IPLP4.EQ.1) WRITE( 8,*) THET, TMP5
+ IF( IPLP2.EQ.1.AND. IPLP4.EQ.2) WRITE( 8,*) THET, TMP6
+ IF( IPLP2.EQ.1.AND. IPLP4.EQ.3) WRITE( 8,*) THET, GTOT
+ IF( IPLP2.EQ.2.AND. IPLP4.EQ.1) WRITE( 8,*) PHI, TMP5
+ IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*) PHI, TMP6
+ IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*) PHI, GTOT
+ GOTO 299
+ 28 WRITE (6,43) RFLD, PHI, THET, ETHM, ETHA, EPHM, EPHA, ERDM, ERDA
+ &
+C***
+ 299 CONTINUE
+ 29 CONTINUE
+ IF( IAVP.EQ.0) GOTO 30
+ TMP3= THETS* TA
+ TMP4= TMP3+ DTH* TA* DFLOAT( NTH-1)
+ TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4)))
+ PINT= PINT/ TMP3
+ TMP3= TMP3/ PI
+ WRITE (6,44) PINT, TMP3
+ 30 IF( INOR.EQ.0) GOTO 34
+ IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR
+ ITMP1=( INOR-1)*2+1
+ ITMP2= ITMP1+1
+ WRITE (6,45) IGNTP( ITMP1), IGNTP( ITMP2), GMAX
+ ITMP2= NPH* NTH
+ IF( ITMP2.GT. NORMAX) ITMP2= NORMAX
+ ITMP1=( ITMP2+2)/3
+ ITMP2= ITMP1*3- ITMP2
+ ITMP3= ITMP1
+ ITMP4=2* ITMP1
+ IF( ITMP2.EQ.2) ITMP4= ITMP4-1
+ DO 31 I=1, ITMP1
+ ITMP3= ITMP3+1
+ ITMP4= ITMP4+1
+ J=( I-1)/ NTH
+ TMP1= THETS+ DFLOAT( I- J* NTH-1)* DTH
+ TMP2= PHIS+ DFLOAT( J)* DPH
+ J=( ITMP3-1)/ NTH
+ TMP3= THETS+ DFLOAT( ITMP3- J* NTH-1)* DTH
+ TMP4= PHIS+ DFLOAT( J)* DPH
+ J=( ITMP4-1)/ NTH
+ TMP5= THETS+ DFLOAT( ITMP4- J* NTH-1)* DTH
+ TMP6= PHIS+ DFLOAT( J)* DPH
+ TSTOR1= GAIN( I)- GMAX
+ IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32
+ TSTOR2= GAIN( ITMP3)- GMAX
+ PINT= GAIN( ITMP4)- GMAX
+ 31 WRITE (6,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2, TMP5, TMP6,
+ & PINT
+ GOTO 34
+ 32 IF( ITMP2.EQ.2) GOTO 33
+ TSTOR2= GAIN( ITMP3)- GMAX
+ WRITE (6,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2
+ GOTO 34
+ 33 WRITE (6,46) TMP1, TMP2, TSTOR1
+C
+ 34 RETURN
+ 35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//)
+ 36 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
+ &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
+ &' METERS')
+ 37 FORMAT(40X,A6,' CLIFF',/,40X,'EDGE DISTANCE=',F9.2,' METERS',/,40
+ &X,'HEIGHT=',F8.2,' METERS',/,40X,'SECOND MEDIUM -',/,40X,'RELA',
+ &'TIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIVITY=',1P,E10.3,
+ &' MHOS')
+ 38 FORMAT(///,48X,'- - - RADIATION PATTERNS - - -')
+ 39 FORMAT(54X,'RANGE=',1P,E13.6,' METERS',/,54X,'EXP(-JKR)/R=',E12.5
+ &,' AT PHASE',0P,F7.2,' DEGREES',/)
+ 40 FORMAT(/,2X,'- - ANGLES - -',7X,2A6,'GAINS -',7X,'- - - POLARI',
+ &'ZATION - - -',4X,'- - - E(THETA) - - -',4X,'- - - E(PHI) - -',
+ &' -',/,2X,'THETA',5X,'PHI',7X,A6,2X,A6,3X,'TOTAL',6X,'AXIAL',5X,
+ &'TILT',3X,'SENSE',2(5X,'MAGNITUDE',4X,'PHASE'),/,2(1X,'DEGREES',1
+ &X),3(6X,'DB'),8X,'RATIO',5X,'DEG.',8X,2(6X,'VOLTS/M',4X,'DEGRE',
+ &'ES'))
+ 41 FORMAT(///,28X,' - - - RADIATED FIELDS NEAR GROUND - - -',//,8X,
+ &'- - - LOCATION - - -',10X,'- - E(THETA) - -',8X,'- - E(PHI) -',
+ &' -',8X,'- - E(RADIAL) - -',/,7X,'RHO',6X,'PHI',9X,'Z',12X,'MAG',
+ &6X,'PHASE',9X,'MAG',6X,'PHASE',9X,'MAG',6X,'PHASE',/,5X,'METERS',
+ &3X,'DEGREES',4X,'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3
+ &X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',/)
+ 42 FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2)
+ &)
+ 43 FORMAT(3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2))
+ 44 FORMAT(//,3X,'AVERAGE POWER GAIN=',1P,E12.5,7X,'SOLID ANGLE U',
+ &'SED IN AVERAGING=(',0P,F7.4,')*PI STERADIANS.',//)
+ 45 FORMAT(//,37X,'- - - - NORMALIZED GAIN - - - -',//,37X,2A6,'GAI',
+ &'N',/,38X,'NORMALIZATION FACTOR =',F9.2,' DB',//,3(4X,
+ &'- - ANGLES'' - -',6X,'GAIN',7X),/,3(4X,'THETA',5X,'PHI',8X,'DB',
+ &8X),/,3(3X,'DEGREES',2X,'DEGREES',16X))
+ 46 FORMAT(3(1X,2F9.2,1X,F9.2,6X))
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ INTEGER*4 NTOT
+ INTEGER*4 NINT
+ INTEGER*4 NFLT
+ PARAMETER (NTOT=9, NINT=2, NFLT=7)
+ INTEGER IARR( NINT), BP( NTOT), EP( NTOT)
+ DIMENSION RARR( NFLT)
+ CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132
+ READ (5, 10) LINE
+ 10 FORMAT(A)
+
+ NLIN= LEN(LINE)
+
+
+ CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
+ IF( NLIN.LT.2) GOTO 110
+ IF( NLIN.LE.132) GOTO 20
+ NLIN=132
+ LINE(133:133)=' '
+ 20 GM= LINE(1:2)
+ NLIN= NLIN+1
+ DO 30 I=1, NINT
+ 30 IARR( I)=0
+ DO 40 I=1, NFLT
+ 40 RARR( I)=0.0
+ IC=2
+ IFOUND=0
+ DO 70 I=1, NTOT
+ 50 IC= IC+1
+ IF( IC.GE. NLIN) GOTO 80
+ IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
+C BEGINNING OF I-TH NUMERICAL FIELD
+ BP( I)= IC
+ 60 IC= IC+1
+ IF( IC.GT. NLIN) GOTO 80
+ IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
+C END OF I-TH NUMERICAL FIELD
+ EP( I)= IC-1
+ IFOUND= I
+ 70 CONTINUE
+ 80 CONTINUE
+ DO 90 I=1, MIN( IFOUND, NINT)
+ NLEN= EP( I)- BP( I)+1
+ BUFFER= LINE( BP( I): EP( I))
+ IND= INDEX( BUFFER(1: NLEN),'.')
+ IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
+C USER PUT DECIMAL POINT FOR INTEGER
+ IF( IND.EQ. NLEN) NLEN= NLEN-1
+ READ( BUFFER(1: NLEN),111,ERR=110) IARR( I)
+111 format(i3)
+ 90 CONTINUE
+ DO 100 I= NINT+1, IFOUND
+ NLEN= EP( I)- BP( I)+1
+ BUFFER= LINE( BP( I): EP( I))
+ IND= INDEX( BUFFER(1: NLEN),'.')
+C USER FORGOT DECIMAL POINT FOR REAL
+ IF( IND.EQ.0) THEN
+ IF( NLEN.GE.15) GOTO 110
+ INDE= INDEX( BUFFER(1: NLEN),'E')
+ NLEN= NLEN+1
+ IF( INDE.EQ.0) THEN
+ BUFFER( NLEN: NLEN)='.'
+ ELSE
+ BUFFER1= BUFFER(1: INDE-1)//'.'// BUFFER( INDE: NLEN-1)
+ BUFFER= BUFFER1
+ ENDIF
+ ENDIF
+ READ( BUFFER(1: NLEN),112,ERR=110) RARR( I- NINT)
+ 112 format (F15.7)
+ 100 CONTINUE
+ I1= IARR(1)
+ I2= IARR(2)
+ X1= RARR(1)
+ Y1= RARR(2)
+ Z1= RARR(3)
+ X2= RARR(4)
+ Y2= RARR(5)
+ Z2= RARR(6)
+ RAD= RARR(7)
+ RETURN
+ 110 WRITE (6,*) ' GEOMETRY DATA CARD ERROR'
+ WRITE (6,*) LINE(1: MAX(1, NLIN-1))
+ STOP
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6)
+C ***
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ INTEGER*4 NTOT
+ INTEGER*4 NINT
+ INTEGER*4 NFLT
+ PARAMETER (NTOT=10, NINT=4, NFLT=6)
+ INTEGER IARR( NINT), BP( NTOT), EP( NTOT)
+ DIMENSION RARR( NFLT)
+ CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132
+ READ (5,10) LINE
+ 10 FORMAT(A)
+ NLIN= LEN(LINE)
+ CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
+ IF( NLIN.LT.2) GOTO 110
+ IF( NLIN.LE.132) GOTO 20
+ NLIN=132
+ LINE(133:133)=' '
+ 20 GM= LINE(1:2)
+ NLIN= NLIN+1
+ DO 30 I=1, NINT
+ 30 IARR( I)=0
+ DO 40 I=1, NFLT
+ 40 RARR( I)=0.0
+ IC=2
+ IFOUND=0
+ DO 70 I=1, NTOT
+ 50 IC= IC+1
+ IF( IC.GE. NLIN) GOTO 80
+ IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
+C BEGINNING OF I-TH NUMERICAL FIELD
+ BP( I)= IC
+ 60 IC= IC+1
+ IF( IC.GT. NLIN) GOTO 80
+ IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
+C END OF I-TH NUMERICAL FIELD
+ EP( I)= IC-1
+ IFOUND= I
+ 70 CONTINUE
+ 80 CONTINUE
+ DO 90 I=1, MIN( IFOUND, NINT)
+ NLEN= EP( I)- BP( I)+1
+ BUFFER= LINE( BP( I): EP( I))
+ IND= INDEX( BUFFER(1: NLEN),'.')
+ IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
+C USER PUT DECIMAL POINT FOR INTEGER
+ IF( IND.EQ. NLEN) NLEN= NLEN-1
+ READ( BUFFER(1: NLEN),111,ERR=110) IARR( I)
+ 111 format(I5)
+ 90 CONTINUE
+ DO 100 I= NINT+1, IFOUND
+ NLEN= EP( I)- BP( I)+1
+ BUFFER= LINE( BP( I): EP( I))
+ IND= INDEX( BUFFER(1: NLEN),'.')
+C USER FORGOT DECIMAL POINT FOR REAL
+ IF( IND.EQ.0) THEN
+ IF( NLEN.GE.15) GOTO 110
+ INDE= INDEX( BUFFER(1: NLEN),'E')
+ NLEN= NLEN+1
+ IF( INDE.EQ.0) THEN
+ BUFFER( NLEN: NLEN)='.'
+ ELSE
+ BUFFER1= BUFFER(1: INDE-1)//'.'// BUFFER( INDE: NLEN-1)
+ BUFFER= BUFFER1
+ ENDIF
+ ENDIF
+ READ( BUFFER(1: NLEN),112,ERR=110) RARR( I- NINT)
+ 112 format(F15.7)
+ 100 CONTINUE
+ I1= IARR(1)
+ I2= IARR(2)
+ I3= IARR(3)
+ I4= IARR(4)
+ F1= RARR(1)
+ F2= RARR(2)
+ F3= RARR(3)
+ F4= RARR(4)
+ F5= RARR(5)
+ F6= RARR(6)
+ RETURN
+ 110 WRITE (6,*) ' FAULTY DATA CARD AFTER GEOMETRY SECTION'
+ WRITE (6,*) LINE(1: MAX(1, NLIN-1))
+ STOP
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE REBLK( B, BX, NB, NBX, N2C)
+C ***
+C REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
+C TO BLOCKS OF COLUMNS ON TAPE16
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX B, BX
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION B( NB,1), BX( NBX,1)
+ REWIND 16
+ NIB=0
+ NPB= NPBL
+ DO 3 IB=1, NBBL
+ IF( IB.EQ. NBBL) NPB= NLBL
+ REWIND 14
+ NIX=0
+ NPX= NPBX
+ DO 2 IBX=1, NBBX
+ IF( IBX.EQ. NBBX) NPX= NLBX
+ READ( 14) (( BX( I, J), I=1, NPX), J=1, N2C)
+ DO 1 I=1, NPX
+ IX= I+ NIX
+ DO 1 J=1, NPB
+ 1 B( IX, J)= BX( I, J+ NIB)
+ 2 NIX= NIX+ NPBX
+ WRITE( 16) (( B( I, J), I=1, NB), J=1, NPB)
+ 3 NIB= NIB+ NPBL
+ REWIND 14
+ REWIND 16
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE REFLC( IX, IY, IZ, ITX, NOP)
+C ***
+C
+C REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES
+C STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /ANGL/ SALP( NM)
+ DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
+ & Y2(1), Z2(1)
+ EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
+ &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET)
+ NP= N
+ MP= M
+ IPSYM=0
+ ITI= ITX
+ IF( IX.LT.0) GOTO 19
+ IF( NOP.EQ.0) RETURN
+ IPSYM=1
+C
+C REFLECT ALONG Z AXIS
+C
+ IF( IZ.EQ.0) GOTO 6
+ IPSYM=2
+ IF( N.LT. N2) GOTO 3
+ DO 2 I= N2, N
+ NX= I+ N- N1
+ E1= Z( I)
+ E2= Z2( I)
+ IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1
+ WRITE (6,24) I
+ STOP
+ 1 X( NX)= X( I)
+ Y( NX)= Y( I)
+ Z( NX)=- E1
+ X2( NX)= X2( I)
+ Y2( NX)= Y2( I)
+ Z2( NX)=- E2
+ ITAGI= ITAG( I)
+ IF( ITAGI.EQ.0) ITAG( NX)=0
+ IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
+ 2 BI( NX)= BI( I)
+ N= N*2- N1
+ ITI= ITI*2
+ 3 IF( M.LT. M2) GOTO 6
+ NXX= LD+1- M1
+ DO 5 I= M2, M
+ NXX= NXX-1
+ NX= NXX- M+ M1
+ IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4
+ WRITE (6,25) I
+ STOP
+ 4 X( NX)= X( NXX)
+ Y( NX)= Y( NXX)
+ Z( NX)=- Z( NXX)
+ T1X( NX)= T1X( NXX)
+ T1Y( NX)= T1Y( NXX)
+ T1Z( NX)=- T1Z( NXX)
+ T2X( NX)= T2X( NXX)
+ T2Y( NX)= T2Y( NXX)
+ T2Z( NX)=- T2Z( NXX)
+ SALP( NX)=- SALP( NXX)
+ 5 BI( NX)= BI( NXX)
+ M= M*2- M1
+C
+C REFLECT ALONG Y AXIS
+C
+ 6 IF( IY.EQ.0) GOTO 12
+ IF( N.LT. N2) GOTO 9
+ DO 8 I= N2, N
+ NX= I+ N- N1
+ E1= Y( I)
+ E2= Y2( I)
+ IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7
+ WRITE (6,24) I
+ STOP
+ 7 X( NX)= X( I)
+ Y( NX)=- E1
+ Z( NX)= Z( I)
+ X2( NX)= X2( I)
+ Y2( NX)=- E2
+ Z2( NX)= Z2( I)
+ ITAGI= ITAG( I)
+ IF( ITAGI.EQ.0) ITAG( NX)=0
+ IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
+ 8 BI( NX)= BI( I)
+ N= N*2- N1
+ ITI= ITI*2
+ 9 IF( M.LT. M2) GOTO 12
+ NXX= LD+1- M1
+ DO 11 I= M2, M
+ NXX= NXX-1
+ NX= NXX- M+ M1
+ IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10
+ WRITE (6,25) I
+ STOP
+ 10 X( NX)= X( NXX)
+ Y( NX)=- Y( NXX)
+ Z( NX)= Z( NXX)
+ T1X( NX)= T1X( NXX)
+ T1Y( NX)=- T1Y( NXX)
+ T1Z( NX)= T1Z( NXX)
+ T2X( NX)= T2X( NXX)
+ T2Y( NX)=- T2Y( NXX)
+ T2Z( NX)= T2Z( NXX)
+ SALP( NX)=- SALP( NXX)
+ 11 BI( NX)= BI( NXX)
+ M= M*2- M1
+C
+C REFLECT ALONG X AXIS
+C
+ 12 IF( IX.EQ.0) GOTO 18
+ IF( N.LT. N2) GOTO 15
+ DO 14 I= N2, N
+ NX= I+ N- N1
+ E1= X( I)
+ E2= X2( I)
+ IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13
+ WRITE (6,24) I
+ STOP
+ 13 X( NX)=- E1
+ Y( NX)= Y( I)
+ Z( NX)= Z( I)
+ X2( NX)=- E2
+ Y2( NX)= Y2( I)
+ Z2( NX)= Z2( I)
+ ITAGI= ITAG( I)
+ IF( ITAGI.EQ.0) ITAG( NX)=0
+ IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
+ 14 BI( NX)= BI( I)
+ N= N*2- N1
+ 15 IF( M.LT. M2) GOTO 18
+ NXX= LD+1- M1
+ DO 17 I= M2, M
+ NXX= NXX-1
+ NX= NXX- M+ M1
+ IF( ABS( X( NXX)).GT.1.D-10) GOTO 16
+ WRITE (6,25) I
+ STOP
+ 16 X( NX)=- X( NXX)
+ Y( NX)= Y( NXX)
+ Z( NX)= Z( NXX)
+ T1X( NX)=- T1X( NXX)
+ T1Y( NX)= T1Y( NXX)
+ T1Z( NX)= T1Z( NXX)
+ T2X( NX)=- T2X( NXX)
+ T2Y( NX)= T2Y( NXX)
+ T2Z( NX)= T2Z( NXX)
+ SALP( NX)=- SALP( NXX)
+ 17 BI( NX)= BI( NXX)
+ M= M*2- M1
+C
+C REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE
+C
+ 18 RETURN
+ 19 FNOP= NOP
+ IPSYM=-1
+ SAM=6.283185308D+0/ FNOP
+ CS= COS( SAM)
+ SS= SIN( SAM)
+ IF( N.LT. N2) GOTO 21
+ N= N1+( N- N1)* NOP
+ NX= NP+1
+ DO 20 I= NX, N
+ K= I- NP+ N1
+ XK= X( K)
+ YK= Y( K)
+ X( I)= XK* CS- YK* SS
+ Y( I)= XK* SS+ YK* CS
+ Z( I)= Z( K)
+ XK= X2( K)
+ YK= Y2( K)
+ X2( I)= XK* CS- YK* SS
+ Y2( I)= XK* SS+ YK* CS
+ Z2( I)= Z2( K)
+ ITAGI= ITAG( K)
+ IF( ITAGI.EQ.0) ITAG( I)=0
+ IF( ITAGI.NE.0) ITAG( I)= ITAGI+ ITI
+ 20 BI( I)= BI( K)
+ 21 IF( M.LT. M2) GOTO 23
+ M= M1+( M- M1)* NOP
+ NX= MP+1
+ K= LD+1- M1
+ DO 22 I= NX, M
+ K= K-1
+ J= K- MP+ M1
+ XK= X( K)
+ YK= Y( K)
+ X( J)= XK* CS- YK* SS
+ Y( J)= XK* SS+ YK* CS
+ Z( J)= Z( K)
+ XK= T1X( K)
+ YK= T1Y( K)
+ T1X( J)= XK* CS- YK* SS
+ T1Y( J)= XK* SS+ YK* CS
+ T1Z( J)= T1Z( K)
+ XK= T2X( K)
+ YK= T2Y( K)
+ T2X( J)= XK* CS- YK* SS
+ T2Y( J)= XK* SS+ YK* CS
+ T2Z( J)= T2Z( K)
+ SALP( J)= SALP( K)
+ 22 BI( J)= BI( K)
+C
+ 23 RETURN
+ 24 FORMAT(' GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S',
+ &'YMMETRY')
+ 25 FORMAT(' GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM',
+ &'METRY')
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE ROM2( A, B, SUM, DMIN)
+C ***
+C
+C FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE
+C SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND. THE METHOD OF
+C VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED. THERE ARE 9
+C FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT,
+C SINE, AND COSINE CURRENT DISTRIBUTIONS.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX SUM, G1, G2, G3, G4, G5, T00, T01, T10, T02, T11, T20
+ &
+ DIMENSION SUM(9), G1(9), G2(9), G3(9), G4(9), G5(9), T01(9), T10
+ &(9), T20(9)
+ DATA NM, NTS, NX, N/65536,4,1,9/, RX/1.D-4/
+ Z= A
+ ZE= B
+ S= B- A
+ IF( S.GE.0.) GOTO 1
+ WRITE (6,18)
+ STOP
+ 1 EP= S/(1.E4* NM)
+ ZEND= ZE- EP
+ DO 2 I=1, N
+ 2 SUM( I)=(0.,0.)
+ NS= NX
+ NT=0
+ CALL SFLDS( Z, G1)
+ 3 DZ= S/ NS
+ IF( Z+ DZ.LE. ZE) GOTO 4
+ DZ= ZE- Z
+ IF( DZ.LE. EP) GOTO 17
+ 4 DZOT= DZ*.5
+ CALL SFLDS( Z+ DZOT, G3)
+ CALL SFLDS( Z+ DZ, G5)
+ 5 TMAG1=0.
+C
+C EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE.
+C
+ TMAG2=0.
+ DO 6 I=1, N
+ T00=( G1( I)+ G5( I))* DZOT
+ T01( I)=( T00+ DZ* G3( I))*.5
+ T10( I)=(4.* T01( I)- T00)/3.
+ IF( I.GT.3) GOTO 6
+ TR= REAL( T01( I))
+ TI= AIMAG( T01( I))
+ TMAG1= TMAG1+ TR* TR+ TI* TI
+ TR= REAL( T10( I))
+ TI= AIMAG( T10( I))
+ TMAG2= TMAG2+ TR* TR+ TI* TI
+ 6 CONTINUE
+ TMAG1= SQRT( TMAG1)
+ TMAG2= SQRT( TMAG2)
+ CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
+ IF( TR.GT. RX) GOTO 8
+ DO 7 I=1, N
+ 7 SUM( I)= SUM( I)+ T10( I)
+ NT= NT+2
+ GOTO 12
+ 8 CALL SFLDS( Z+ DZ*.25, G2)
+ CALL SFLDS( Z+ DZ*.75, G4)
+ TMAG1=0.
+C
+C EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE.
+C
+ TMAG2=0.
+ DO 9 I=1, N
+ T02=( T01( I)+ DZOT*( G2( I)+ G4( I)))*.5
+ T11=(4.* T02- T01( I))/3.
+ T20( I)=(16.* T11- T10( I))/15.
+ IF( I.GT.3) GOTO 9
+ TR= REAL( T11)
+ TI= AIMAG( T11)
+ TMAG1= TMAG1+ TR* TR+ TI* TI
+ TR= REAL( T20( I))
+ TI= AIMAG( T20( I))
+ TMAG2= TMAG2+ TR* TR+ TI* TI
+ 9 CONTINUE
+ TMAG1= SQRT( TMAG1)
+ TMAG2= SQRT( TMAG2)
+ CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
+ IF( TR.GT. RX) GOTO 14
+ 10 DO 11 I=1, N
+ 11 SUM( I)= SUM( I)+ T20( I)
+ NT= NT+1
+ 12 Z= Z+ DZ
+ IF( Z.GT. ZEND) GOTO 17
+ DO 13 I=1, N
+ 13 G1( I)= G5( I)
+ IF( NT.LT. NTS.OR. NS.LE. NX) GOTO 3
+ NS= NS/2
+ NT=1
+ GOTO 3
+ 14 NT=0
+ IF( NS.LT. NM) GOTO 15
+ WRITE (6,19) Z
+ GOTO 10
+ 15 NS= NS*2
+ DZ= S/ NS
+ DZOT= DZ*.5
+ DO 16 I=1, N
+ G5( I)= G3( I)
+ 16 G3( I)= G2( I)
+ GOTO 5
+ 17 CONTINUE
+C
+ RETURN
+ 18 FORMAT(' ERROR - B LESS THAN A IN ROM2')
+ 19 FORMAT(' ROM2 -- STEP SIZE LIMITED AT Z =',1P,E12.5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE SBF( I, IS, AA, BB, CC)
+C ***
+C COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ DATA PI/3.141592654D+0/, JMAX/30/
+ AA=0.
+ BB=0.
+ CC=0.
+ JUNE=0
+ JSNO=0
+ PP=0.
+ JCOX= ICON1( I)
+ IF( JCOX.GT.10000) JCOX= I
+ JEND=-1
+ IEND=-1
+ SIG=-1.
+ IF( JCOX) 1,11,2
+ 1 JCOX=- JCOX
+ GOTO 3
+ 2 SIG=- SIG
+ JEND=- JEND
+ 3 JSNO= JSNO+1
+ IF( JSNO.GE. JMAX) GOTO 24
+ D= PI* SI( JCOX)
+ SDH= SIN( D)
+ CDH= COS( D)
+ SD=2.* SDH* CDH
+ IF( D.GT.0.015) GOTO 4
+ OMC=4.* D* D
+ OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
+ GOTO 5
+ 4 OMC=1.- CDH* CDH+ SDH* SDH
+ 5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
+ PP= PP- OMC/ SD* AJ
+ IF( JCOX.NE. IS) GOTO 6
+ AA= AJ/ SD* SIG
+ BB= AJ/(2.* CDH)
+ CC=- AJ/(2.* SDH)* SIG
+ JUNE= IEND
+ 6 IF( JCOX.EQ. I) GOTO 9
+ IF( JEND.EQ.1) GOTO 7
+ JCOX= ICON1( JCOX)
+ GOTO 8
+ 7 JCOX= ICON2( JCOX)
+ 8 IF( IABS( JCOX).EQ. I) GOTO 10
+ IF( JCOX) 1,24,2
+ 9 IF( JCOX.EQ. IS) BB=- BB
+ 10 IF( IEND.EQ.1) GOTO 12
+ 11 PM=- PP
+ PP=0.
+ NJUN1= JSNO
+ JCOX= ICON2( I)
+ IF( JCOX.GT.10000) JCOX= I
+ JEND=1
+ IEND=1
+ SIG=-1.
+ IF( JCOX) 1,12,2
+ 12 NJUN2= JSNO- NJUN1
+ D= PI* SI( I)
+ SDH= SIN( D)
+ CDH= COS( D)
+ SD=2.* SDH* CDH
+ CD= CDH* CDH- SDH* SDH
+ IF( D.GT.0.015) GOTO 13
+ OMC=4.* D* D
+ OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
+ GOTO 14
+ 13 OMC=1.- CD
+ 14 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
+ AJ= AP
+ IF( NJUN1.EQ.0) GOTO 19
+ IF( NJUN2.EQ.0) GOTO 21
+ QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
+ QM=( AP* OMC- PP* SD)/ QP
+ QP=-( AJ* OMC+ PM* SD)/ QP
+ IF( JUNE) 15,18,16
+ 15 AA= AA* QM
+ BB= BB* QM
+ CC= CC* QM
+ GOTO 17
+ 16 AA=- AA* QP
+ BB= BB* QP
+ CC=- CC* QP
+ 17 IF( I.NE. IS) RETURN
+ 18 AA= AA-1.
+ BB= BB+( AJ* QM+ AP* QP)* SDH/ SD
+ CC= CC+( AJ* QM- AP* QP)* CDH/ SD
+ RETURN
+ 19 IF( NJUN2.EQ.0) GOTO 23
+ QP= PI* BI( I)
+ XXI= QP* QP
+ XXI= QP*(1.-.5* XXI)/(1.- XXI)
+ QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
+ IF( JUNE.NE.1) GOTO 20
+ AA=- AA* QP
+ BB= BB* QP
+ CC=- CC* QP
+ IF( I.NE. IS) RETURN
+ 20 AA= AA-1.
+ D= CD- XXI* SD
+ BB= BB+( SDH+ AP* QP*( CDH- XXI* SDH))/ D
+ CC= CC+( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
+ RETURN
+ 21 QM= PI* BI( I)
+ XXI= QM* QM
+ XXI= QM*(1.-.5* XXI)/(1.- XXI)
+ QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
+ IF( JUNE.NE.-1) GOTO 22
+ AA= AA* QM
+ BB= BB* QM
+ CC= CC* QM
+ IF( I.NE. IS) RETURN
+ 22 AA= AA-1.
+ D= CD- XXI* SD
+ BB= BB+( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
+ CC= CC+( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
+ RETURN
+ 23 AA=-1.
+ QP= PI* BI( I)
+ XXI= QP* QP
+ XXI= QP*(1.-.5* XXI)/(1.- XXI)
+ CC=1./( CDH- XXI* SDH)
+ RETURN
+ 24 WRITE (6,25) I
+C
+ STOP
+ 25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE SFLDS( T, E)
+C ***
+C
+C SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON
+C THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX E, ERV, EZV, ERH, EZH, EPH, T1, EXK, EYK, EZK, EXS,
+ &EYS, EZS, EXC, EYC, EZC, XX1, XX2, U, U2, ZRATI, ZRATI2, FRATI,
+ &ER, ET, HRV, HZV, HRH
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
+ COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ DIMENSION E(9)
+ DATA PI/3.141592654D+0/, TP/6.283185308D+0/, POT/1.570796327D+0
+ &/
+ XT= XJ+ T* CABJ
+ YT= YJ+ T* SABJ
+ ZT= ZJ+ T* SALPJ
+ RHX= XO- XT
+ RHY= YO- YT
+ RHS= RHX* RHX+ RHY* RHY
+ RHO= SQRT( RHS)
+ IF( RHO.GT.0.) GOTO 1
+ RHX=1.
+ RHY=0.
+ PHX=0.
+ PHY=1.
+ GOTO 2
+ 1 RHX= RHX/ RHO
+ RHY= RHY/ RHO
+ PHX=- RHY
+ PHY= RHX
+ 2 CPH= RHX* XSN+ RHY* YSN
+ SPH= RHY* XSN- RHX* YSN
+ IF( ABS( CPH).LT.1.D-10) CPH=0.
+ IF( ABS( SPH).LT.1.D-10) SPH=0.
+ ZPH= ZO+ ZT
+ ZPHS= ZPH* ZPH
+ R2S= RHS+ ZPHS
+ R2= SQRT( R2S)
+ RK= R2* TP
+ XX2= CMPLX( COS( RK),- SIN( RK))
+C
+C USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND. CURRENT IS
+C LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE,
+C OR COSINE DISTRIBUTION.
+C
+ IF( ISNOR.EQ.1) GOTO 3
+ ZMH=1.
+ R1=1.
+ XX1=0.
+ CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
+ ET=-(0.,4.77134)* FRATI* XX2/( R2S* R2)
+ ER=2.* ET* CMPLX(1.0, RK)
+ ET= ET* CMPLX(1.0 - RK* RK, RK)
+ HRV=( ER+ ET)* RHO* ZPH/ R2S
+ HZV=( ZPHS* ER- RHS* ET)/ R2S
+ HRH=( RHS* ER- ZPHS* ET)/ R2S
+ ERV= ERV- HRV
+ EZV= EZV- HZV
+ ERH= ERH+ HRH
+ EZH= EZH+ HRV
+ EPH= EPH+ ET
+ ERV= ERV* SALPJ
+ EZV= EZV* SALPJ
+ ERH= ERH* SN* CPH
+ EZH= EZH* SN* CPH
+ EPH= EPH* SN* SPH
+ ERH= ERV+ ERH
+ E(1)=( ERH* RHX+ EPH* PHX)* S
+ E(2)=( ERH* RHY+ EPH* PHY)* S
+ E(3)=( EZV+ EZH)* S
+ E(4)=0.
+ E(5)=0.
+ E(6)=0.
+ SFAC= PI* S
+ SFAC= SIN( SFAC)/ SFAC
+ E(7)= E(1)* SFAC
+ E(8)= E(2)* SFAC
+ E(9)= E(3)* SFAC
+C
+C INTERPOLATE IN SOMMERFELD FIELD TABLES
+C
+ RETURN
+ 3 IF( RHO.LT.1.D-12) GOTO 4
+ THET= ATAN( ZPH/ RHO)
+ GOTO 5
+ 4 THET= POT
+C COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z
+C COMPONENTS. MULTIPLY BY EXP(-JKR)/R.
+ 5 CALL INTRP( R2, THET, ERV, EZV, ERH, EPH)
+ XX2= XX2/ R2
+ SFAC= SN* CPH
+ ERH= XX2*( SALPJ* ERV+ SFAC* ERH)
+ EZH= XX2*( SALPJ* EZV- SFAC* ERV)
+C X,Y,Z FIELDS FOR CONSTANT CURRENT
+ EPH= SN* SPH* XX2* EPH
+ E(1)= ERH* RHX+ EPH* PHX
+ E(2)= ERH* RHY+ EPH* PHY
+ E(3)= EZH
+C X,Y,Z FIELDS FOR SINE CURRENT
+ RK= TP* T
+ SFAC= SIN( RK)
+ E(4)= E(1)* SFAC
+ E(5)= E(2)* SFAC
+C X,Y,Z FIELDS FOR COSINE CURRENT
+ E(6)= E(3)* SFAC
+ SFAC= COS( RK)
+ E(7)= E(1)* SFAC
+ E(8)= E(2)* SFAC
+ E(9)= E(3)* SFAC
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE SOLGF( A, B, C, D, XY, IP, NP, N1, N, MP, M1, M, N1C,
+ &N2C, N2CZ)
+C ***
+C SOLVE FOR CURRENT IN N.G.F. PROCEDURE
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, B, C, D, SUM, XY, Y
+ COMMON /SCRATM/ Y( N2M)
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A(1), B( N1C,1), C( N1C,1), D( N2CZ,1), IP(1), XY(1)
+ IFL=14
+ IF( ICASX.GT.0) IFL=13
+C NORMAL SOLUTION. NOT N.G.F.
+ IF( N2C.GT.0) GOTO 1
+ CALL SOLVES( A, IP, XY, N1C,1, NP, N, MP, M,13, IFL)
+ GOTO 22
+C REORDER EXCITATION ARRAY
+ 1 IF( N1.EQ. N.OR. M1.EQ.0) GOTO 5
+ N2= N1+1
+ JJ= N+1
+ NPM= N+2* M1
+ DO 2 I= N2, NPM
+ 2 Y( I)= XY( I)
+ J= N1
+ DO 3 I= JJ, NPM
+ J= J+1
+ 3 XY( J)= Y( I)
+ DO 4 I= N2, N
+ J= J+1
+ 4 XY( J)= Y( I)
+ 5 NEQS= NSCON+2* NPCON
+ IF( NEQS.EQ.0) GOTO 7
+ NEQ= N1C+ N2C
+C COMPUTE INV(A)E1
+ NEQS= NEQ- NEQS+1
+ DO 6 I= NEQS, NEQ
+ 6 XY( I)=(0.,0.)
+ 7 CALL SOLVES( A, IP, XY, N1C,1, NP, N1, MP, M1,13, IFL)
+ NI=0
+C COMPUTE E2-C(INV(A)E1)
+ NPB= NPBL
+ DO 10 JJ=1, NBBL
+ IF( JJ.EQ. NBBL) NPB= NLBL
+ IF( ICASX.GT.1) READ( 15) (( C( I, J), I=1, N1C), J=1, NPB)
+ II= N1C+ NI
+ DO 9 I=1, NPB
+ SUM=(0.,0.)
+ DO 8 J=1, N1C
+ 8 SUM= SUM+ C( J, I)* XY( J)
+ J= II+ I
+ 9 XY( J)= XY( J)- SUM
+ 10 NI= NI+ NPBL
+ REWIND 15
+C COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
+ JJ= N1C+1
+ IF( ICASX.GT.1) GOTO 11
+ CALL SOLVE( N2C, D, IP( JJ), XY( JJ), N2C)
+ GOTO 13
+ 11 IF( ICASX.EQ.4) GOTO 12
+ NI= N2C* N2C
+ READ( 11) ( B( J,1), J=1, NI)
+ REWIND 11
+ CALL SOLVE( N2C, B, IP( JJ), XY( JJ), N2C)
+ GOTO 13
+ 12 NBLSYS= NBLSYM
+ NPSYS= NPSYM
+ NLSYS= NLSYM
+ ICASS= ICASE
+ NBLSYM= NBBL
+ NPSYM= NPBL
+ NLSYM= NLBL
+ ICASE=3
+ REWIND 11
+ REWIND 16
+ CALL LTSOLV( B, N2C, IP( JJ), XY( JJ), N2C,1,11,16)
+ REWIND 11
+ REWIND 16
+ NBLSYM= NBLSYS
+ NPSYM= NPSYS
+ NLSYM= NLSYS
+ ICASE= ICASS
+ 13 NI=0
+C COMPUTE INV(A)E1-(INV(A)B)I2 = I1
+ NPB= NPBL
+ DO 16 JJ=1, NBBL
+ IF( JJ.EQ. NBBL) NPB= NLBL
+ IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
+ II= N1C+ NI
+ DO 15 I=1, N1C
+ SUM=(0.,0.)
+ DO 14 J=1, NPB
+ JP= II+ J
+ 14 SUM= SUM+ B( I, J)* XY( JP)
+ 15 XY( I)= XY( I)- SUM
+ 16 NI= NI+ NPBL
+ REWIND 14
+C REORDER CURRENT ARRAY
+ IF( N1.EQ. N.OR. M1.EQ.0) GOTO 20
+ DO 17 I= N2, NPM
+ 17 Y( I)= XY( I)
+ JJ= N1C+1
+ J= N1
+ DO 18 I= JJ, NPM
+ J= J+1
+ 18 XY( J)= Y( I)
+ DO 19 I= N2, N1C
+ J= J+1
+ 19 XY( J)= Y( I)
+ 20 IF( NSCON.EQ.0) GOTO 22
+ J= NEQS-1
+ DO 21 I=1, NSCON
+ J= J+1
+ JJ= ISCON( I)
+ 21 XY( JJ)= XY( J)
+ 22 RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE SOLVE( N, A, IP, B, NDIM)
+C ***
+C
+C SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT
+C LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH
+C OF WHICH ARE STORED IN A. THE RHS VECTOR B IS INPUT AND THE
+C SOLUTION IS RETURNED THROUGH VECTOR B. (MATRIX TRANSPOSED.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, B, Y, SUM
+ INTEGER PI
+ COMMON /SCRATM/ Y( N2M)
+C
+C FORWARD SUBSTITUTION
+C
+ DIMENSION A( NDIM, NDIM), IP( NDIM), B( NDIM)
+ DO 3 I=1, N
+ PI= IP( I)
+ Y( I)= B( PI)
+ B( PI)= B( I)
+ IP1= I+1
+ IF( IP1.GT. N) GOTO 2
+ DO 1 J= IP1, N
+ B( J)= B( J)- A( I, J)* Y( I)
+ 1 CONTINUE
+ 2 CONTINUE
+C
+C BACKWARD SUBSTITUTION
+C
+ 3 CONTINUE
+ DO 6 K=1, N
+ I= N- K+1
+ SUM=(0.,0.)
+ IP1= I+1
+ IF( IP1.GT. N) GOTO 5
+ DO 4 J= IP1, N
+ SUM= SUM+ A( J, I)* B( J)
+ 4 CONTINUE
+ 5 CONTINUE
+ B( I)=( Y( I)- SUM)/ A( I, I)
+ 6 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE SOLVES( A, IP, B, NEQ, NRH, NP, N, MP, M, IFL1, IFL2)
+C ***
+C
+C SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE
+C TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE
+C MATRIX EQ.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX A, B, Y, SUM, SSX
+ COMMON /SMAT/ SSX(16,16)
+ COMMON /SCRATM/ Y( N2M)
+ COMMON /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
+ &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
+ DIMENSION A(1), IP(1), B( NEQ, NRH)
+ NPEQ= NP+2* MP
+ NOP= NEQ/ NPEQ
+ FNOP= NOP
+ FNORM=1./ FNOP
+ NROW= NEQ
+ IF( ICASE.GT.3) NROW= NPEQ
+ IF( NOP.EQ.1) GOTO 11
+ DO 10 IC=1, NRH
+ IF( N.EQ.0.OR. M.EQ.0) GOTO 6
+ DO 1 I=1, NEQ
+ 1 Y( I)= B( I, IC)
+ KK=2* MP
+ IA= NP
+ IB= N
+ J= NP
+ DO 5 K=1, NOP
+ IF( K.EQ.1) GOTO 3
+ DO 2 I=1, NP
+ IA= IA+1
+ J= J+1
+ 2 B( J, IC)= Y( IA)
+ IF( K.EQ. NOP) GOTO 5
+ 3 DO 4 I=1, KK
+ IB= IB+1
+ J= J+1
+ 4 B( J, IC)= Y( IB)
+C
+C TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
+C
+ 5 CONTINUE
+ 6 DO 10 I=1, NPEQ
+ DO 7 K=1, NOP
+ IA= I+( K-1)* NPEQ
+ 7 Y( K)= B( IA, IC)
+ SUM= Y(1)
+ DO 8 K=2, NOP
+ 8 SUM= SUM+ Y( K)
+ B( I, IC)= SUM* FNORM
+ DO 10 K=2, NOP
+ IA= I+( K-1)* NPEQ
+ SUM= Y(1)
+ DO 9 J=2, NOP
+ 9 SUM= SUM+ Y( J)* CONJG( SSX( K, J))
+ 10 B( IA, IC)= SUM* FNORM
+ 11 IF( ICASE.LT.3) GOTO 12
+ REWIND IFL1
+C
+C SOLVE EACH MODE EQUATION
+C
+ REWIND IFL2
+ 12 DO 16 KK=1, NOP
+ IA=( KK-1)* NPEQ+1
+ IB= IA
+ IF( ICASE.NE.4) GOTO 13
+ I= NPEQ* NPEQ
+ READ( IFL1) ( A( J), J=1, I)
+ IB=1
+ 13 IF( ICASE.EQ.3.OR. ICASE.EQ.5) GOTO 15
+ DO 14 IC=1, NRH
+ 14 CALL SOLVE( NPEQ, A( IB), IP( IA), B( IA, IC), NROW)
+ GOTO 16
+ 15 CALL LTSOLV( A, NPEQ, IP( IA), B( IA,1), NEQ, NRH, IFL1, IFL2)
+ 16 CONTINUE
+C
+C INVERSE TRANSFORM THE MODE SOLUTIONS
+C
+ IF( NOP.EQ.1) RETURN
+ DO 26 IC=1, NRH
+ DO 20 I=1, NPEQ
+ DO 17 K=1, NOP
+ IA= I+( K-1)* NPEQ
+ 17 Y( K)= B( IA, IC)
+ SUM= Y(1)
+ DO 18 K=2, NOP
+ 18 SUM= SUM+ Y( K)
+ B( I, IC)= SUM
+ DO 20 K=2, NOP
+ IA= I+( K-1)* NPEQ
+ SUM= Y(1)
+ DO 19 J=2, NOP
+ 19 SUM= SUM+ Y( J)* SSX( K, J)
+ 20 B( IA, IC)= SUM
+ IF( N.EQ.0.OR. M.EQ.0) GOTO 26
+ DO 21 I=1, NEQ
+ 21 Y( I)= B( I, IC)
+ KK=2* MP
+ IA= NP
+ IB= N
+ J= NP
+ DO 25 K=1, NOP
+ IF( K.EQ.1) GOTO 23
+ DO 22 I=1, NP
+ IA= IA+1
+ J= J+1
+ 22 B( IA, IC)= Y( J)
+ IF( K.EQ. NOP) GOTO 25
+ 23 DO 24 I=1, KK
+ IB= IB+1
+ J= J+1
+ 24 B( IB, IC)= Y( J)
+ 25 CONTINUE
+ 26 CONTINUE
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE TBF( I, ICAP)
+C ***
+C COMPUTE BASIS FUNCTION I
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ DATA PI/3.141592654D+0/, JMAX/30/
+ JSNO=0
+ PP=0.
+ JCOX= ICON1( I)
+ IF( JCOX.GT.10000) JCOX= I
+ JEND=-1
+ IEND=-1
+ SIG=-1.
+ IF( JCOX) 1,10,2
+ 1 JCOX=- JCOX
+ GOTO 3
+ 2 SIG=- SIG
+ JEND=- JEND
+ 3 JSNO= JSNO+1
+ IF( JSNO.GE. JMAX) GOTO 28
+ JCO( JSNO)= JCOX
+ D= PI* SI( JCOX)
+ SDH= SIN( D)
+ CDH= COS( D)
+ SD=2.* SDH* CDH
+ IF( D.GT.0.015) GOTO 4
+ OMC=4.* D* D
+ OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
+ GOTO 5
+ 4 OMC=1.- CDH* CDH+ SDH* SDH
+ 5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
+ PP= PP- OMC/ SD* AJ
+ AX( JSNO)= AJ/ SD* SIG
+ BX( JSNO)= AJ/(2.* CDH)
+ CX( JSNO)=- AJ/(2.* SDH)* SIG
+ IF( JCOX.EQ. I) GOTO 8
+ IF( JEND.EQ.1) GOTO 6
+ JCOX= ICON1( JCOX)
+ GOTO 7
+ 6 JCOX= ICON2( JCOX)
+ 7 IF( IABS( JCOX).EQ. I) GOTO 9
+ IF( JCOX) 1,28,2
+ 8 BX( JSNO)=- BX( JSNO)
+ 9 IF( IEND.EQ.1) GOTO 11
+ 10 PM=- PP
+ PP=0.
+ NJUN1= JSNO
+ JCOX= ICON2( I)
+ IF( JCOX.GT.10000) JCOX= I
+ JEND=1
+ IEND=1
+ SIG=-1.
+ IF( JCOX) 1,11,2
+ 11 NJUN2= JSNO- NJUN1
+ JSNOP= JSNO+1
+ JCO( JSNOP)= I
+ D= PI* SI( I)
+ SDH= SIN( D)
+ CDH= COS( D)
+ SD=2.* SDH* CDH
+ CD= CDH* CDH- SDH* SDH
+ IF( D.GT.0.015) GOTO 12
+ OMC=4.* D* D
+ OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
+ GOTO 13
+ 12 OMC=1.- CD
+ 13 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
+ AJ= AP
+ IF( NJUN1.EQ.0) GOTO 16
+ IF( NJUN2.EQ.0) GOTO 20
+ QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
+ QM=( AP* OMC- PP* SD)/ QP
+ QP=-( AJ* OMC+ PM* SD)/ QP
+ BX( JSNOP)=( AJ* QM+ AP* QP)* SDH/ SD
+ CX( JSNOP)=( AJ* QM- AP* QP)* CDH/ SD
+ DO 14 IEND=1, NJUN1
+ AX( IEND)= AX( IEND)* QM
+ BX( IEND)= BX( IEND)* QM
+ 14 CX( IEND)= CX( IEND)* QM
+ JEND= NJUN1+1
+ DO 15 IEND= JEND, JSNO
+ AX( IEND)=- AX( IEND)* QP
+ BX( IEND)= BX( IEND)* QP
+ 15 CX( IEND)=- CX( IEND)* QP
+ GOTO 27
+ 16 IF( NJUN2.EQ.0) GOTO 24
+ IF( ICAP.NE.0) GOTO 17
+ XXI=0.
+ GOTO 18
+ 17 QP= PI* BI( I)
+ XXI= QP* QP
+ XXI= QP*(1.-.5* XXI)/(1.- XXI)
+ 18 QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
+ D= CD- XXI* SD
+ BX( JSNOP)=( SDH+ AP* QP*( CDH- XXI* SDH))/ D
+ CX( JSNOP)=( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
+ DO 19 IEND=1, NJUN2
+ AX( IEND)=- AX( IEND)* QP
+ BX( IEND)= BX( IEND)* QP
+ 19 CX( IEND)=- CX( IEND)* QP
+ GOTO 27
+ 20 IF( ICAP.NE.0) GOTO 21
+ XXI=0.
+ GOTO 22
+ 21 QM= PI* BI( I)
+ XXI= QM* QM
+ XXI= QM*(1.-.5* XXI)/(1.- XXI)
+ 22 QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
+ D= CD- XXI* SD
+ BX( JSNOP)=( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
+ CX( JSNOP)=( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
+ DO 23 IEND=1, NJUN1
+ AX( IEND)= AX( IEND)* QM
+ BX( IEND)= BX( IEND)* QM
+ 23 CX( IEND)= CX( IEND)* QM
+ GOTO 27
+ 24 BX( JSNOP)=0.
+ IF( ICAP.NE.0) GOTO 25
+ XXI=0.
+ GOTO 26
+ 25 QP= PI* BI( I)
+ XXI= QP* QP
+ XXI= QP*(1.-.5* XXI)/(1.- XXI)
+ 26 CX( JSNOP)=1./( CDH- XXI* SDH)
+ 27 JSNO= JSNOP
+ AX( JSNO)=-1.
+ RETURN
+ 28 WRITE (6,29) I
+C
+ STOP
+ 29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE TEST( F1R, F2R, TR, F1I, F2I, TI, DMIN)
+C ***
+C
+C TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ DEN= ABS( F2R)
+ TR= ABS( F2I)
+ IF( DEN.LT. TR) DEN= TR
+ IF( DEN.LT. DMIN) DEN= DMIN
+ IF( DEN.LT.1.D-37) GOTO 1
+ TR= ABS(( F1R- F2R)/ DEN)
+ TI= ABS(( F1I- F2I)/ DEN)
+ RETURN
+ 1 TR=0.
+ TI=0.
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE TRIO( J)
+C ***
+C COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ COMMON /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
+ &NSCON, IPCON(10), NPCON
+ DATA JMAX/30/
+ JSNO=0
+ JCOX= ICON1( J)
+ IF( JCOX.GT.10000) GOTO 7
+ JEND=-1
+ IEND=-1
+ IF( JCOX) 1,7,2
+ 1 JCOX=- JCOX
+ GOTO 3
+ 2 JEND=- JEND
+ 3 IF( JCOX.EQ. J) GOTO 6
+ JSNO= JSNO+1
+ IF( JSNO.GE. JMAX) GOTO 9
+ CALL SBF( JCOX, J, AX( JSNO), BX( JSNO), CX( JSNO))
+ JCO( JSNO)= JCOX
+ IF( JEND.EQ.1) GOTO 4
+ JCOX= ICON1( JCOX)
+ GOTO 5
+ 4 JCOX= ICON2( JCOX)
+ 5 IF( JCOX) 1,9,2
+ 6 IF( IEND.EQ.1) GOTO 8
+ 7 JCOX= ICON2( J)
+ IF( JCOX.GT.10000) GOTO 8
+ JEND=1
+ IEND=1
+ IF( JCOX) 1,8,2
+ 8 JSNO= JSNO+1
+ CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO))
+ JCO( JSNO)= J
+ RETURN
+ 9 WRITE (6,10) J
+C
+ STOP
+ 10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5)
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE UNERE( XOB, YOB, ZOB)
+C ***
+C CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
+C DIRECTIONS ON A PATCH
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMPLEX EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
+ &ZRATI2, T1, ER, Q1, Q2, RRV, RRH, EDP, FRATI
+ COMMON /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
+ &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
+ &INDD2, IPGND
+ COMMON /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
+ &KSYMP, IFAR, IPERF, T1, T2
+ EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
+ &IND1),(T2ZJ,IND2)
+C CONST=ETA/(8.*PI**2)
+ DATA TPI, CONST/6.283185308D+0,4.771341188D+0/
+ ZR= ZJ
+ T1ZR= T1ZJ
+ T2ZR= T2ZJ
+ IF( IPGND.NE.2) GOTO 1
+ ZR=- ZR
+ T1ZR=- T1ZR
+ T2ZR=- T2ZR
+ 1 RX= XOB- XJ
+ RY= YOB- YJ
+ RZ= ZOB- ZR
+ R2= RX* RX+ RY* RY+ RZ* RZ
+ IF( R2.GT.1.D-20) GOTO 2
+ EXK=(0.,0.)
+ EYK=(0.,0.)
+ EZK=(0.,0.)
+ EXS=(0.,0.)
+ EYS=(0.,0.)
+ EZS=(0.,0.)
+ RETURN
+ 2 R= SQRT( R2)
+ TT1=- TPI* R
+ TT2= TT1* TT1
+ RT= R2* R
+ ER= CMPLX( SIN( TT1),- COS( TT1))*( CONST* S)
+ Q1= CMPLX( TT2-1., TT1)* ER/ RT
+ Q2= CMPLX(3.- TT2,-3.* TT1)* ER/( RT* R2)
+ ER= Q2*( T1XJ* RX+ T1YJ* RY+ T1ZR* RZ)
+ EXK= Q1* T1XJ+ ER* RX
+ EYK= Q1* T1YJ+ ER* RY
+ EZK= Q1* T1ZR+ ER* RZ
+ ER= Q2*( T2XJ* RX+ T2YJ* RY+ T2ZR* RZ)
+ EXS= Q1* T2XJ+ ER* RX
+ EYS= Q1* T2YJ+ ER* RY
+ EZS= Q1* T2ZR+ ER* RZ
+ IF( IPGND.EQ.1) GOTO 6
+ IF( IPERF.NE.1) GOTO 3
+ EXK=- EXK
+ EYK=- EYK
+ EZK=- EZK
+ EXS=- EXS
+ EYS=- EYS
+ EZS=- EZS
+ GOTO 6
+ 3 XYMAG= SQRT( RX* RX+ RY* RY)
+ IF( XYMAG.GT.1.D-6) GOTO 4
+ PX=0.
+ PY=0.
+ CTH=1.
+ RRV=(1.,0.)
+ GOTO 5
+ 4 PX=- RY/ XYMAG
+ PY= RX/ XYMAG
+ CTH= RZ/ SQRT( XYMAG* XYMAG+ RZ* RZ)
+ RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
+ 5 RRH= ZRATI* CTH
+ RRH=( RRH- RRV)/( RRH+ RRV)
+ RRV= ZRATI* RRV
+ RRV=-( CTH- RRV)/( CTH+ RRV)
+ EDP=( EXK* PX+ EYK* PY)*( RRH- RRV)
+ EXK= EXK* RRV+ EDP* PX
+ EYK= EYK* RRV+ EDP* PY
+ EZK= EZK* RRV
+ EDP=( EXS* PX+ EYS* PY)*( RRH- RRV)
+ EXS= EXS* RRV+ EDP* PX
+ EYS= EYS* RRV+ EDP* PY
+ EZS= EZS* RRV
+ 6 RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ SUBROUTINE WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, RDEL, RRAD,
+ &NS, ITG)
+C ***
+C
+C SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT
+C WIRE OF NS SEGMENTS.
+C
+ IMPLICIT REAL (A-H,O-Z)
+ PARAMETER ( NM=600, N2M=800, N3M=1000)
+ COMMON /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
+ &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
+ & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
+ DIMENSION X2(1), Y2(1), Z2(1)
+ EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
+ IST= N+1
+ N= N+ NS
+ NP= N
+ MP= M
+ IPSYM=0
+ IF( NS.LT.1) RETURN
+ XD= XW2- XW1
+ YD= YW2- YW1
+ ZD= ZW2- ZW1
+ IF( ABS( RDEL-1.).LT.1.D-6) GOTO 1
+ DELZ= SQRT( XD* XD+ YD* YD+ ZD* ZD)
+ XD= XD/ DELZ
+ YD= YD/ DELZ
+ ZD= ZD/ DELZ
+ DELZ= DELZ*(1.- RDEL)/(1.- RDEL** NS)
+ RD= RDEL
+ GOTO 2
+ 1 FNS= NS
+ XD= XD/ FNS
+ YD= YD/ FNS
+ ZD= ZD/ FNS
+ DELZ=1.
+ RD=1.
+ 2 RADZ= RAD
+ XS1= XW1
+ YS1= YW1
+ ZS1= ZW1
+ DO 3 I= IST, N
+ ITAG( I)= ITG
+ XS2= XS1+ XD* DELZ
+ YS2= YS1+ YD* DELZ
+ ZS2= ZS1+ ZD* DELZ
+ X( I)= XS1
+ Y( I)= YS1
+ Z( I)= ZS1
+ X2( I)= XS2
+ Y2( I)= YS2
+ Z2( I)= ZS2
+ BI( I)= RADZ
+ DELZ= DELZ* RD
+ RADZ= RADZ* RRAD
+ XS1= XS2
+ YS1= YS2
+ 3 ZS1= ZS2
+ X2( N)= XW2
+ Y2( N)= YW2
+ Z2( N)= ZW2
+ RETURN
+ END
+C ***
+C DOUBLE PRECISION 6/4/85
+C
+ COMPLEX FUNCTION ZINT( SIGL, ROLAM)
+C ***
+C
+C ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE
+C
+C
+ IMPLICIT REAL (A-H,O-Z)
+ COMPLEX TH, PH, F, G, FJ, CN, BR1, BR2
+ COMPLEX CC1, CC2, CC3, CC4, CC5, CC6, CC7, CC8, CC9, CC10,
+ &CC11, CC12, CC13, CC14
+ DIMENSION FJX(2), CNX(2), CCN(28)
+ EQUIVALENCE(FJ,FJX),(CN,CNX),(CC1,CCN(1)),(CC2,CCN(3)),(CC3,CCN(5
+ &)),(CC4,CCN(7)),(CC5,CCN(9)),(CC6,CCN(11)),(CC7,CCN(13)),(CC8,CCN
+ &(15)),(CC9,CCN(17)),(CC10,CCN(19)),(CC11,CCN(21)),(CC12,CCN(23)),
+ &(CC13,CCN(25)),(CC14,CCN(27))
+ DATA PI, POT, TP, TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0,
+ &2.368705D+3/
+ DATA CMOTP/60.00/, FJX/0.,1./, CNX/.70710678D+0,.70710678D+0/
+ DATA CCN/6.D-7,1.9D-6,-3.4D-6,5.1D-6,-2.52D-5,0.,-9.06D-5,-
+ &9.01D-5,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,
+ &1.6D-6,-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-
+ &1.3813D-3,1.3811D-3,-6.25001D-2,-1.D-7,.7071068D+0,.7071068D+0/
+ TH( D)=((((( CC1* D+ CC2)* D+ CC3)* D+ CC4)* D+ CC5)* D+ CC6)* D+
+ & CC7
+ PH( D)=((((( CC8* D+ CC9)* D+ CC10)* D+ CC11)* D+ CC12)* D+ CC13)
+ &* D+ CC14
+ F( D)= SQRT( POT/ D)* EXP(- CN* D+ TH(-8./ X))
+ G( D)= EXP( CN* D+ TH(8./ X))/ SQRT( TP* D)
+ X= SQRT( TPCMU* SIGL)* ROLAM
+ IF( X.GT.110.) GOTO 2
+ IF( X.GT.8.) GOTO 1
+ Y= X/8.
+ Y= Y* Y
+ S= Y* Y
+ BER=((((((-9.01D-6* S+1.22552D-3)* S-.08349609D+0)* S+
+ &2.6419140D+0)* S-32.363456D+0)* S+113.77778D+0)* S-64.)* S+1.
+ BEI=((((((1.1346D-4* S-.01103667D+0)* S+.52185615D+0)* S-
+ &10.567658D+0)* S+72.817777D+0)* S-113.77778D+0)* S+16.)* Y
+ BR1= CMPLX( BER, BEI)
+ BER=(((((((-3.94D-6* S+4.5957D-4)* S-.02609253D+0)* S+
+ &.66047849D+0)* S-6.0681481D+0)* S+14.222222D+0)* S-4.)* Y)* X
+ BEI=((((((4.609D-5* S-3.79386D-3)* S+.14677204D+0)* S-
+ &2.3116751D+0)* S+11.377778D+0)* S-10.666667D+0)* S+.5)* X
+ BR2= CMPLX( BER, BEI)
+ BR1= BR1/ BR2
+ GOTO 3
+ 1 BR2= FJ* F( X)/ PI
+ BR1= G( X)+ BR2
+ BR2= G( X)* PH(8./ X)- BR2* PH(-8./ X)
+ BR1= BR1/ BR2
+ GOTO 3
+ 2 BR1= CMPLX(.70710678D+0,-.70710678D+0)
+ 3 ZINT= FJ* SQRT( CMOTP/ SIGL)* BR1/ ROLAM
+ RETURN
+ END
+
+C .. Convert a string to upper case
+ SUBROUTINE STR0PC( STRING, STRING1)
+ CHARACTER *(*) STRING, STRING1
+ INTEGER*4 I, IC
+ INTEGER IS_PC
+
+ IS_PC = 0
+
+ DO 150, I=1, LEN( STRING)
+ IC= ICHAR( STRING( I: I))
+
+ IF (IS_PC .NE. 0) THEN
+ IF( IC.GE.97.AND. IC.LE.122) IC= IC-32
+ ENDIF
+
+ STRING1( I: I)= CHAR( IC)
+ 150 CONTINUE
+
+ RETURN
+ END
+
+
+ SUBROUTINE FILEERR(MSG, FILE)
+ IMPLICIT NONE
+ CHARACTER *(*) MSG,FILE
+ INTEGER I
+
+ DO I=LEN(FILE),1,-1
+ IF (FILE(I:I).NE.' ') GOTO 100
+ ENDDO
+
+ 100 CONTINUE
+
+ PRINT *, 'Error:'
+ PRINT *, MSG
+ PRINT *, FILE(1:I)
+ RETURN
+ END
+
